#lang racket
(require "../base/com.rkt")
(require "../com.rkt"
"../base/coord.rkt"
(except-in "../proxies/main.rkt" id))
(provide load-rhino4-com
load-rhino5-com
singleton-id
singleton-id?
create-preview-image-honor-flag
create-preview-image-draw-flag
create-preview-image-ghosted-flag
domain-direction-u
domain-direction-v
knot-style-uniform-knots
knot-style-chord-length-spacing
knot-style-sqrt
knot-style-periodic-uniform-spacing
knot-style-periodic-chord-length-spacing
knot-style-periodic-sqrt
loft-type-normal
loft-type-loose
loft-type-straight
loft-type-tight
loft-type-developable
loft-style-none
loft-style-rebuild
loft-style-refit
optional
view-display-mode-wireframe
view-display-mode-shaded
view-display-mode-render-preview
view-perspective
view-projection-mode-parallel
view-projection-mode-perspective
clear-command-history
close-curve
com-omit
command
duplicate-edge-curves
intersect-breps
join-surfaces
surface-curvature
view-camera-lens
view-camera-target
view-display-mode
view-projection
view-radius
view-size
(rename-out (world-x-y-plane world-xy-plane))
(rename-out (world-y-z-plane world-yz-plane))
(rename-out (world-z-x-plane world-zx-plane))
zoom-selected)
(define create-preview-image-honor-flag 1)
(define create-preview-image-draw-flag 2)
(define create-preview-image-ghosted-flag 4)
(define domain-direction-u 0)
(define domain-direction-v 1)
(define knot-style-uniform-knots 0)
(define knot-style-chord-length-spacing 1)
(define knot-style-sqrt 2)
(define knot-style-periodic-uniform-spacing 3)
(define knot-style-periodic-chord-length-spacing 4)
(define knot-style-periodic-sqrt 5)
(define optional com-omit)
(define view-display-mode-wireframe 0)
(define view-display-mode-shaded 1)
(define view-display-mode-render-preview 2)
(define view-perspective "Perspective")
(define view-projection-mode-parallel 1)
(define view-projection-mode-perspective 2)
(define rhino-com-msg "Waiting for Rhinoceros3D to be ready...")
(define (rhino-invoke name . args)
(apply com-invoke rhino-coobject name args))
(define (rhino-check-invoke name . args)
(error "Convert this")
(let ((val (apply rhino-invoke name args)))
(if (void? val)
(raise-com-exn "COM error. Got no results from ~A: ~A" name args)
val)))
(define rhino-coclass #f)
(define rhino-coobject #f)
(define (load-rhino-com progid)
(set! rhino-coclass
(let ((clsid (progid->clsid progid)))
(with-handlers ((exn?
(λ (e)
(displayln "Starting Rhinoceros 3D...")
(com-create-instance clsid))))
(com-get-active-object clsid))))
(com-set-property! rhino-coclass "Visible" true)
(set! rhino-coobject
(try-void-connection
rhino-com-msg
(λ () (com-invoke rhino-coclass "GetScriptObject")))))
(define (load-rhino4-com)
(load-rhino-com "Rhino4.Interface"))
(define (load-rhino5-com)
(load-rhino-com "Rhino5x64.Interface"))
(define id string)
(define (arr-ids v)
(cond ((string? v)
(vector v))
((pair? v)
(let ((vl (flatten v)))
(if (andmap string? vl)
(list->vector vl)
(expected "string or tree of strings" v))))
(else
(expected "string or tree of strings" v))))
(define (ids v)
(if (void? v)
(raise-com-exn "Expecting a vector of strings but got void")
(vector->list v)))
(define (maybe-ids v)
(if (void? v)
(list)
(ids v)))
(define (ids-or-false v)
(if (void? v)
#f
(ids v)))
(define (singleton-id v)
(cond ((string? v)
v)
((vector? v)
(if (= 1 (vector-length v))
(vector-ref v 0)
(expected "string or vector (or list) with one string" v)))
((list? v)
(if (and (not (null? v)) (null? (cdr v)))
(car v)
(expected "string or vector (or list) with one string" v)))
(else
(expected "string or vector (or list) with one string" v))))
(define (singleton-id? v)
(cond ((string? v)
#t)
((vector? v)
(= 1 (vector-length v)))
((list? v)
(and (not (null? v)) (null? (cdr v))))
(else
#f)))
(define (plane-from-base c)
(let ((x (exact->inexact (xyz-x c)))
(y (exact->inexact (xyz-y c)))
(z (exact->inexact (xyz-z c))))
(vector x y z 1.0 0.0 0.0 0.0 1.0 0.0)))
(define (plane c/m/p)
(let ((arr
(cond ((position? c/m/p)
(let ((p (as-world c/m/p)))
(let ((cs (position-cs c/m/p)))
(vector (vector<-xyz p)
(vector<-xyz (cs-x cs))
(vector<-xyz (cs-y cs))
(vector<-xyz (cs-z cs))))))
((matrix? c/m/p)
(plane<-matrix c/m/p)) ((vector? c/m/p) c/m/p)
(else
(error "don't do that!")
c/m/p))))
(type-describe
arr
'(array 4 (variant (array 3 double))))))
(define (rh-plane v)
(check-expected
(lambda (v)
(and (= 4 (vector-length v))
(for/and ((e (in-vector v)))
(vector? e))))
"vector of vectors" v))
(define (rh-matrix arr)
(type-describe
arr
'(array 4 (array 4 any))))
(define (flat-plane p)
(let ((v (make-vector 12)))
(vector-copy! v 0 (vector-ref p 0))
(vector-copy! v 3 (vector-ref p 1))
(vector-copy! v 6 (vector-ref p 2))
(vector-copy! v 9 (vector-ref p 3))
v))
(define (plane<-matrix m)
(vector
(vector-drop-right (m-column m 3) 1)
(vector-drop-right (m-column m 0) 1)
(vector-drop-right (m-column m 1) 1)
(vector-drop-right (m-column m 2) 1)))
(define (matrix<-nested-plane pl)
(m-cols (vector-ref pl 1)
(vector-ref pl 2)
(vector-ref pl 3)
(vector-ref pl 0))
)
(define (matrix<-rhino-matrix v)
(error "Finish this")
)
(define (list<-intersection-array v)
(coord<-vector (vector-ref (vector-ref v 0) 1)))
(define (matrix->rh-matrix m)
(type-describe
(vector (m-line m 0)
(m-line m 1)
(m-line m 2)
(vector 0 0 0 1))
'(array 4 (array 4 any))))
(define (array-4array-int vals)
(begin type-describe
(apply vector-append (vector->list vals))
`(array ,(* (vector-length vals) 4) int)))
(define-syntax (def stx)
(syntax-case stx ()
((def name ins out)
(syntax/loc stx
(def-com rhino-coobject name ins out)))))
(def add-arc (plane radius angle) id)
(def add-box (arr-points) id)
(def add-circle (plane radius) id)
(def add-cone (point point radius #:opt boolean) id)
(def (add-cone-from-plane "AddCone") (plane real radius #:opt boolean) id)
(def add-curve (arr-points #:opt integer) id)
(def add-cut-plane (arr-ids point point #:opt point) id)
(def add-cylinder (point point radius #:opt boolean) id)
(def (add-cylinder-from-plane "AddCylinder") (plane real radius #:opt boolean) id)
(def add-edge-srf (arr-ids) id)
(def add-ellipse (plane radius radius) id)
(def add-hatch (id #:opt name real angle) id)
(define knot-style integer) (def add-interp-curve (arr-points #:opt integer knot-style point point) id)
(def add-interp-curve-ex (arr-points #:opt integer knot-style boolean point point) id)
(def add-layer (#:opt name integer boolean boolean name) identity)
(def add-line (point point) id)
(provide loft-type-normal
loft-type-loose
loft-type-straight
loft-type-tight
loft-type-developable)
(define loft-type-normal 0)
(define loft-type-loose 1)
(define loft-type-straight 2)
(define loft-type-tight 3)
(define loft-type-developable 4)
(define loft-style-none 0)
(define loft-style-rebuild 1)
(define loft-style-refit 2)
(define loft-type integer)
(define loft-simplify integer)
(def add-loft-srf
(arr-ids #:opt (start point) (end point) loft-type loft-simplify number (closed? boolean))
singleton-id)
(def add-material-to-layer (string) integer)
(def add-mesh (arr-pointss (vertices array-4array-int)) id)
(def add-nurbs-surface
((arr-point-count list->vector)
arr-pointss
(arr-knot-u arr-reals) (arr-knot-v arr-reals)
(arr-degree list->vector)
#:opt (arr-weights arr-realss))
id)
(def add-planar-srf (arr-ids) singleton-id)
(def (add-planar-srfs "AddPlanarSrf") (arr-ids) maybe-ids)
(def add-plane-surface (plane real real) id)
(def add-point (point) id)
(def add-polyline (arr-points) id)
(def add-rev-srf (id arr-points #:opt angle angle) id)
(def add-sphere (point radius) id)
(def add-srf-contour-crvs (id plane real) ids)
(def add-srf-pt (arr-points) id)
(def add-srf-pt-grid (arr-ints arr-points #:opt arr-ints arr-booleans) id)
(def add-srf-section-crvs (id plane) maybe-ids)
(define text-style integer)
(def add-text (string plane #:opt positive-real string text-style) id)
(def add-torus (point real real #:opt point) id)
(def (add-torus2 "AddTorus") (plane real real) id)
(def all-objects (#:opt (select? boolean) (include-lights? boolean) (include-grips? boolean)) maybe-ids)
(def boolean-difference (arr-ids arr-ids #:opt boolean) ids)
(def boolean-intersection (arr-ids arr-ids #:opt boolean) ids)
(def boolean-union (arr-ids #:opt boolean) ids)
(def (boolean-difference2 "BooleanDifference") (arr-ids arr-ids #:opt boolean) ids-or-false)
(def (boolean-intersection2 "BooleanIntersection") (arr-ids arr-ids #:opt boolean) ids-or-false)
(def (boolean-union2 "BooleanUnion") (arr-ids #:opt boolean) ids-or-false)
(define (bbox-corners<-vector v)
(list (coord<-vector (vector-ref v 0))
(coord<-vector (vector-ref v 6))))
(def bounding-box (arr-ids) coords<-vector)
(def (bounding-box-corners "BoundingBox") (arr-ids) bbox-corners<-vector)
(def brep-closest-point (id point) identity)
(def cap-planar-holes (id) boolean)
(provide capped-planar-holes)
(define (capped-planar-holes id)
(if (or (is-object-solid id)
(cap-planar-holes id))
id
(error 'capped-planar-holes "couldn't cap planar holes of shape ~A" id)))
(def circle-center-point (id) coord<-vector)
(def circle-radius (id) number)
(def clear-command-history () void)
(def close-curve (id #:opt tolerance) id)
(def command (string #:opt (echo? boolean)) boolean)
(def copy-object (id #:opt point point) id)
(def copy-objects (arr-ids #:opt point point) ids)
(define bitmap-creation-flags integer)
(def create-preview-image
((file string) #:opt (view string) (size list->vector) bitmap-creation-flags (wireframe? boolean))
boolean)
(def create-solid (arr-ids #:opt delete?) singleton-id)
(def current-layer (#:opt name) name)
(def current-view (#:opt name) name)
(def curve-boolean-difference (id id) ids)
(def curve-boolean-intersection (id id) ids)
(def curve-boolean-union (id id) ids)
(def curve-curve-intersection (id #:opt id real) list<-intersection-array)
(def curve-closest-point (id point #:opt integer) real)
(def curve-domain (id) vector->list)
(def curve-end-point (id) coord<-vector)
(def curve-evaluate (id real #:opt integer) coords<-vector)
(def curve-frame (id real) matrix<-nested-plane)
(def curve-parameter (id real) real)
(def curve-perp-frame (id real) matrix<-nested-plane)
(def curve-normal (id) coord<-vector)
(def curve-points (id) coords<-vector)
(def curve-seam (id real) boolean)
(def curve-start-point (id) coord<-vector)
(def curve-tangent (id real #:opt integer) coord<-vector)
(def delete-layer (name) boolean)
(def delete-object (id) boolean)
(def (delete-existing-objects "DeleteObjects") (arr-ids) integer)
(provide delete-objects)
(define (delete-objects ids)
(if (null? ids)
0
(delete-existing-objects ids)))
(def duplicate-edge-curves (id #:opt boolean) ids)
(def duplicate-surface-border (id) ids)
(def ellipse-center-point (id) coord<-vector)
(def enable-redraw (#:opt boolean) boolean)
(def evaluate-curve (id real #:opt integer) coord<-vector)
(def evaluate-surface (id arr-reals) coord<-vector)
(def extract-iso-curve (id arr-reals integer) ids)
(def extrude-curve ((curve id) (path id)) id)
(def extrude-curve-point ((curve id) point) id)
(def extrude-curve-straight ((curve id) point point) id)
(def extrude-surface ((surface id) (curve id) #:opt (cap boolean)) id)
(define (maybe-singleton ids)
(if (and (pair? ids)
(null? (cdr ids)))
(car ids)
ids))
(provide extrude)
(define (extrude id dir)
(if (is-curve id)
(extrude-curve-straight id (u0) dir)
(let ((c (car (surface-area-centroid id))))
(let ((curve (add-curve (list c (+c c dir)))))
(begin0
(extrude-surface id curve #t)
(delete-object curve))))
(maybe-singleton
(map capped-planar-holes
(map (lambda (b)
(begin0
(extrude-curve-straight b (u0) dir)
(delete-object b))
(duplicate-surface-border id)))))))
(define get-object-type integer)
(def get-integer (#:opt (message string) integer integer integer) integer)
(def get-object (#:opt (message string) (type get-object-type) (pre-select? boolean) (select? boolean) (objects arr-ids)) id)
(def get-point ((message string) #:opt point radius (plane? boolean)) coord<-vector)
(def get-real (#:opt (message string) real real real) real)
(def intersect-breps (id id #:opt tolerance) maybe-ids)
(def is-circle (id) boolean)
(def is-curve (id #:opt integer) boolean)
(def is-curve-closed (id #:opt integer) boolean)
(def is-curve-closable (id #:opt tolerance) boolean)
(def is-ellipse (string) boolean)
(def is-layer (string) boolean)
(def is-line (id) boolean)
(def is-mesh (id) boolean)
(def is-object (id) boolean)
(def is-object-in-box (id arr-points boolean) boolean)
(def is-object-solid (id) boolean)
(def is-point-in-surface (id point) boolean)
(def is-polycurve (id) boolean)
(def is-polyline (id) boolean)
(def is-polysurface (id) boolean)
(def is-polysurface-closed (id) boolean)
(def is-polysurface-planar (id) boolean)
(def is-point (id) boolean)
(def is-surface (id) boolean)
(def is-view-maximized (string) boolean)
(def last-created-objects (#:opt boolean integer) ids)
(def join-curves (arr-ids #:opt delete? tolerance) singleton-id)
(def join-surfaces (arr-ids #:opt delete?) id)
(def material-name (integer #:opt string) string)
(def maximize-restore-view (string) void)
(def mesh-faces (id boolean) coords<-vector)
(def mesh-face-normals (id) coords<-vector)
(def mesh-offset (id real) id)
(def move-object (id point #:opt point) id)
(def move-objects (arr-ids point #:opt point) ids)
(def mirror-object (id point point #:opt boolean) id)
(def mirror-objects (arr-ids point point #:opt boolean) ids)
(def object-layer (id #:opt name) name)
(def offset-curve (id point real #:opt point integer) ids)
(def offset-surface (id real) id)
(def plane-from-frame ((o point) (x point) (y point)) rh-plane)
(def plane-from-normal (point normal) matrix<-nested-plane rh-plane)
(def plane-from-points ((o point) (x point) (y point)) rh-plane)
(def point-coordinates (id #:opt point) coord<-vector)
(def point-in-planar-closed-curve (point id #:opt plane real) integer)
(def purge-layer (name) name)
(def rename-layer ((old-name name) (new-name name)) name)
(def render-resolution (#:opt list->vector) vector->list)
(provide revolve)
(define (revolve id p0 p1 a0 a1)
(cond ((is-curve id)
(add-rev-srf id
(list p0 p1)
(radians->degrees a0)
(radians->degrees a1)))
((or (is-surface id) (is-polysurface id))
(let ((border (singleton-id (duplicate-surface-border id))))
(begin0
(capped-planar-holes
(add-rev-srf border
(list p0 p1)
(radians->degrees a0)
(radians->degrees a1)))
(delete-object border))))
(else
(error 'revolve "Can't revolve the shape ~A" id))))
(def rotate-plane (plane angle (axis point)) rh-plane)
(def rotate-object (id point angle #:opt (axis point) (copy? boolean)) id)
(def rotate-objects (arr-ids point angle #:opt (axis point) (copy? boolean)) ids)
(def scale-object (id point (scale point) (copy? boolean)) id)
(def scale-objects (arr-ids point (scale point) (copy? boolean)) ids)
(def select-object (id) boolean)
(def (select-existing-objects "selectObjects") (arr-ids) integer)
(provide select-objects)
(define (select-objects objects)
(if (empty? objects)
#f
(select-existing-objects objects)))
(def selected-objects (#:opt (include-lights? boolean) (include-grips? boolean)) maybe-ids)
(def split-brep ((brep id) (cutter id) #:opt delete?) maybe-ids)
(def surface-area-centroid (id) coords<-vector)
(def surface-closest-point (id point) vector->list)
(define (surface-curvature object uv)
(let ((curvature
(rhino-check-invoke
"SurfaceCurvature"
object
(vector (real (first uv)) (real (second uv))))))
(list
(coord<-vector (vector-ref curvature 0))
(coord<-vector (vector-ref curvature 1))
(vector-ref curvature 2)
(coord<-vector (vector-ref curvature 3))
(vector-ref curvature 4)
(coord<-vector (vector-ref curvature 5))
(vector-ref curvature 6)
(vector-ref curvature 7))))
(def surface-domain (id integer) vector->list)
(def surface-frame (id arr-reals) rh-plane matrix<-nested-plane)
(def surface-normal (id arr-reals) coord<-vector)
(def surface-volume (id) numbers)
(def surface-volume-centroid (id) coords<-vector)
(def add-sweep1 (id arr-ids #:opt point point boolean integer point integer number) singleton-id)
(def add-sweep2 (arr-ids arr-ids #:opt point point boolean boolean boolean integer number) singleton-id)
(provide sweep)
(define (sweep path shape)
(let* ((plane (curve-perp-frame path (curve-parameter path 0.0)))
(bb (bounding-box-corners shape))
(c (/c (+c (car bb) (cadr bb)) 2)))
(move-object shape (*c c -1))
(transform-objects shape plane)
(cond ((is-curve shape)
(add-sweep1 path shape))
((is-surface shape)
(extrude-surface shape path #t)
(let ((border (duplicate-surface-border shape)))
(begin0
(capped-planar-holes
(add-sweep1 path border))
(delete-existing-objects border)
(add-sweep1 path (list shape)))))
(else
(error "Continue this")))))
(def transform-object (id matrix->rh-matrix #:opt boolean) id)
(def (transform-object-special "TransformObject") (id rh-matrix #:opt boolean) id)
(def transform-objects (arr-ids matrix->rh-matrix #:opt boolean) ids)
(def unit-absolute-tolerance (#:opt tolerance boolean) number)
(def unselect-all-objects () integer)
(def unselect-object (id) boolean)
(def unselect-objects (arr-ids) integer)
(def unselected-objects (#:opt (include-lights? boolean) (include-grips? boolean)) maybe-ids)
(define (unselected-objects . args)
(with-handlers ((com-exn? (λ (e) (list))))
(vector->list
(match args
((list) (rhino-check-invoke "UnselectedObjects"))
((list include-lights?) (rhino-check-invoke "UnselectedObjects" include-lights?))
((list include-lights? include-grips?) (rhino-check-invoke "UnselectedObjects" include-lights? include-grips?))))))
(def vector-create (point point) coord<-vector)
(def vector-unitize (point) coord<-vector)
(def view-c-plane (#:opt string plane) matrix<-nested-plane)
(def view-camera (#:opt (view string) (camera point)) coord<-vector)
(def view-camera-lens (#:opt (view string) (length real)) number)
(def view-camera-target (#:opt (view string) (camera point) (target point)) coords<-vector)
(define view-camera-target
(case-lambda
(() (rhino-check-invoke "ViewCameraTarget"))
((view) (rhino-check-invoke "ViewCameraTarget" view))
((view camera)
(list<coord><-vector<vector<real>>
(rhino-check-invoke
"ViewCameraTarget"
view
(point camera))))
((view camera target)
(list<coord><-vector<vector<real>>
(rhino-check-invoke
"ViewCameraTarget"
view
(point camera)
(point target))))))
(def view-display-mode (#:opt string integer) integer)
(def view-projection (#:opt string integer) integer)
(def view-radius (#:opt (view string) (radius radius)) number)
(def view-size (#:opt string) vector->list)
(def view-target (#:opt (view string) (target point)) coord<-vector)
(def xform-change-basis (plane plane) identity matrix<-nested-plane)
(def (xform-change-basis2 "XformChangeBasis") (identity identity identity identity identity identity) identity)
(def window-handle () identity)
(def world-x-y-plane () matrix<-nested-plane rh-plane)
(def world-y-z-plane () matrix<-nested-plane rh-plane)
(def world-z-x-plane () matrix<-nested-plane rh-plane)
(def zoom-extents (#:opt string boolean) void)
(def zoom-selected (#:opt string boolean) void)
(provide thicken)
(define (thicken object distance)
(unselect-all-objects)
(select-object object)
(command (format "OffsetSrf Solid=Yes ~A _Enter" distance))
(begin0
(singleton-id (last-created-objects))
(unselect-all-objects)))
(provide create-solid-command)
(define (create-solid-command ids)
(unselect-all-objects)
(select-objects ids)
(command (format "CreateSolid"))
(begin0
(singleton-id (last-created-objects))
(unselect-all-objects)))
(provide brep-closest-uv)
(define (brep-closest-uv id p)
(vector->list (vector-ref (brep-closest-point id p) 1)))
(provide brep-closest-normal)
(define (brep-closest-normal id p)
(coord<-vector (vector-ref (brep-closest-point id p) 3)))
(provide point-in-surface)
(define (point-in-surface id)
(coord<-vector (vector-ref (brep-closest-point id (u0)) 0)))
(provide render-view)
(define (render-view path)
(command "_-Render")
(command (format "_-SaveRenderWindowAs ~A" path))
(command "_-CloseRenderWindow"))