#lang at-exp racket (require scribble/srcdoc) (require (for-doc racket/base scribble/manual)) (require (for-syntax racket/syntax)) (require "base/coord.rkt" "base/bounding-box.rkt" ;"base/main.rkt" (only-in "com.rkt" debug-com step-com) (prefix-in ac: "autocad/ac-com.rkt") (prefix-in rh: "rhinoceros3d/rh-com.rkt") ;(prefix-in gl: "opengl/opengl.rkt") (prefix-in gl: "opengl/opengl.rkt") (prefix-in tz: "tikz/tikz.rkt") ) ;(provide (all-from-out (prefix-in ac: "autocad/ac-com.rkt"))) (provide debug-com step-com) #| |# ;;Utilities to be moved to some other place: (provide division) (define-sequence-syntax division (lambda () #'division/proc) (lambda (stx) (syntax-case stx () [[(v) (clause from to elems)] #'[(v) (clause from to elems #t)]] [[(v) (_ from to elems last?)] #`[(v) (:do-in ([(a) from] [(b) to] [(n) elems] #,@(case (syntax-e #'last?) ((#t #f) #'()) (else #'([(pred) (if last? <= <)])))) (unless (exact-positive-integer? n) (raise-type-error 'division "exact non-negative integer" n)) ([i 0]) (#,(case (syntax-e #'last?) ((#t) #'<=) ((#f) #'<) (else #'pred)) i n) ([(v) (+ a (/ (* i (- b a)) n))]) #true #true ((+ i 1)))]]))) (define (division/proc a b n [last? #t]) (if last? (for/list ([t (division a b n #t)]) t) (for/list ([t (division a b n #f)]) t))) (provide map-division) (define map-division (case-lambda ((f t0 t1 n) (for/list ((t (division t0 t1 n))) (f t))) ((f t0 t1 n last?) (for/list ((t (division t0 t1 n last?))) (f t))) ((f u0 u1 nu v0 v1 nv) (for/list ((u (division u0 u1 nu))) (for/list ((v (division v0 v1 nv))) (f u v)))) ((f u0 u1 nu lastu? v0 v1 nv) (for/list ((u (division u0 u1 nu lastu?))) (for/list ((v (division v0 v1 nv))) (f u v)))) ((f u0 u1 nu lastu? v0 v1 nv lastv?) (for/list ((u (division u0 u1 nu lastu?))) (for/list ((v (division v0 v1 nv lastv?))) (f u v)))))) (provide in-interval) (define-sequence-syntax in-interval (lambda () #'in-interval/proc) (lambda (stx) (syntax-case stx () [[(v) (_ from to elems)] #'[(v) (:do-in ([(a) from] [(b) to] [(n) elems]) (unless (exact-positive-integer? n) (raise-type-error 'in-interval "exact non-negative integer" n)) ([i 0]) (<= i n) ([(v) (+ a (/ (* i (- b a)) n))]) #true #true ((+ i 1)))]]))) (define (in-interval/proc a b n) (for/list ([t (in-interval a b n)]) t)) (provide in-period) (define-sequence-syntax in-period (lambda () #'in-period/proc) (lambda (stx) (syntax-case stx () [[(v) (_ from to elems)] #'[(v) (:do-in ([(a) from] [(b) to] [(n) elems]) (unless (exact-positive-integer? n) (raise-type-error 'in-period "exact non-negative integer" n)) ([i 0]) (< i n) ([(v) (+ a (/ (* i (- b a)) n))]) #true #true ((+ i 1)))]]))) (define (in-period/proc a b n) (for/list ([t (in-period a b n)]) t)) (provide map-in-interval map-in-period) (define map-in-interval (case-lambda ((f t0 t1 n) (for/list ((t (in-interval t0 t1 n))) (f t))) ((f u0 u1 nu v0 v1 nv) (for/list ((u (in-interval u0 u1 nu))) (for/list ((v (in-interval v0 v1 nv))) (f u v)))))) (define map-in-period (case-lambda ((f t0 t1 n) (for/list ((t (in-period t0 t1 n))) (f t))) ((f u0 u1 nu v0 v1 nv) (for/list ((u (in-period u0 u1 nu))) (for/list ((v (in-period v0 v1 nv))) (f u v)))))) ;;HACK: highly inneficient ;; (define-syntax (for/append stx) ;; (syntax-case stx () ;; [(_ clauses . defs+exprs) ;; (with-syntax ([original stx]) ;; #'(for/fold/derived ;; original ;; ([r (list)]) clauses ;; (values (append r (let () . defs+exprs))))]))) (define (singleton? l) (and (not (null? l)) (null? (cdr l)))) (define (singleton-value l) (if (singleton? l) (car l) (error 'singleton-value "Not a singleton ~A" l))) (provide asinh acosh atanh) (define (asinh x) (log (+ x (sqrt (+ (* x x) 1))))) (define (acosh x) (log (+ x (sqrt (- (* x x) 1))))) (define (atanh x) (if (< (abs x) 1) (/ (log (/ (+ 1 x) (- 1 x))) 2) (/ (log (/ (+ x 1) (- x 1))) 2))) (struct backend (name) #:property prop:custom-write (lambda (b port mode) (fprintf port "#<~a>" (backend-name b)))) ;;Available backends (provide autocad rhino opengl tikz delayed) (define autocad (backend "AutoCAD")) (define rhino (backend "Rhinoceros")) (define tikz (backend "TikZ")) (define opengl (backend "OpenGL")) ;;The delayed backend constructs delayed ;;shapes, to be instantiated later in a ;;concrete backend. (define delayed (backend "Unknown")) ;;The current out backend is the one active at ;;a given moment, used only during shape creation (provide current-out-backend) (define current-out-backend (make-parameter delayed)) ;;The current in backend is the one active at ;;a given moment, used only during shape acquisition (provide current-in-backend) (define current-in-backend (make-parameter delayed)) ;;Each shape is represented by a structure that contains ;;the name of the shape, the backend that was used for ;;the creation, and an opaque value representing the actual ;;shape in that backend. (struct shape ([name #:mutable] [backend #:mutable] [ref #:mutable] id [deleted? #:mutable]) #:property prop:custom-write (lambda (s port mode) (fprintf port "#<~A~A ~A>" (if (shape-deleted? s) "deleted " "") (shape-name s) (shape-id s)))) (define incr (let ((counter -1)) (lambda () (set! counter (+ counter 1)) counter))) (define (new-shape name backend ref) (if (shape? ref) (let ((base-name (shape-name ref))) (let ((name (cons name (if (list? base-name) base-name (list base-name))))) (shape name backend (shape-ref ref) (incr) #f))) (shape name backend ref (incr) #f))) ;;There are two modes of operation: ;;1. Immediate mode: Each operation causes immediate action on the current-out-backend ;;2. Delayed mode: Uses the delayed backend and a special print that realizes shapes. (provide delayed-mode?) (define delayed-mode? (make-parameter #f)) ;;For the delayed backend, we also store ;;the function and args needed for reconstructing the ;;shape whenever necessary. (struct delayed-shape shape (fn args)); [tm #:auto]) ;#:auto-value #f #;m-identity) ;;That's the job of the realize function (provide realize) (define (realize v) (cond ((pair? v) (cons (realize (car v)) (realize (cdr v)))) ((delayed-shape? v) ;(printf "Shape: ~a ref:~a~%" v (shape-ref v)) (when (shape-deleted? v) ;;nuke the previous reference (set-shape-ref! v #f)) (unless (shape-ref v) (let ((realization (apply (delayed-shape-fn v) (map realize (delayed-shape-args v))))) ;;There are various options here: ;;1. Preserve the backend, so that operations can still access the original values ;(set-shape-ref! v realization) ;;2. Use the realization backend (and ref) so that operations use the realization backend (set-shape-ref! v (shape-ref realization)) (set-shape-backend! v (shape-backend realization)))) v) (else v))) ;;The realize function is called whenever we try to visualize ;;(print, in Racket terms) the delayed shape (define default-current-print (current-print)) (define (rosetta-print value) (default-current-print (parameterize ((delayed-mode? #f)) (realize value)))) (provide immediate-mode) (define (immediate-mode) (delayed-mode? #f) (current-print default-current-print)) (provide delayed-mode) (define (delayed-mode) (delayed-mode? #t) (current-print rosetta-print)) ;;Some backends cannot compute certain intermediate ;;shapes, although they can compute the final shape ;;As a simple example, consider three spheres A, B, ;;and C, where C touches A and B, but A and B do not ;;touch each other. Any CAD will compute (A U C) U B, ;;but some will fail at (A U B) U C. ;;For those cases, we use (for the lack of a better ;;name) "failed" shapes. (define-for-syntax (build-name id fmt) (format-id id #:source id fmt (syntax-e id))) (define-syntax (define-failed-operation stx) (syntax-case stx () ((_ name) (with-syntax ([failed-name (build-name #'name "failed-~A")] [delayed-name (build-name #'name "delayed-~A")] [delayed-name? (build-name #'name "delayed-~A?")] [pred-name (build-name #'name "failed-~A?")]) #'(begin ;(struct delayed-name delayed-shape ()) (define (failed-name subshapes) (if (null? subshapes) (empty-shape);;HACK: This is only valid for unions. Intersection should ;;probably use the universal-shape. And for subtractions I don't even ;;know what to use. (if (null? (cdr subshapes)) (car subshapes) (#;delayed-name delayed-shape 'delayed-name #;'failed-name (shape-backend (car subshapes)) #f (incr) #f name subshapes)))) (define (pred-name s) (eq? (shape-name s) 'delayed-name #;'failed-name))))))) (define-failed-operation intersection) (define-failed-operation union) (define-failed-operation subtraction) (define (failed-operation? s) (or (failed-union? s) (failed-intersection? s) (failed-subtraction? s))) (define failed-operation-shapes delayed-shape-args) (define (unfailed-operation-name name) (case name ((delayed-intersection) 'intersection) ((delayed-union) 'union) ((delayed-subtraction) 'subtraction))) (define (map-failed-operation f s) (cond ((null? s) null) ((pair? s) (cons (map-failed-operation f (car s)) (map-failed-operation f (cdr s)))) ((failed-operation? s) (struct-copy delayed-shape s [args (map-failed-operation f (failed-operation-shapes s))])) (else (f s)))) ;;To iterate among the tree of shapes (define (for-each-shape f s) (cond ((null? s) #f) ((pair? s) (for-each-shape f (car s)) (for-each-shape f (cdr s))) (else (f s)))) ;;To map among the tree of shapes (define (map-shape f s) (cond ((null? s) null) ((pair? s) (cons (map-shape f (car s)) (map-shape f (cdr s)))) (else (f s)))) ;;To collect all shapes (define (collect-all-shapes s) (let ((shapes (list))) (define (collect s) (cond ((or (empty-shape? s) (universal-shape? s)) s) ((failed-operation? s) (for-each-shape collect (shape-ref s))) (else (set! shapes (cons s shapes))))) (for-each-shape collect s) shapes)) ;;To obtain the backend of a tree of shapes ;;Note: In the future, it might be good to check ;;that all shapes have the same backend (define (shapes-backend s) (cond ((shape? s) (shape-backend s)) ((pair? s) (shapes-backend (car s))) (else (error "Can't identify the backend from" s)))) ;;To access the shape opaque representation in the backend ;;we might need to resolve failed operations (define (shape-impl s) (if (failed-operation? s) (let ((r (resolve s))) (set-shape-name! s (unfailed-operation-name (shape-name s))) (set-shape-ref! s r) r) (shape-ref s))) (provide actual-shape) (define (actual-shape s) (shape-impl s) s) #| We frequently need to unwrap shapes. Let's define some syntax for that: |# (define-syntax (let-shapes stx) (syntax-case stx () ((_ ((s e) ...) body ...) #'(let ((s (shape-impl e)) ...) body ...)))) #| Definition of backend operations |# (define debug-backend (make-parameter #f)) (provide debug-backend) ;;The most generic (define-syntax (case-backend stx) (syntax-case stx () ((case-backend expr name clause ...) (syntax/loc stx (let ((backend expr)) (case-backend* backend name clause ...)))))) (define-syntax (case-backend* stx) (syntax-case stx (else) ;;In the future, optimize this with a jump table ((_ b name) (syntax/loc stx #;(printf "operation ~a not available in backend ~a~%" 'name b) (error 'name "operation not available in backend ~a" b) )) ((_ b name (else body ...)) (syntax/loc stx (begin body ...))) ((_ b name ((backend ...) body ...) clause ...) (syntax/loc stx (if (or (eq? b backend) ...) (begin body ...) (case-backend* b name clause ...)))) ((_ b name (backend body ...) clause ...) (syntax/loc stx (case-backend* b name ((backend) body ...) clause ...))))) ;;Using the current-out-backend (define-syntax (case-current-backend stx) (syntax-case stx () ((_ name clause ...) (syntax/loc stx (case-backend (current-out-backend) name clause ...))))) ;;Using a shape (define-syntax (case-shape-backend stx) (syntax-case stx () ((_ expr name clause ...) (syntax/loc stx (case-backend (shapes-backend expr) name clause ...))))) (define-for-syntax (without-defaults params) (map (lambda (param) (let ((datum (syntax-e param))) (if (pair? datum) (car datum) param))) (syntax->list params))) ;;We also provide some combinations between function definition ;;and case-backend. (define-syntax (def-backend-op stx) (syntax-case stx () ((_ (name param ...) backend-expr clause ...) (with-syntax ([(arg ...) (without-defaults #'(param ...))]) (syntax/loc stx (begin (provide name) (define (name param ...) (case-backend backend-expr name clause ...)))))))) (define-syntax (def-current-backend-op stx) (syntax-case stx () ((_ (name arg ...) clause ...) (syntax/loc stx (def-backend-op (name arg ...) (current-out-backend) clause ...))))) (define-syntax (def-shape-arg-op stx) (syntax-case stx () ((_ (name arg0 arg1 ...) arg clause ...) (syntax/loc stx (def-backend-op (name arg0 arg1 ...) (shapes-backend arg) clause ...))))) (define-syntax (def-shape-op stx) (syntax-case stx () ((_ (name arg0 arg1 ...) clause ...) (syntax/loc stx (def-backend-op (name arg0 arg1 ...) (shapes-backend arg0) clause ...))))) (define-syntax (def-new-shape stx) (syntax-case stx () ((_ ((name shape backend-expr) param ...) clause ...) (with-syntax ([(arg ...) (without-defaults #'(param ...))] [struct-name (build-name #'shape "delayed-~A")] [pred-name (build-name #'shape "~A?")]) (syntax/loc stx (begin ; (provide name) (provide (thing-doc name any/c ; (proc-doc/names name (-> any/c) () ;(-> any/c) (param ...) @{@racket[(name param ...)] Creates a new shape.})) (struct struct-name delayed-shape (arg ...)) (define (name param ...) (if (delayed-mode?) (struct-name 'shape delayed #f (incr) #f name (list arg ...) arg ...) (let ((backend backend-expr)) (new-shape 'shape backend (case-backend* backend name clause ...))))) (provide pred-name) (define (pred-name s) (if (list? (shape-name s)) (and (memq 'shape (shape-name s)) #t) (eq? (shape-name s) 'shape))))))) ((def ((name shape-name) param ...) clause ...) (syntax/loc stx (def ((name shape-name (current-out-backend)) param ...) clause ...))) ((def (name param ...) clause ...) (syntax/loc stx (def ((name name) param ...) clause ...))))) (define-syntax (def-new-shape-op stx) (syntax-case stx () ((def ((name shape-name) arg0 arg1 ...) clause ...) (syntax/loc stx (def ((name shape-name (shapes-backend arg0)) arg0 arg1 ...) clause ...))) ((def ((name shape-name backend-expr) arg0 arg1 ...) clause ...) (syntax/loc stx (def-new-shape ((name shape-name backend-expr) arg0 arg1 ...) clause ...))) ((def (name arg0 arg1 ...) clause ...) (syntax/loc stx (def ((name name) arg0 arg1 ...) clause ...))))) (define-syntax (def-new-shape* stx) (syntax-case stx () ((_ (name arg0 arg1 ...) clause ...) (with-syntax ([name* (build-name #'name "~A*")]) (syntax/loc stx (begin (def-list-arg name name*) (def-new-shape ((name* name) arg0 arg1 ...) clause ...))))))) (define-syntax (def-new-shape-op* stx) (syntax-case stx () ((_ (name arg0 arg1 ...) clause ...) (with-syntax ([name* (build-name #'name "~A*")]) (syntax/loc stx (begin (def-list-arg name name*) (def-new-shape-op ((name* name) arg0 arg1 ...) clause ...))))))) #| Syntax for defining backend operations: * If the operation depends _only_ on the current-out-backend, use: (def-current-backend-op (name arg ...) (rhino expr ...) (autocad expr ...) ...) * If the operation depends on a computed backend, use: (def-backend-op (name arg ...) expression-that-evaluates-to-backend (rhino expr ...) (autocad expr ...) ...) For example: (def-backend-op (sweep path shape) (if (monday?) rhino autocad) (rhino expr ...) (autocad expr ...) ...) * If the backend to use is the one stored in an arg shape, i.e., the expression that evaluates to a backend is the result of (shape-backend arg), use: (def-shape-arg-op (name arg ...) arg (rhino expr ...) (autocad expr ...) ...) * If the backend to use comes from the first shape arg, use: (def-shape-op (name arg ...) (rhino expr ...) (autocad expr ...) ...) * If the backend to use comes from the first shape arg _and_ the result must be wrapped in a shape that saves the backend used, use: (def-new-shape-op (name arg ...) (rhino expr) (autocad expr) ...) * If the backend to use is the current-out-backend _and_ the result must be wrapped in a shape that saves the backend used, use: (def-new-shape (name arg ...) (rhino expr) (autocad expr) ...) or, in case you want to use a specific name for the shape which doesn't match the function name: (def-new-shape ((name shape-name) arg ...) (rhino expr) (autocad expr) ...) * If the shape constructor accepts either a variable number of arguments or a list of arguments plus some additional arguments, use: (def-new-shape* (name arg ...) (rhino expr) (autocad expr) ...) If your were paying attention, you noticed that there's a missing operation: def-new-shape-shape-arg-op. If the need arises, we will provide it but it doesn look like we will need it. |# ;;Choose backend (provide select-backend) (define (select-backend backend [op 'none]) (in-out-backend backend backend op)) (provide in-out-backend) (define (in-out-backend in [out in] [op 'none]) (current-in-backend in) (current-out-backend out) (start-backend in) (unless (eq? in out) (start-backend out)) (case op [(none) (void)] [(delete) (delete-all-shapes) (void)]) #;(delayed-mode) (immediate-mode)) (define (start-backend backend) (case-backend backend start-backend (delayed #t) (rhino (rh:load-rhino-com) #t) (autocad (ac:load-autocad-com) (ac:reset-ucs) (ac:delobj 0) (ac:osmode 0) ;(ac:nomutt 1) ;(ac:cmdecho 0) ;(ac:expert 5) ;(ac:objectsnap) ;(ac:surfaceassociativity 0) ;(ac:surfacemodelingmode 1) ;(ac:solidhist 0) ;(ac:start-undo-mark) (ac:undo-off) #t) (opengl (gl:load-opengl)) (tikz ;;Don't need to do anything #t))) (def-current-backend-op (all-shapes) (rhino (map rh:shape<-ref (rh:all-objects))) (autocad (map ac:shape<-ref (ac:all-objects))) (opengl (map gl:shape<-ref (gl:all-actors)))) (def-current-backend-op (delete-all-shapes) (rhino (rh:delete-objects (rh:all-objects))) (autocad (ac:erase-all)) (opengl (gl:erase-all-actors)) (tikz ;;Nothing to do here #t)) ;;To accept a variable number of arguments (define-syntax (def-var-args stx) (syntax-case stx () ((_ name name2) #'(begin (provide name) (define (name c . cs) (name2 (if (null? cs) c (cons c cs)))))))) ;;To accept a list of arguments or a variable number of arguments (define-syntax (def-list-arg stx) (syntax-case stx () ((_ name name2) #'(begin (provide name) (define (name c . cs) (if (list? c) (apply name2 c cs) (name2 (cons c cs)))))))) ;;We also need some mathematically special shapes that represent empty sets or universal sets (define the-empty-shape (shape 'empty delayed #f "shape" #f)) (define the-universal-shape (shape 'universal delayed #f "shape" #f)) (provide empty-shape empty-shape?) (define (empty-shape) the-empty-shape) (define (empty-shape? s) (eq? s the-empty-shape)) (provide universal-shape universal-shape) (define (universal-shape) the-universal-shape) (define (universal-shape? s) (eq? s the-universal-shape)) #| The actual operations: |# (define (transform-from transform ref c) (transform (transform ref (let ((tr (tr-matrix (position-cs (as-origin c))))) (m-cols (m-column tr 0) (m-column tr 1) (m-column tr 2) (vector 0 0 0 1)))) (m-translation (as-world c)))) (define (ac:transform-from com c) (transform-from ac:transform com c)) (define (gl:transform-from actor c) (transform-from gl:transform actor c)) ;;No longer needed. The predicates are automatically defined ;;and operate on the rosetta side. ;(def-shape-op (point? p) ; (delayed ; (delayed-point? p)) ; (rhino ; (let-shapes ((p p)) ; (rh:is-point p))) ; (autocad ; (let-shapes ((p p)) ; (ac:point? p)))) ; ;(def-shape-op (circle? c) ; (rhino ; (let-shapes ((c c)) ; (rh:is-circle c))) ; (autocad ; (let-shapes ((c c)) ; (ac:circle? c)))) ; ; ;(def-shape-op (ellipse? shape) ; (rhino ; (rh:is-ellipse (shape-impl shape))) ; (autocad ; (ac:ellipse? (shape-impl shape)))) ; ; ;(def-shape-op (line? shape) ; (rhino ; (let-shapes ((r shape)) ; (or (rh:is-line r) ; (rh:is-polyline r)))) ; (autocad ; (let-shapes ((r shape)) ; (or (ac:3d-polyline? r) ; (ac:2d-polyline? r) ; (ac:line? r) ; (ac:lightweight-polyline? r))))) ; ; ;(def-shape-op (closed-line? shape) ; (rhino ; (let-shapes ((r shape)) ; (and (rh:is-curve r) ; (rh:is-curve-closed r)))) ; (autocad ; (let-shapes ((r shape)) ; (and (or (ac:3d-polyline? r) ; (ac:2d-polyline? r) ; (ac:line? r) ; (ac:lightweight-polyline? r)) ; (ac:closed r))))) ; ; ;(def-shape-op (curve? c) ; (rhino ; (let-shapes ((c c)) ; (rh:is-curve c))) ; (autocad ; (let-shapes ((c c)) ; (ac:curve? c)))) ; ;; point (def-new-shape (point position) (rhino (rh:add-point position)) (autocad (ac:add-point position)) (opengl (gl:add-point position))) (def-shape-op (point-position p) (delayed (delayed-point-position p)) (rhino (let-shapes ((p p)) (rh:point-coordinates p))) (autocad (let-shapes ((p p)) (car (ac:coordinates p)))) (opengl (let-shapes ((p p)) (gl:point-coordinates p)))) ;; circle (def-new-shape (circle [c u0] [r 1]) (rhino (if (= r 0) (rh:add-point c) (rh:add-circle c r))) (autocad (if (= r 0) (ac:add-point c) (ac:transform-from (ac:add-circle u0 r) c))) (opengl (if (= r 0) (gl:add-point c) (gl:transform-from (gl:add-circle u0 r) c))) (tikz (if (= r 0) (tz:point c) (tz:circle c r)))) (def-shape-op (circle-radius c) (delayed (delayed-circle-r c)) (rhino ;;HACK: should we do this or should we just always consult the information contained in the shape? ;;This last option would not work for shapes that came directly from the backend. (let-shapes ((c c)) (if (rh:is-point c) 0 (rh:circle-radius c)))) (autocad (let-shapes ((c c)) (if (ac:point? c) 0 (ac:circle-radius c))))) (def-shape-op (circle-center c) (delayed (delayed-circle-c c)) (rhino (let-shapes ((c c)) (if (rh:is-point c) (rh:point-coordinates c) (rh:circle-center-point c)))) (autocad (let-shapes ((c c)) (if (ac:point? c) (car (ac:coordinates c)) (ac:center c))))) (def-new-shape (surface-circle [c u0] [r 1]) (rhino (if (= r 0) (rh:add-point c) (rh:add-surface-circle c r))) (autocad (if (= r 0) (ac:add-point c) (ac:add-surface-circle c r))) (opengl (if (= r 0) (gl:add-point c) (gl:transform-from (gl:add-surface-circle u0 r) c)))) (define (rh:add-surface-circle c r) (let ((circ (rh:add-circle c r))) (begin0 (rh:singleton-id (rh:add-planar-srf circ)) (rh:delete-object circ)))) (define (ac:add-surface-circle c r) (let ((circ (ac:add-circle c r))) (begin0 (car (ac:add-region circ)) (ac:delete circ)))) ;; arc (define (arc-morph c r beg-a a point circle) (cond ((= r 0) (point c)) ((= a 0) (point (+pol c r beg-a))) ((>= (abs a) 2pi) (circle c r)) (else #f))) ;;HACK the morph case doesn't seem to be correct because it doesn't respect the coordinate system of c ;;It also seems to prevent the use of primitives (e.g. gl:add-circle) that always create shapes at the ;;origin (def-new-shape (arc [c u0] [r 1] [beg-a 0] [a pi]) (rhino (or (arc-morph c r beg-a a rh:add-point rh:add-circle) (rh:add-arc (if (= beg-a 0) c (rh:rotate-plane c (radians->degrees beg-a) uz)) r (radians->degrees (coterminal a))))) (autocad (let ((end-a (+ beg-a a))) (or (arc-morph c r beg-a a ac:add-point ac:add-circle) (ac:transform-from (if (> end-a beg-a) (ac:add-arc u0 r beg-a end-a) (ac:add-arc u0 r end-a beg-a)) c)))) (opengl (let ((end-a (+ beg-a a))) (or (arc-morph c r beg-a a gl:add-point gl:add-circle) (gl:transform-from (if (> end-a beg-a) (gl:add-arc u0 r beg-a end-a) (gl:add-arc u0 r end-a beg-a)) c))))) (define (surface-arc-morph c r beg-a a point line surface-circle) (cond ((= r 0) (point c)) ((= a 0) (line c (+pol c r beg-a))) ((>= a 2pi) (surface-circle c r)) (else #f))) (def-new-shape (surface-arc [c u0] [r 1] [beg-a 0] [end-a pi]) (rhino (let ((a (- beg-a end-a))) (or (surface-arc-morph c r beg-a a rh:add-point rh:add-line rh:add-surface-circle) (let ((curves (list (rh:add-arc (if (= beg-a 0) c (rh:rotate-plane c (radians->degrees beg-a) uz)) r (radians->degrees (coterminal a))) (rh:add-line c (+pol c r beg-a)) (rh:add-line c (+pol c r end-a))))) (begin0 (rh:singleton-id (rh:add-planar-srf curves)) (rh:delete-objects curves)))))) (autocad (or (arc-morph c r beg-a (- beg-a end-a) ac:add-point ac:add-surface-circle) (let ((curves (list (ac:transform-from (if (> end-a beg-a) (ac:add-arc u0 r beg-a end-a) (ac:add-arc u0 r end-a beg-a)) c) (ac:add-line c (+pol c r beg-a)) (ac:add-line c (+pol c r end-a))))) (begin0 (car (ac:add-region curves)) (for ((c (in-list curves))) (ac:delete c)))))) (opengl (or (arc-morph c r beg-a (- beg-a end-a) gl:add-point gl:add-surface-circle) (gl:transform-from (if (> end-a beg-a) (gl:add-surface-arc u0 r beg-a end-a) (gl:add-surface-arc u0 r end-a beg-a)) c)))) ;; elliptical arc #| (define elliptical-arc (case-lambda ((x-r y-r angle) (elliptical-arc u0 x-r y-r angle)) ((c x-r y-r angle) (elliptical-arc c x-r y-r 0 angle)) ((c x-r y-r begin-angle end-angle) (move c (rotate-z begin-angle (elliptical-arc x-r y-r (- end-angle begin-angle))))))) (def-new-shape (elliptical-arc x-radius y-radius angle) (rhino (scale (origin-scaling-type) (xyz x-radius y-radius 1) (arc 1 angle)))) |# (define (ellipse-morph c xr yr) (cond ((= xr yr 0) (point c)) ((= xr 0) (line (+y c (- yr)) (+y c yr))) ((= yr 0) (line (+x c (- xr)) (+x c xr))) (else #f))) (def-new-shape (ellipse [c u0] [xr 1] [yr 1/2]) (rhino (or (ellipse-morph c xr yr) (rh:add-ellipse c xr yr))) (autocad (or (ellipse-morph c xr yr) (ac:transform-from (if (> xr yr) (ac:add-ellipse u0 (xyz xr 0 0) (/ yr xr)) (ac:add-ellipse u0 (xyz 0 yr 0) (/ xr yr))) c)))) (def-new-shape* (line cs) (rhino (rh:add-polyline cs)) (autocad (ac:add-3d-poly cs)) (opengl (gl:add-line #f cs)) (tikz (tz:line cs))) (def-shape-op (line-vertices l) (rhino (let-shapes ((r l)) (let ((pts (rh:curve-points r))) (if (or (rh:is-curve-closed r) (< (distance (car pts) (last pts)) 1.0e-15)) ;Rhino tolerance (drop-right pts 1) pts)))) (autocad (let-shapes ((r l)) (let ((pts (cond ((ac:line? r) (list (ac:start-point r) (ac:end-point r))) ((ac:lightweight-polyline? r) ;;This is not right, we need to convert coordinates (let ((h (ac:elevation r))) (map (lambda (p) (+z p h)) (ac:2d-coordinates r)))) ((ac:3d-polyline? r) (ac:coordinates r)) (else (error 'line-vertices "Can't compute vertices of ~A" l))))) (if (or (ac:closed r) (< (distance (car pts) (last pts)) 1.0e-015)) ;AutoCAD tolerance (drop-right pts 1) pts))))) #| ; predicates (define (angle? a) (number? a)) (define (distance? d) (and (number? d) (positive? d))) (define (nonnegative-number? r) (and (number? r) (not (negative? r)))) (define (nonnegative-integer? r) (and (integer? r) (not (negative? r)))) (define (coord-list? lst) (and (list? lst) (every is-coord lst))) (define (node? expr) (is-a? expr node%)) ; elliptical-arc (define (elliptical-arc-impl angle x-radius y-radius) (assert-types 'elliptical-arc-impl (list number? nonnegative-number? nonnegative-number?) (list angle x-radius y-radius)) (cond ((= x-radius y-radius) (arc x-radius angle)) ((= x-radius 0) (line u0 (y y-radius))) ; edit: depends on the angle ((= y-radius 0) (line u0 (x x-radius))) ; edit: depends on the angle ((= angle 0) (point (x x-radius))) (else (let ((angle (coterminal angle))) (if (= angle 0) (ellipse x-radius y-radius) (new elliptical-arc-node% (angle angle) (x-radius x-radius) (y-radius y-radius))))))) (define elliptical-arc (case-lambda ((x-r y-r angle) (elliptical-arc-impl angle x-r y-r)) ((c x-r y-r angle) (move c (elliptical-arc x-r y-r angle))) ((c x-r y-r begin-angle end-angle) (move c (rotate-z begin-angle (elliptical-arc x-r y-r (- end-angle begin-angle))))))) ; /elliptical-arc |# ;HACK This should be applicable to empty-shapes (def-shape-op (bounding-box s) (rhino (rh:bounding-box (shape-impl s))) (autocad (ac:bounding-box (shape-impl s))) (opengl (gl:bounding-box (shape-impl s)))) (def-new-shape-op (closed shape) (else (begin0 (error 'closed "Finish this. Dispatch on shape type and create closed shape")))) (def-new-shape* (closed-line cs) (rhino (let ((id (rh:add-polyline (append cs (list (car cs)))))) ;; (cond ((rh:is-curve-closed id) ;; id) ;; ((rh:is-curve-closable id) ;; (rh:close-curve id)) ;; (else ;; (delete-object id) ;; (add-polyline (append-first coords))))) id)) (autocad (let ((com (ac:add-3d-poly (append cs (list (car cs)))))) (ac:closed com #t) com)) (opengl (gl:add-line #t (map as-world cs))) (tikz (tz:closed-line (map as-world cs)))) (def-new-shape* (spline cs [v0 #f] [v1 #f]) (rhino (rh:add-interp-curve-ex cs 3 rh:knot-style-chord-length-spacing #t (or v0 rh:com-omit) (or v1 rh:com-omit))) (autocad ;;HACK: apparently, there's no difference ;(ac:spline-command cs v0 v1) (let ((v0 (or v0 (-c (cadr cs) (car cs)))) (v1 (or v1 (let ((end (take-right cs 2))) (-c (cadr end) (car end)))))) (ac:add-spline cs v0 v1))) (opengl (gl:add-spline #f cs v0 v1))) (def-new-shape* (closed-spline cs [v0 #f] [v1 #f]) (rhino (rh:add-interp-curve-ex (append cs (list (car cs))) 3 rh:knot-style-chord-length-spacing #f (or v0 rh:com-omit) (or v1 rh:com-omit))) (autocad (spline (append cs (list (car cs))) v0 v1)) ;;HACK SHOULDN'T WE CLOSED THIS? (opengl (gl:add-spline #t cs v0 v1))) ;;A polygon should have all its vertices in the same plane ;;but we don't check that (def-new-shape* (polygon cs) (else (closed-line cs))) (def-new-shape* (surface-polygon cs) (rhino (let ((id (rh:add-polyline (append cs (list (car cs)))))) (begin0 (rh:singleton-id (rh:add-planar-srf id)) (rh:delete-object id)))) (autocad (let ((com (ac:add-3d-poly (append cs (list (car cs)))))) (ac:closed com #t) (begin0 (car (ac:add-region com)) (ac:delete com)))) (opengl (gl:add-surface-from-points (map as-world (append cs (list (car cs))))))) (provide regular-polygon-vertices) (define (regular-polygon-vertices edges [c u0] [r 1] [a 0] [inscribed? #f]) (let ((r (if inscribed? r (/ r (cos (/ pi edges)))))) ;;from inscribed to circumscribed (for/list ((a (in-period a (+ a 2pi) edges))) (+pol c r a)))) (def-new-shape (regular-polygon edges [c u0] [r 1] [a 0] [inscribed? #f]) (else (if (= r 0) (point c) (polygon (regular-polygon-vertices edges c r a inscribed?))))) (def-new-shape (surface-regular-polygon edges [c u0] [r 1] [a 0] [inscribed? #f]) (opengl (gl:add-surface-from-points-pivot (regular-polygon-vertices edges c r a inscribed?) c)) (else (surface (regular-polygon edges c r a inscribed?)))) ;; rectangle (define (rectangle-morph c dx dy point line) (cond ((= dx dy 0) (point c)) ((= dx 0) (line c (+y c dy))) ((= dy 0) (line c (+x c dx))) (else #f))) (define (rectangle-deltas c dx/c1 dy) (if (number? dx/c1) (values dx/c1 dy) (let ((d (-c dx/c1 c))) (values (xyz-x d) (xyz-y d))))) (def-new-shape (rectangle [c u0] [dx/c1 1] [dy 1]) (rhino (let-values ([(dx dy) (rectangle-deltas c dx/c1 dy)]) (or (rectangle-morph c dx dy rh:add-point rh:add-line) (rh:add-polyline (list c (+x c dx) (+xy c dx dy) (+y c dy) c))))) (autocad (let-values ([(dx dy) (rectangle-deltas c dx/c1 dy)]) (or (rectangle-morph c dx dy ac:add-point ac:add-line) (ac:add-3d-poly (list c (+x c dx) (+xy c dx dy) (+y c dy) c)) #;(ac:transform-from (ac:add-polyline (list u0 (x dx) (xy dx dy) (y dy) u0)) ;;Using polylines because ;;3d-poly does not support offset c)))) (opengl (let-values ([(dx dy) (rectangle-deltas c dx/c1 dy)]) (or (rectangle-morph c dx dy gl:add-point gl:add-line) (gl:add-rectangle c dx dy)))) (tikz (let-values ([(dx dy) (rectangle-deltas c dx/c1 dy)]) (or (rectangle-morph c dx dy tz:point tz:line) (tz:rectangle c dx dy))))) (def-new-shape (surface-rectangle [c u0] [dx/c1 1] [dy 1]) (rhino (let-values ([(dx dy) (rectangle-deltas c dx/c1 dy)]) (or (rectangle-morph c dx dy rh:add-point rh:add-line) (let ((rect (rh:add-polyline (list c (+x c dx) (+xy c dx dy) (+y c dy) c)))) (begin0 (rh:singleton-id (rh:add-planar-srf rect)) (rh:delete-object rect)))))) (autocad (let-values ([(dx dy) (rectangle-deltas c dx/c1 dy)]) (or (rectangle-morph c dx dy ac:add-point ac:add-line) (let ((rect (ac:add-3d-poly (list c (+x c dx) (+xy c dx dy) (+y c dy) c)))) (begin0 (ac:singleton-or-union (ac:add-region (list rect))) (ac:delete rect)))))) (opengl (let-values ([(dx dy) (rectangle-deltas c dx/c1 dy)]) (or (rectangle-morph c dx dy gl:add-point gl:add-line) (gl:add-surface-from-points (list c (+x c dx) (+xy c dx dy) (+y c dy) c)))))) (provide show-position) (define (show-position p) (let ((cs (position-cs p))) (list (cylinder (cs-o cs) 0.01 (+c (cs-o cs) (cs-x cs))) (cylinder (cs-o cs) 0.01 (+c (cs-o cs) (cs-y cs))) (cylinder (cs-o cs) 0.02 (+c (cs-o cs) (cs-z cs))) (list (sphere (as-world p) 0.03)))) p) ; text (def-new-shape (text str [c u0] [h 1]) (rhino (rh:add-text str c h)) (autocad (ac:transform-from (ac:add-text str u0 h) c)) (opengl (gl:transform-from (gl:add-text str u0 h) c)) (tikz (tz:text str c h))) (def-new-shape (text-centered str [c u0] [h 1]) (else (text str (+xy c (/ (text-length str h) -2) (/ h -2)) h))) (def-current-backend-op (text-length str [h 1]) (else ;;HACK conservative approach (* (string-length str) h 0.7))) ; solids (def-new-shape (sphere [c u0] [r 1]) (autocad (ac:add-sphere c r)) (rhino (rh:add-sphere c r)) (opengl (gl:add-sphere c r))) (def-shape-op (sphere-center s) (delayed (delayed-sphere-c s)) #; (rhino ;Doesn't exist (rh:sphere-center s))) (def-shape-op (sphere-radius s) (delayed (delayed-sphere-r s)) #; (rhino ;Doesn't exist (rh:sphere-radius s))) (def-new-shape (torus [c u0] [re 1] [ri 1/2]) (rhino (rh:add-torus2 c re ri)) (autocad (ac:transform-from (ac:add-torus u0 re ri) c)) (opengl (gl:transform-from (gl:add-torus u0 re ri) c))) (def-new-shape (regular-pyramid-frustum [edges 4] [cb u0] [rb 1] [a 0] [h/ct 1] [rt 1] [inscribed? #f]) (opengl (let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c (max rb rt) h point (lambda (c r) (surface-regular-polygon edges c r a inscribed?)) line) (gl:transform (if (= rt 0) (gl:add-pyramid u0 rb h a edges) (gl:add-pyramid-frustum u0 rb rt h a edges)) (tr-matrix (position-cs (as-origin c))))))) (else (let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c (max rb rt) h point (lambda (c r) (surface-regular-polygon edges c r a inscribed?)) line) (loft ;;don't use loft-curves because one of the polygons might be degenerate (list (regular-polygon edges c rb a inscribed?) (regular-polygon edges (+z c h) rt a inscribed?)) #t #t))))) (def-new-shape (regular-pyramid [edges 4] [cb u0] [rb 1] [a 0] [h/ct 1] [inscribed? #f]) ((rhino autocad) (regular-pyramid-frustum edges cb rb a h/ct 0 inscribed?)) (opengl (let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c rb h gl:add-point gl:add-circle gl:add-line) ;;HACK circle? WRONG! (gl:transform (gl:add-pyramid u0 rb h a edges) (tr-matrix (position-cs (as-origin c)))))))) (def-new-shape (irregular-pyramid pts ct [solid? #t]) (else (loft-curve-point (polygon pts) (point ct) solid?))) (def-new-shape (regular-prism edges [cb u0] [r 1] [a 0] [h/ct 1]) (else (regular-pyramid-frustum edges cb r a h/ct r))) (def-new-shape (irregular-prism cbs [h/ct 1] [solid? #t]) (else (let ((v (if (number? h/ct) (z h/ct) h/ct))) (loft-curves (list (polygon cbs) (polygon (map (lambda (p) (+c p v)) cbs))) #t solid?)))) (def-new-shape (right-cuboid [cb u0] [width 1] [height 1] [h/ct 1]) (else (let-values ([(c h) (position-and-height cb h/ct)]) (irregular-prism (list (+xy c (/ width -2) (/ height -2)) (+xy c (/ width +2) (/ height -2)) (+xy c (/ width +2) (/ height +2)) (+xy c (/ width -2) (/ height +2))) h)))) #| Using right-cuboid2 in AutoCAD speeds the escada-n-caracol example from cpu time: 1763 real time: 11930 gc time: 109 to cpu time: 327 real time: 614 gc time: 0 or from cpu time: 13088 real time: 154478 gc time: 1138 to cpu time: 2355 real time: 5130 gc time: 327 a 20~30x speedup |# (def-new-shape (right-cuboid2 [cb u0] [width 1] [height 1] [h/ct 1]) (rhino #t #;(let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c r h rh:add-point rh:add-circle rh:add-line) (rh:add-cylinder-from-plane c h r)))) (autocad (let-values ([(c h) (position-and-height cb h/ct)]) (or ; finish this (axial-morph c r h ac:add-point ac:add-circle ac:add-line) (ac:transform (ac:add-box (+z u0 (/ h 2.0)) width height h) (tr-matrix (position-cs (as-origin c))))))) (opengl #t #;(let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c r h gl:add-point gl:add-circle gl:add-line) (gl:transform (gl:add-cylinder u0 r h) (tr-matrix (position-cs (as-origin c)))))))) ; box (define (box-morph c dx dy dz point line rectangle) (cond ((= dx dy dz 0) (point c)) ((= dx dy 0) (line c (+z c dz))) ((= dx dz 0) (line c (+y c dy))) ((= dy dz 0) (line c (+x c dx))) ; ((= dx 0) (rectangle (line u0 (y dy)) (line u0 (z dz))) ; edit: not possible (yet?) ; ((= dy 0) (rectangle (line u0 (x dx)) (line u0 (z dz))) ; edit: not possible (yet?) ; ((= dz 0) (rectangle (line u0 (x dx)) (line u0 (y dy))) ; edit: not possible (yet?) (else #f))) (define (box-deltas c dx/c1 dy dz) (if (number? dx/c1) (values dx/c1 dy dz) (let ((d (-c dx/c1 c))) (values (xyz-x d) (xyz-y d) (xyz-z d))))) (def-new-shape (box [c u0] [dx/c1 1] [dy (if (number? dx/c1) dx/c1 1)] [dz dy]) (rhino (let-values ([(dx dy dz) (box-deltas c dx/c1 dy dz)]) (or (box-morph c dx dy dz rh:add-point rh:add-line #f) (rh:add-box (list c (+x c dx) (+xy c dx dy) (+y c dy) (+z c dz) (+xz c dx dz) (+xyz c dx dy dz) (+yz c dy dz)))))) (autocad (let-values ([(dx dy dz) (box-deltas c dx/c1 dy dz)]) (or (box-morph c dx dy dz ac:add-point ac:add-line #f) (ac:transform-from (ac:add-box (xyz (/ dx 2) (/ dy 2) (/ dz 2)) (abs dx) (abs dy) (abs dz)) c)))) (opengl (let-values ([(dx dy dz) (box-deltas c dx/c1 dy dz)]) (or (box-morph c dx dy dz gl:add-point gl:add-line #f) (gl:transform-from (gl:add-box (xyz (/ dx 2) (/ dy 2) (/ dz 2)) (abs dx) (abs dy) (abs dz)) c))))) (def-new-shape (cuboid b0 b1 b2 b3 t0 t1 t2 t3) (rhino (rh:add-box (list b0 b1 b2 b3 t0 t1 t2 t3)))) ;; cone (define (axial-morph c r l point circle line) (cond ((and (= l 0) (= r 0)) (point c)) ((= l 0) (circle c r)) ((= r 0) (line c (+z c l))) (else #f))) (def-new-shape (cone [cb u0] [r 1] [h/ct 1]) (rhino (let-values ([(c h) (inverted-position-and-height cb h/ct)]) (or (axial-morph cb r h rh:add-point rh:add-circle rh:add-line) (rh:add-cone-from-plane c h r)))) (autocad (let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c r h ac:add-point ac:add-circle ac:add-line) (ac:transform (ac:add-cone (+z u0 (/ h 2.0)) r h) (tr-matrix (position-cs (as-origin c))))))) (opengl (let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c r h ac:add-point ac:add-circle ac:add-line) (gl:transform (gl:add-cone u0 r h) (tr-matrix (position-cs (as-origin c)))))))) ; cone-frustum (def-new-shape (cone-frustum [cb u0] [rb 1] [h/ct 1] [rt 1]) (rhino (let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c (max rb rt) h rh:add-point rh:add-circle rh:add-line) (let ((circs (list (rh:add-circle c rb) (rh:add-circle (+z c h) rt)))) (let ((srf (rh:add-loft-srf circs rh:com-omit rh:com-omit rh:loft-type-straight))) (rh:capped-planar-holes srf) (rh:delete-objects circs) srf))))) (autocad (let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c (max rb rt) h ac:add-point ac:add-circle ac:add-line) (ac:transform (ac:add-cone-frustum u0 rb rt h) (tr-matrix (position-cs (as-origin c))))))) (opengl (let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c (max rb rt) h ac:add-point ac:add-circle ac:add-line) (gl:transform (gl:add-cone-frustum u0 rb rt h) (tr-matrix (position-cs (as-origin c)))))))) ; cylinder (def-new-shape (cylinder [cb u0] [r 1] [h/ct 1]) (rhino (let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c r h rh:add-point rh:add-circle rh:add-line) (rh:add-cylinder-from-plane c h r)))) (autocad (let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c r h ac:add-point ac:add-circle ac:add-line) (ac:transform (ac:add-cylinder (+z u0 (/ h 2.0)) r h) (tr-matrix (position-cs (as-origin c))))))) (opengl (let-values ([(c h) (position-and-height cb h/ct)]) (or (axial-morph c r h gl:add-point gl:add-circle gl:add-line) (gl:transform (gl:add-cylinder u0 r h) (tr-matrix (position-cs (as-origin c)))))))) ;; Predicates ; transformations (define (contains-pivot? s) (or (circle? s) (arc? s))) ;;HACK what else? #; (def-new-shape-op (extrusion profile [dir 1]) (rhino (begin0 (rh:extrude (shape-impl profile) (if (number? dir) (z dir) dir)) (delete-shape profile))) (autocad (begin0 (ac:singleton-or-union (if (number? dir) (ac:extrude-command-length (shape-impl profile) dir (surface-region? profile)) (ac:extrude-command-direction (shape-impl profile) u0 dir (surface-region? profile)))) ;; (if (number? dir) ;; (ac:add-extruded-solid (shape-impl profile) dir) ;; (let ((path (ac:add-line u0 dir))) ;; (begin0 ;; (ac:add-extruded-solid-along-path (shape-impl profile) path) ;; (ac:delete path)))) (delete-shape profile))) (opengl (begin0 (gl:add-extrusion (shape-impl profile) (if (number? dir) (z dir) dir) (surface-region? profile) (contains-pivot? profile) (smooth-curve? profile)) (delete-shape profile)))) (provide extrusion) (define (extrusion profile [dir 1]) (map-failed-operation (lambda (profile) (if (empty-shape? profile) (empty-shape) (new-shape 'extrusion (shape-backend profile) (case-shape-backend profile extrusion (rhino (begin0 (rh:extrude (shape-impl profile) (if (number? dir) (z dir) dir)) (delete-shape profile))) (autocad (begin0 (ac:singleton-or-union (if (number? dir) (ac:extrude-command-length (shape-impl profile) dir (surface-region? profile)) (ac:extrude-command-direction (shape-impl profile) u0 dir (surface-region? profile)))) ;; (if (number? dir) ;; (ac:add-extruded-solid (shape-impl profile) dir) ;; (let ((path (ac:add-line u0 dir))) ;; (begin0 ;; (ac:add-extruded-solid-along-path (shape-impl profile) path) ;; (ac:delete path)))) (delete-shape profile))) (opengl (begin0 (gl:add-extrusion (shape-impl profile) (if (number? dir) (z dir) dir) (surface-region? profile) (contains-pivot? profile) (smooth-curve? profile)) (delete-shape profile))))))) profile)) (provide move) (define (move shape v) (map-failed-operation (lambda (s) (case-shape-backend s move (rhino (rh:move-objects (shape-ref s) v) s) (autocad (ac:move (shape-ref s) u0 v) s) (opengl (gl:move (shape-ref s) v) s))) shape)) (provide mirror) #;(define (mirror shape [p u0] [copy? #t]) (if copy? (union (copy-shape shape) (mirror shape p #f)) (map-failed-operation (lambda (s) (case-shape-backend s mirror (rhino (rh:mirror-object (shape-ref s) p (+x p 1) #f) s) (autocad (begin0 (new-shape (shape-name s) autocad (ac:mirror3d (shape-impl s) p (+x p 1) (+y p 1))) (delete-shape s))))) shape))) (define (mirror shape [p u0] [n uz] [copy? #t]) (if copy? (union (copy-shape shape) (mirror shape p n #f)) (let ((p (xyz-from-normal p n))) (map-failed-operation (lambda (s) (case-shape-backend s mirror (rhino (rh:mirror-object (shape-ref s) p (+x p 1) #f) s) (autocad (begin0 (new-shape (shape-name s) autocad (ac:mirror3d (shape-impl s) p (+x p 1) (+y p 1))) (delete-shape s))))) shape)))) (provide scale) (define (scale shape s [p u0]) (map-failed-operation (lambda (sh) (case-shape-backend sh scale (autocad (ac:scale-entity (shape-ref sh) p s) sh) (rhino ;;HACK must change the active construction plane to the perspective????? (rh:scale-object (shape-ref sh) p (xyz s s s) #f) sh) (opengl (gl:move (gl:scale (gl:move (shape-ref sh) (*c p -1)) s s s) p) sh))) shape)) (provide rotate) (define (rotate shape a [p0 u0] [p1 (+z p0 1)]) (map-failed-operation (lambda (s) (case-shape-backend s rotate (autocad (ac:rotate3d (shape-ref s) p0 p1 a) s) (rhino (rh:rotate-object (shape-ref s) p0 (radians->degrees (coterminal a)) p1 #f) s))) shape)) (def-new-shape-op (offset shape distance) (autocad (begin0 (let-shapes ((r shape)) (if (ac:3d-polyline? r) (let ((2d-r (ac:2dpoly<-3dpoly (shape-impl shape)))) (begin0 (singleton-value (ac:offset 2d-r distance)) (ac:delete 2d-r))) (singleton-value (ac:offset r distance)))) (delete-shape shape)))) (def-new-shape-op (revolve shape [p0 u0] [p1 (+z p0 1)] [a0 0] [a 2pi]) (rhino (begin0 (rh:revolve (shape-impl shape) p0 p1 a0 (+ a0 a)) (delete-shape shape))) (autocad (begin0 (ac:revolve-command (shape-impl shape) p0 p1 a0 (+ a0 a) (surface-region? shape)) (delete-shape shape)))) (def-new-shape-op (thicken shape [h 1]) (rhino (begin0 (let-shapes ((r shape)) (rh:thicken r (- h))) ;(delete-shape shape) )) (autocad (let ((s (ac:as-surface (shape-impl shape)))) (begin0 (ac:thicken-command s h) (ac:delete s) (set-shape-deleted?! shape #t))))) #| ; align (define (make-list-fn val1) (λ (val2) (thunk (list val1 val2)))) (define cen (make-list-fn 'cen)) (define x-cen (make-list-fn 'x)) (define x-pos (make-list-fn '+x)) (define x-neg (make-list-fn '-x)) (define y-cen (make-list-fn 'y)) (define y-pos (make-list-fn '+y)) (define y-neg (make-list-fn '-y)) (define z-cen (make-list-fn 'z)) (define z-pos (make-list-fn '+z)) (define z-neg (make-list-fn '-z)) (define (make-key-align-type sym) (match sym ('cen (center-key-align-type)) ('+x (x-pos-key-align-type)) ('-x (x-neg-key-align-type)) ('+y (y-pos-key-align-type)) ('-y (y-neg-key-align-type)) ('+z (z-pos-key-align-type)) ('-z (z-neg-key-align-type)))) (define (make-shape-align-type sym) (match sym ('x (x-cen-shape-align-type)) ('+x (x-pos-shape-align-type)) ('-x (x-neg-shape-align-type)) ('y (y-cen-shape-align-type)) ('+y (y-pos-shape-align-type)) ('-y (y-neg-shape-align-type)) ('z (z-cen-shape-align-type)) ('+z (z-pos-shape-align-type)) ('-z (z-neg-shape-align-type)))) (define (align-key-impl key-fn shape-fns) (assert-types 'align-key-impl (list procedure? (listof procedure?)) (list key-fn shape-fns)) (let ((key-align-type (make-key-align-type (first (key-fn))))) (let ((key-align-types (map (const key-align-type) shape-fns)) (key-shape (second (key-fn))) (shape-align-types (map (λ. make-shape-align-type first call) shape-fns)) (node (sequence (map (λ. second call) shape-fns)))) (new align-node% (key-align-types key-align-types) (key-shape key-shape) (shape-align-types shape-align-types) (node node))))) (define align-key (case-lambda ((fns) (align-key-impl (first fns) (rest fns))) ((fn1 fn2 . fns) (align-key (list* fn1 fn2 fns))))) (define (align-key-list key-fn . shape-fns) (align-key-impl key-fn shape-fns)) (define align-simple (case-lambda ((key-fn shape-fn shapes) (align-key-impl (key-fn (first shapes)) (map shape-fn (rest shapes)))) ((key-fn shape-fn shape1 shape2 . shapes) (align-simple key-fn shape-fn (list* shape1 shape2 shapes))))) ; /align ; function-curve (define (function-curve-impl functional-par) (new parametric-node% (functional-par functional-par))) (define function-curve (case-lambda ((fn) (function-curve fn 0 1)) ((fn t0 t1) (function-curve-impl (functional-curve fn t0 t1))))) ; /function-curve (define (lift proc node) (assert-types 'lift (list procedure? node?) (list proc node)) (new lift-node% (proc proc) (node node))) ; on (define (make-on-type sym) (match sym ('+x (x-pos-on-type)) ('right (x-pos-on-type)) ('-x (x-neg-on-type)) ('left (x-neg-on-type)) ('+y (y-pos-on-type)) ('back (y-pos-on-type)) ('-y (y-neg-on-type)) ('front (y-pos-on-type)) ('+z (z-pos-on-type)) ('top (z-pos-on-type)) ('-z (z-neg-on-type)) ('bottom (z-neg-on-type)))) (define (on-impl type node) (assert-types 'on-impl (list on-type? node?) (list type node)) (new on-node% (type type) (node node))) (define-sequence-constructor* (on type) (on-impl (make-on-type type))) (define on-right (cλ on 'right)) (define on-left (cλ on 'left)) (define on-back (cλ on 'back)) (define on-front (cλ on 'front)) (define on-top (cλ on 'top)) (define on-bottom (cλ on 'bottom)) ; /on ; sequence (define (sequence-impl nodes) ;(assert-types 'sequence-impl (list (listof node?)) (list nodes)) (let ((node (new sequence-node% (nodes nodes)))) (set-field! srcloc node (map-append (lambda (node) (get-field srcloc node)) nodes)) node)) (define sequence (case-lambda ((nodes) (sequence-impl nodes)) ((node . nodes) (sequence (cons node nodes))))) ; /sequence ; cad ; view (define realistic (realistic-view-style)) (define wireframe (wireframe-view-style)) (define ortho (ortho-projection-type)) (define perspective (case-lambda (() (perspective 50)) ((lens) (perspective-projection-type lens)))) (define (view-impl type projection-type style node) (assert-types 'view-impl (list view-type? projection-type? view-style? node?) (list type projection-type style node)) (new view-node% (type type) (projection-type projection-type) (style style) (node node))) (define (auto-view direction projection-type style node/nodes) (view-impl (auto-view-type direction) projection-type style (node-or-sequence node/nodes))) (define (manual-view center target projection-type style node/nodes) (view-impl (manual-view-type center target) projection-type style (node-or-sequence node/nodes))) (define view (case-lambda ((direction projection-type node/nodes) (auto-view projection-type wireframe (node-or-sequence node/nodes))) ((center target projection-type node/nodes) (manual-view center target projection-type wireframe (node-or-sequence node/nodes))))) (define view-ortho-top (case-lambda ((node/nodes) (auto-view (z -1) ortho wireframe (node-or-sequence node/nodes))) ((center/style node/nodes) (if (is-coord center/style) (manual-view center/style u0 ortho (node-or-sequence node/nodes)) (auto-view (z -1) ortho 50 center/style (node-or-sequence node/nodes)))) ((center style node/nodes) (manual-view center u0 ortho style (node-or-sequence node/nodes))))) (define view-perspective (case-lambda ((node/nodes) (auto-view (xyz 1 1 -1) (perspective) realistic (node-or-sequence node/nodes))))) ; rhino (define (add-edge-srf id) (begin0 (match id ((list-id ids) (make-string-id (com:add-edge-srf (flat-strs<-ids ids))))) (delete-objects id))) (define (add-hatch id) (begin0 (match id ((string-id str) (make-string-id (com:add-hatch str)))) (delete-object id))) (define (add-interp-curve coords . args) (make-string-id (apply com:add-interp-curve coords args))) (define (add-planar-srf id) (begin0 (match id ((string-id str) (make-rhino-id (com:add-planar-srf (list str)))) ((list-id ids) (make-rhino-id (com:add-planar-srf (flat-strs<-ids ids))))) (delete-object id))) |# ;;Use something like singleton-or-union (provide section) (define (section s p) (case-shape-backend s section (rhino (let ((curves (rh:add-srf-section-crvs (shape-impl s) p))) (if (null? curves) (empty-shape) (begin0 (failed-union (foldl append (list) (map (lambda (c) (map rh:shape<-ref (rh:add-planar-srfs c))) curves))) (rh:delete-objects curves) #;(delete-shape s))))))) (provide copy-shapes) (define (copy-shapes ss) (map-failed-operation (lambda (s) (if (or (empty-shape? s) (universal-shape? s)) s (case-shape-backend s copy-shapes (delayed s) (rhino (new-shape (shape-name s) rhino (rh:copy-object (shape-ref s)))) (autocad (new-shape (shape-name s) autocad (ac:copy (shape-ref s))))))) ss)) (provide copy-shape) (define copy-shape copy-shapes) #| (define (curve-boolean-difference id1 id2) (match (cons id1 id2) ((cons (string-id str1) (string-id str2)) (begin0 (make-rhino-id (com:curve-boolean-difference str1 str2)) (delete-object id1) (delete-object id2))))) (define (curve-boolean-intersection id1 id2) (match (cons id1 id2) ((cons (string-id str1) (string-id str2)) (begin0 (make-rhino-id (com:curve-boolean-intersection str1 str2)) (delete-object id1) (delete-object id2))))) (define (curve-end-point id) (match id ((string-id str) (com:curve-end-point str)))) (define (curve-normal id) (match id ((string-id str) (com:curve-normal str)))) (define (curve-start-point id) (match id ((string-id str) (com:curve-start-point str)))) |# (provide delete-shapes) (define (delete-shapes ss) (let ((shapes (collect-all-shapes ss))) (if (null? shapes) #t (begin (for-each (lambda (s) (set-shape-deleted?! s #t)) shapes) (case-shape-backend shapes delete-shapes (rhino (rh:delete-objects (map shape-ref shapes))) (autocad (for ((s (in-list shapes))) (let ((r (shape-ref s))) (if (list? r) ;;Special case for surface-grid (for ((s (in-list r))) (ac:delete s)) (ac:delete r))))) (opengl (for ((s (in-list shapes))) (gl:erase-actor (shape-ref s))))))))) (provide delete-shape) (define delete-shape delete-shapes) (def-new-shape-op (surface-boundary shape) (rhino (let-shapes ((r shape)) (begin0 ;;HACK to be completed for the case of multiple ;;borders. Probably, return a failed union of curves (rh:singleton-id (rh:duplicate-surface-border r)) (delete-shape shape)))) (autocad (let-shapes ((r shape)) (let ((rs (ac:explode r))) (cond ((null? rs) (error 'surface-boundary "Can't compute boundary of ~A" shape)) ((null? (cdr rs)) (delete-shape shape) (car rs)) ((andmap ac:line? rs) (let ((poly (ac:add-3d-poly (ac:closed-lines-points rs)))) (ac:closed poly #t) (for ((s (in-list rs))) (ac:delete s)) poly)) (else (delete-shape shape) (ac:join-curves rs))))))) (def-shape-op (shape-layer shape [new-layer #f]) (autocad (if new-layer (begin (ac:add-layer new-layer) (ac:layer (shape-impl shape) new-layer) shape) (ac:layer (shape-impl shape)))) (rhino (if new-layer (begin (rh:object-layer (shape-impl shape) new-layer) shape) (rh:object-layer (shape-impl shape))))) (def-shape-op (shape-material shape [new-material #f]) (autocad (if new-material (begin (ac:add-material new-material) (ac:material (shape-impl shape) new-material) shape) (ac:material (shape-impl shape)))) #;(rhino (if new-material (begin (rh:object-material (shape-impl shape) new-material) shape) (rh:object-material (shape-impl shape))))) ;; (def-shape-op (shapes-layer shapes [new-layer #f]) ;; (autocad ;; (if new-layer ;; (begin ;; (ac:add-layer new-layer) ;; (for ((shape (in-list shapes))) ;; (ac:layer (shape-impl shape) new-layer))) ;; (remove-duplicates (map (lambda (s) (ac:layer (shape-impl s))) shapes))))) (def-current-backend-op (current-layer [new-layer #f]) (autocad (if new-layer (with-handlers ((exn? (λ (e) (error 'current-layer "Layer ~A does not exist" new-layer)))) (ac:clayer new-layer)) (ac:clayer))) (rhino (if new-layer (rh:current-layer) (rh:current-layer new-layer)))) (provide with-current-layer) (define-syntax (with-current-layer stx) (syntax-case stx () ((_ new-layer body ...) (syntax/loc stx (let ((old-layer (current-layer))) (dynamic-wind (lambda () (current-layer new-layer)) (lambda () body ...) (lambda () (current-layer old-layer)))))))) #| (define (intersect-breps id1 id2 . args) (with-handlers ((com:com-exn? (λ (e) (defer-intersect id1 id2)))) (match (cons id1 id2) ((cons (empty-id) _) (delete-object id2) id1) ((cons _ (empty-id)) (delete-object id1) id2) ((cons (universal-id) _) id2) ((cons _ (universal-id)) id1) ((cons (string-id str1) (string-id str2)) (begin0 (make-rhino-id (apply com:intersect-breps str1 str2 args)) (delete-object id1) (delete-object id2)))))) |# (def-new-shape-op* (join-curves shapes) (rhino (begin0 (rh:join-curves (map shape-impl shapes) #f) (delete-shapes shapes))) (autocad (begin0 (ac:join-command (map shape-impl shapes)) (delete-shapes shapes))) (opengl (begin0 (gl:join-curves (map shape-impl shapes)) (delete-shapes shapes)))) (provide select-shapes) (def-shape-op (select-shapes s) (rhino (rh:select-objects (collect-all-shapes s)))) (provide select-shape) (define select-shape select-shapes) #| (define (selected-objects) (map make-string-id (com:selected-objects))) (define (surface-curvature id uv) (match id ((string-id str) (com:surface-curvature str uv)))) (define (surface-domain id direction) (match id ((string-id str) (com:surface-domain id direction)))) (define (split-brep id cutter) (begin0 (match (cons id cutter) ((cons (string-id str) (string-id cutter-str)) (map make-string-id (com:split-brep str cutter-str #t)))) (delete-object cutter))) ; lines (define (nurbs-curve controls knots) (define (uniform-knots? knots) #t) ;;AML: must be finished (if (uniform-knots? knots) (add-curve controls (min 3 (- (length controls) 1))) (error "Rhino curve does not support non uniform knots"))) ; surface (define (generate-knot-vector order total) (let ((knots (make-vector (+ total order)))) (let iter ((i 0)) (if (< i order) (begin (vector-set! knots i 0.0) (iter (+ i 1))) (let iter ((j 1) (i i)) (if (<= j (- total order)) (begin (vector-set! knots i (/ j (+ (- total order) 1.0))) (iter (+ j 1) (+ i 1))) (let iter ((j 0) (i i)) (if (< j order) (begin (vector-set! knots i 1.0) (iter (+ j 1) (+ i 1))) knots)))))))) (define (nurbs-surface controls u-knots v-knots) (define (degree-from-n-controls n) (cond ((< n 3) 1) ((< n 6) 3) (else 5))) (let ((n-rows (length controls)) (n-cols (length (car controls)))) (let ((u-degree (degree-from-n-controls n-rows)) (v-degree (degree-from-n-controls n-cols))) (make-string-id (com:add-nurbs-surface (list n-rows n-cols) controls (generate-knot-vector (- u-degree 1) n-rows) (generate-knot-vector (- v-degree 1) n-cols) (list u-degree v-degree) #;(map (lambda (row) (map (lambda (col) 1.0) row)) controls)))))) (define (surface-from-list lst) (cond ((andmap is-coord lst) (make-string-id (com:add-srf-pt lst))) ((andmap is-curve? lst) (add-edge-srf (make-list-id lst))) (else (error 'surface "Unhandled shape")))) |# (def-new-shape-op* (surface shapes) (rhino (if (singleton? shapes) (let-shapes ((r (car shapes))) (if (rh:is-point r) r (begin0 (rh:singleton-id (rh:add-planar-srf r)) (delete-shapes shapes)))) (begin0 (rh:add-edge-srf (map shape-impl shapes)) (delete-shapes shapes)))) (autocad (if (singleton? shapes) (let-shapes ((r (car shapes))) (if (ac:point? r) r (begin0 (car (ac:add-region r)) (delete-shapes shapes)))) (begin0 (ac:singleton-or-union (ac:add-region (map shape-impl shapes))) (delete-shapes shapes)))) (opengl ;;HACK Unfinished (e.g. point, but this should be handled on the abstract level) (if (singleton? shapes) (let ((shape (car shapes))) (begin0 (gl:add-surface-from-curve (shape-impl shape)) (delete-shapes shapes))) (begin0 (gl:add-surface-from-curves (map shape-impl shapes)) (delete-shapes shapes))))) (def-new-shape (surface-grid css [closed-u? #f] [closed-v? #f]) (rhino ;;Rhino requires at least 3 points in each dimension (if (and (null? (cddr css)) (null? (cddr (car css)))) (rh:add-srf-pt (append (car css) (cadr css))) (let ((css (cond ((null? (cddr css)) (list (car css) (map (lambda (p0 p1) (/c (+c p0 p1) 2)) (car css) (cadr css)) (cadr css))) ((null? (cddr (car css))) (map (lambda (cs) (/c (+c (car cs) (cadr cs)) 2)) css)) (else css)))) (rh:add-srf-pt-grid (vector (length css) (length (car css))) (foldr append (list) css) rh:com-omit (vector closed-u? closed-v?))))) (autocad #;(loft-curves (map (if closed-v? closed-spline spline) css) #f #f closed-u?) ;;HACK: This must be seriously improved!!! (let ((nu (length css)) (nv (length (car css)))) (unless (and (<= nu 256) (<= nv 256)) (error "Too many elements (more than 256x256)")) (define (maybe-singleton l) (if (null? (cdr l)) (car l) l)) (maybe-singleton (cond ((> nu 256) (append (shape-ref (surface-grid (take css 256) #f closed-v?)) (shape-ref (surface-grid (drop css 255) #f closed-v?)))) ((> nv 256) (append (shape-ref (surface-grid (map (lambda (cs) (take cs 256)) css) closed-u? #f)) (shape-ref (surface-grid (map (lambda (cs) (drop cs 255)) css) closed-u? #f)))) (else (let ((r (ac:add-3d-mesh nu nv (foldr append (list) css)))) (when closed-u? (ac:m-close r #t)) (when closed-v? (ac:n-close r #t)) ;(ac:type r ac:ac-bezier-surface-mesh) BUG?? (list r)))))) #;(for ((pts0 (in-list css)) (pts1 (in-list (cdr css)))) (for ((pt0 (in-list pts0)) (pt1 (in-list (cdr pts0))) (pt2 (in-list (cdr pts1))) (pt3 (in-list pts1))) (ac:add-3d-face pt0 pt1 pt2 pt3)))) (opengl (gl:add-grid-surface (map (lambda (pts) (map as-world pts)) css) closed-u? #t closed-v? #t))) #| ; transformations ; sweep |# (define (surface-region? s) (or (surface? s) (surface-circle? s) (surface-arc? s) (surface-rectangle? s) (surface-polygon? s) ;;ask the backend (case-shape-backend s surface-region? (autocad (ac:region? (shape-impl s))) (rhino (or (rh:is-surface (shape-impl s)) (rh:is-polysurface (shape-impl s))))))) (define (smooth-curve? s) (or (spline? s) (closed-spline? s) (circle? s))) ;;HACK ellipse? (define (closed-curve? s) (or (closed-line? s) (closed-spline? s))) (def-new-shape-op (sweep path profile [rotation 0] [scale 1]) (rhino (unless (= scale 1) (error "Rhino doesn't handle scale in sweep")) (unless (= rotation 0) (error "Rhino doesn't handle rotation in sweep")) (begin0 (rh:sweep (shape-impl path) (shape-impl profile)) (delete-shapes (list profile path)))) (autocad (begin0 (ac:sweep-command (shape-impl profile) #t (shape-impl path) (surface-region? profile) rotation scale) (delete-shapes (list profile path)))) (opengl (unless (= scale 1) (error "OpenGL doesn't handle scale in sweep")) (unless (= rotation 0) (error "OpenGL doesn't handle rotation in sweep")) (begin0 (gl:add-sweep (shape-impl profile) (shape-impl path) #f #;(smooth-curve? path) #f #;(surface-region? profile)) (delete-shapes (list profile path))))) #| ; loft |# (def-new-shape-op* (loft-ruled shapes) (else (loft shapes #t))) (def-new-shape-op ((guided-loft* guided-loft) shapes rails [ruled? #f] [solid? #f] [closed? #f]) (rhino (if (> (length rails) 2) (error 'guided-loft "Rhino only supports two rails but were passed ~A" rails) (let ((r (rh:add-sweep2 (map shape-impl rails) (map shape-impl shapes)))) (when solid? (rh:cap-planar-holes r)) (delete-shapes shapes) (delete-shapes rails) r))) (autocad (begin0 (ac:loft-command (ac:loft-objects-guides-string (map shape-impl shapes) (map shape-impl rails) solid?) (if ruled? ac:loftnormals-ruled ac:loftnormals-smooth-fit) closed?) ;(delete-shapes shapes) ;For some reason, AutoCAD does not close the solid... (delete-shapes rails)))) (define (curve? s) (or (line? s) (closed-line? s) (spline? s) (closed-spline? s) (circle? s) (arc? s))) (provide guided-loft) (define (guided-loft shapes rails [ruled? #f] [solid? #f] [closed? #f]) (cond ((null? (cdr shapes)) (delete-shapes rails) (car shapes)) ((andmap curve? shapes) (guided-loft* shapes rails ruled? solid? closed?)) ((andmap surface-region? shapes) (guided-loft* shapes rails ruled? #t closed?)) (else (error 'loft-shapes "cross sections are not either curves or surfaces")))) (provide loft) (define (loft shapes [ruled? #f] [solid? #f] [closed? #f]) (cond ((null? (cdr shapes)) (car shapes)) ((andmap point? shapes) (begin0 ((if ruled? (if closed? polygon line) (if closed? closed-spline spline)) (map point-position shapes)) (delete-shapes shapes))) ((andmap curve? shapes) (loft-curves shapes ruled? solid? closed?)) ((andmap surface-region? shapes) (loft-surfaces shapes ruled? #t closed?)) ((and (null? (cddr shapes)) (ormap point? shapes)) (let-values ([(p s) (if (point? (car shapes)) (values (car shapes) (cadr shapes)) (values (cadr shapes) (car shapes)))]) (cond ((curve? s) (loft-curve-point s p solid?)) ((surface-region? s) (loft-surface-point s p #t)) (else (error 'loft-shapes "can't loft the shapes ~A" shapes))))) (else (error 'loft-shapes "cross sections are not either curves or surfaces")))) (def-new-shape-op (loft-curves shapes [ruled? #f] [solid? #f] [closed? #f]) (rhino (let ((rs (map shape-impl shapes))) ;;Adjust seams #;(let ((ref-p (rh:evaluate-curve (car rs) 0.0))) (for ((r (in-list (cdr rs)))) (rh:curve-seam r (rh:curve-closest-point r ref-p)))) (let ((ref-p (xyz -100000 -10000 -10000))) (for ((r (in-list rs))) (rh:curve-seam r (rh:curve-closest-point r ref-p)))) (let ((r (rh:add-loft-srf rs rh:com-omit rh:com-omit (if ruled? rh:loft-type-straight rh:loft-type-normal) rh:com-omit rh:com-omit closed?))) (when solid? (rh:cap-planar-holes r)) (delete-shapes shapes) r))) (autocad (begin0 (ac:loft-command (ac:loft-objects-string (map shape-impl shapes) solid?) (if ruled? ac:loftnormals-ruled ac:loftnormals-smooth-fit) closed?) (delete-shapes shapes))) (opengl (begin0 (gl:add-loft (map shape-impl shapes) ruled? solid? closed? (andmap line? shapes)) (delete-shapes shapes)))) (def-new-shape-op (loft-curve-point shape point [solid? #f]) (rhino (let-shapes ((r shape) (p point)) (let ((r (rh:extrude-curve-point r (rh:point-coordinates p)))) (when solid? (rh:cap-planar-holes r)) (delete-shape shape) (delete-shape point)))) (autocad (let-shapes ((r shape) (p point)) (begin0 (ac:loft-command (ac:loft-to-point-string (shape-ref (surface-boundary shape)) (car (ac:coordinates p)) solid?) ac:loftnormals-ruled #f) (delete-shape shape) (delete-shape point)))) (opengl (let-shapes ((s shape) (p point)) (begin0 (gl:add-loft-curve-point s p solid? (line? shape)) (delete-shape shape) (delete-shape point))))) (def-new-shape-op (loft-surfaces shapes [ruled? #f] [solid? #t] [closed? #f]) (autocad (begin0 (ac:loft-command (ac:loft-objects-string (map shape-impl shapes) solid?) (if ruled? ac:loftnormals-ruled ac:loftnormals-smooth-fit) closed?) #;(delete-shapes shapes))) (else (begin0 (loft-curves (map surface-boundary shapes) ruled? solid? closed?) (delete-shapes shapes)))) ;;HACK: rename this after removing the previous one (def-new-shape-op (loft-surfaces2 shapes [ruled? #f] [solid? #t] [closed? #f]) (autocad (let ((boundary (map surface-boundary shapes))) (begin0 (ac:loft-command (ac:loft-objects-string (map shape-impl boundary) solid?) (if ruled? ac:loftnormals-ruled ac:loftnormals-smooth-fit) closed?) (delete-shapes boundary)))) (else (begin0 (loft-curves (map surface-boundary shapes) ruled? solid? closed?) (delete-shapes shapes)))) (def-new-shape-op (loft-surface-point shape point [solid? #t]) (else (begin0 (loft-curve-point (surface-boundary shape) point solid?) (delete-shape shape)))) (provide slice) (define (slice shape [p u0] [n uz]) (cond ((empty-shape? shape) shape) ((failed-union? shape) (union (map (lambda (s) (slice s p n)) (failed-operation-shapes shape)))) ((failed-subtraction? shape) (subtraction (map (lambda (s) (slice s p n)) (failed-operation-shapes shape)))) (else (slice* shape (xyz-from-normal p n))))) (def-new-shape-op ((slice* slice) shape plane) (autocad (begin0 (ac:slice-command (shape-ref shape) plane uz) (set-shape-deleted?! shape #t))) (rhino (begin0 (let ((p plane) (r (shape-ref shape))) (let ((pw (as-world p))) (let ((n (-c (as-world (+z p 1)) pw))) (let ((cutter (rh:add-cut-plane r pw (as-world (+x p 1)) (-c (as-world (+y p 1)) pw)))) (let ((rs (rh:split-brep r cutter #f))) (begin0 (if (null? rs) r (begin (rh:delete-object r) (let-values (([keep clear] (partition rh:cap-planar-holes rs))) (rh:delete-objects clear) (let-values (([keep clear] (partition (lambda (r) (let ((c (car (rh:surface-volume-centroid r)))) (< (dot-c (-c c pw) n) 0))) keep))) (rh:delete-objects clear) ;;HACK Check this (singleton-value keep))))) (rh:delete-objects cutter))))))) (set-shape-deleted?! shape #t)))) (def-new-shape (grid-surface ptss [closed-s? #f] [closed-t? #f] [smooth-s? #t] [smooth-t? #t]) (opengl (gl:add-grid-surface (map (lambda (pts) (map as-world pts)) ptss) closed-s? smooth-s? closed-t? smooth-t?))) ;;half spaces (def-new-shape (half-space p n) (else (cons p n))) (def-shape-op (half-space-point hs) (else (car (shape-ref hs)))) (def-shape-op (half-space-normal hs) (else (cdr (shape-ref hs)))) ;;HACK to be continued, to implement ;;slices (or cuts) ;; ;;Helpers (define (fully-contained? s0 s1) (cond ((failed-union? s1) (ormap (lambda (s) (fully-contained? s0 s)) (failed-operation-shapes s1))) ((failed-subtraction? s1) (let ((ss (failed-operation-shapes s1))) (and (fully-contained? s0 (car ss)) (not (ormap (lambda (s) (fully-contained? s0 s)) ss))))) (else (rh:fully-contained? (rh:singleton-id (shape-ref s0)) (rh:singleton-id (shape-ref s1)))))) (define (rh:fully-contained? r0 r1) ;;if all points of the bounding box of r0 are contained in r1 ;;then it's guaranteed that r0 is fully contained in r1. (andmap (lambda (p) (rh:is-point-in-surface r1 p)) (list<-bbox (rh:bounding-box r0)))) (define (fully-not-contained? s0 s1) (cond ((failed-union? s1) (andmap (lambda (s) (fully-not-contained? s0 s)) (failed-operation-shapes s1))) ((failed-subtraction? s1) (let ((ss (failed-operation-shapes s1))) (or (fully-not-contained? s0 (car ss)) (ormap (lambda (s) (fully-contained? s0 s)) ss)))) (else (rh:fully-not-contained? (rh:singleton-id (shape-ref s0)) (rh:singleton-id (shape-ref s1)))))) (define (rh:fully-not-contained? r0 r1) ;;if neither the centroid nor all points of the bounding box of r0 ;;are not contained in r1 then it's guaranteed that r0 is fully not ;;contained in r1. (error "Don't use this (yet)") (not (ormap (lambda (p) (rh:is-point-in-surface r1 p)) (list<-bbox (rh:bounding-box r0))))) ;;Note: a totally contained shape is also a ;;partially contained shape (define (rh:partially-contained? r0 r1) (let ((c0 (rh:point-in-surface r0))) (rh:is-point-in-surface r1 c0)) ;; (let ((c0 (car (rh:surface-volume-centroid r0)))) ;; (if (rh:is-point-in-surface r0 c0) ;; (rh:is-point-in-surface r1 c0) ;; (error "Can't compute containement"))) ) (define (partially-contained? s0 s1) (cond ((failed-union? s1) (ormap (lambda (s) (partially-contained? s0 s)) (failed-operation-shapes s1))) ((failed-subtraction? s1) (partially-contained? s0 (car (failed-operation-shapes s1)))) (else (rh:partially-contained? (rh:singleton-id (shape-ref s0)) (rh:singleton-id (shape-ref s1)))))) (provide union) (define (union . shapes-tree) (let ((ss (filter-not empty-shape? (remove-duplicates (flatten shapes-tree))))) (cond ((null? ss) (empty-shape)) ((null? (cdr ss)) (car ss)) ((ormap universal-shape? ss) (delete-shapes ss) (universal-shape)) (else (let-values ([(failed ss) (partition failed-operation? ss)]) (let-values ([(failed-unions failed-subtractions) (partition failed-union? failed)]) (failed-union (append (append-map failed-operation-shapes failed-unions) ss failed-subtractions)) ;; (let ((s (pure-union (append (append-map failed-operation-shapes failed-unions) ss)))) ;; (cond ((null? failed-subtractions) ;; s) ;; ((universal-shape? s) ;;This never happens (I suppose) ;; (delete-shapes failed) ;; s) ;; ((empty-shape? s) ;; (failed-union failed-subtractions)) ;; (else ;; (distribute-operation ;; union ;; s ;; failed-subtractions)))) )))))) (def-shape-op (pure-union2 sh0 sh1) (rhino (let-shapes ((r0 sh0) (r1 sh1)) (let ((r (rhino-boolean-union (flatten (list r0 r1))))) (cond (r (set-shape-deleted?! sh0 #t) (set-shape-deleted?! sh1 #t) (new-shape 'union rhino r)) ;;union in Rhino only tests surface union ;;This means that although the surface union might ;;fail, the solid union might exist if one surface ;;fully contains the other. ((fully-contained? sh0 sh1) ;(rh:delete-object r0) just to make sure we're tracking deletions correctly (delete-shape sh0) sh1) ((fully-contained? sh1 sh0) ;(rh:delete-object r1) (delete-shape sh1) sh0) (else #f))))) (autocad (let-shapes ((r0 sh0) (r1 sh1)) (new-shape 'union autocad (ac:boolean-union r0 r1))))) (define (rhino-boolean-union ids) (rh:boolean-union2 ids #t)) ;; (displayln "RHINO->") ;; (displayln ids) ;; (let ((r (debug "RH:UNION " (rh:boolean-union2 ids #f)))) ;; (when r ;; (display "Deleting!") ;; (displayln ids) ;; (read) ;; (rh:delete-objects ids) ;; (display "Selecting") ;; (rh:select-objects r) ;; (read)) ;; r)) (define (pure-union ss) (cond ((null? ss) (empty-shape)) ((null? (cdr ss)) (car ss)) (else (case-shape-backend (car ss) union (rhino ;;First, try a faster single union ;;NO, don't do this because the union of 3 shapes where only two can be united ;;causes the union to succeed although there's one shape missing. ;;Second, more precise and slow computation (let loop ((curr (car ss)) (rest (cdr ss)) (failed (list)) (success? #f)) (if (null? rest) (if (null? failed) curr (let ((ss (reverse (cons curr failed)))) (if success? (loop (car ss) (cdr ss) (list) #f) (failed-union ss)))) (let ((r (pure-union2 curr (car rest)))) (if r (loop r (cdr rest) failed #t) (loop curr (cdr rest) (cons (car rest) failed) success?)))))) (autocad ;;We don't have multi-argument union in autocad, but unions do not fail (let loop ((curr (car ss)) (rest (cdr ss))) (if (null? rest) curr (let ((r (pure-union2 curr (car rest)))) (loop r (cdr rest)))))))))) (provide intersection) (define (intersection . shapes-tree) (let ((ss (filter-not universal-shape? (remove-duplicates (flatten shapes-tree))))) (cond ((null? ss) (universal-shape)) ((null? (cdr ss)) (car ss)) ((ormap empty-shape? ss) (delete-shapes ss) (empty-shape)) (else (let-values ([(failed ss) (partition failed-operation? ss)]) (let ((s (pure-intersection ss))) (cond ((null? failed) s) ((empty-shape? s) (delete-shapes failed) s) (else (distribute-operation intersection (car failed) (if (universal-shape? s) (cdr failed) (cons s (cdr failed)))))))))))) (define (copy-shapes-n ss n) (if (= n 1) (list ss) (cons (copy-shapes ss) (copy-shapes-n ss (- n 1))))) (define (distribute-operation oper s ss) (cond ((failed-union? s) (let ((failed-shapes (failed-operation-shapes s))) (union (map (lambda (u ss) (oper (cons u ss))) failed-shapes (copy-shapes-n ss (length failed-shapes)))))) ((failed-subtraction? s) (let ((failed-shapes (failed-operation-shapes s))) (subtraction (map (lambda (u ss) (oper (cons u ss))) failed-shapes (copy-shapes-n ss (length failed-shapes)))))) ((failed-subtraction? (car ss)) (let ((failed-shapes (failed-operation-shapes (car ss)))) (oper (map subtraction (copy-shapes-n s (length failed-shapes)) failed-shapes) (cdr ss)))) (else (error "To be treated")))) (define (pure-intersection ss) (if (null? ss) (universal-shape) (if (null? (cdr ss)) (car ss) (let loop ((curr (car ss)) (rest (cdr ss))) (cond ((null? rest) curr) ((empty-shape? curr) (delete-shapes rest) curr) ;; ((half-space? (car rest)) ;; (loop (slice curr (car rest)) ;; (cdr rest))) (else (loop (pure-intersection2 curr (car rest)) (cdr rest)))))))) (def-shape-op (pure-intersection2 sh0 sh1) (delayed (failed-intersection (list sh0 sh1))) (rhino (let-shapes ((r0 sh0) (r1 sh1)) (let ((r (rh:boolean-intersection2 r0 r1 #t))) (if r (begin (set-shape-deleted?! sh0 #t) (set-shape-deleted?! sh1 #t) (if (rh:singleton-id? r) (new-shape 'intersection rhino (rh:singleton-id r)) (failed-union (map (lambda (r) (new-shape 'intersection rhino r)) r)))) ;;Intersection in Rhino only tests surface intersection ;;This means that although the surface intersection might ;;fail, the solid intersection might exist if one surface ;;contains the other. (cond ((partially-contained? sh0 sh1) (delete-shape sh1) sh0) ((partially-contained? sh1 sh0) (delete-shape sh0) sh1) (else (delete-shapes (list sh0 sh1)) (empty-shape))))))) (autocad (let-shapes ((r0 sh0) (r1 sh1)) (new-shape 'intersection autocad (ac:boolean-intersection r0 r1)))) (opengl (displayln "WARNING: intersection is not operational in OpenGL") (empty-shape))) (provide subtraction) (define (subtraction . shapes-tree) (let ((ss (flatten shapes-tree))) (if (null? ss) (empty-shape) ;(error "No shapes to subtract") (let ((s (car ss)) (ss (cdr ss))) (cond ((null? ss) s) ((empty-shape? s) s) ((ormap (lambda (o) (or (universal-shape? o) (eq? s o))) ;;Perhaps we should use a equal-shape? test ss) (delete-shapes (cons s ss)) (empty-shape)) ((failed-union? s) (let ((failed (failed-operation-shapes s))) (union (map (lambda (u s) (subtraction (cons u s))) failed (copy-shapes-n ss (length failed)))))) ((failed-subtraction? s) (let ((ss1 (failed-operation-shapes s))) (subtraction (car ss1) (union (cdr ss1) ss)))) (else (let-values ([(failed ss) (partition failed-operation? ss)]) (let-values ([(failed-unions failed-subtractions) (partition failed-union? failed)]) (let ((s (pure-subtraction (cons s (append (append-map failed-operation-shapes failed-unions) ss))))) (cond ((null? failed-subtractions) s) ((empty-shape? s) (delete-shapes failed-subtractions) s) (else (distribute-operation subtraction s (cdr failed))))))))))))) #;(define (debug tag . val) (display tag) (displayln val) (car val)) (define (pure-subtraction ss) (if (null? ss) (empty-shape) (if (null? (cdr ss)) (car ss) (case-shape-backend (car ss) subtraction (delayed (failed-subtraction ss)) (rhino ;;First, for just two shapes (if (null? (cddr ss)) (pure-subtraction2 (car ss) (cadr ss)) ;;Second, try a faster single subtraction ;;No, don't do this for the same reasons that it shouldn't be ;;done for unions (let ((r #f #;(rh:boolean-difference2 (shape-ref (car ss)) (flatten (map shape-ref (cdr ss))) #t))) (if r (begin (for-each (lambda (s) (set-shape-deleted?! s #t)) ss) (if (rh:singleton-id? r) (new-shape 'subtraction rhino (rh:singleton-id r)) (failed-union (map (lambda (r) (new-shape 'subtraction rhino r)) r)))) ;;Second, more precise and slow computation (let loop ((curr (car ss)) (rest (cdr ss)) (failed (list)) (success? #f)) (if (null? rest) (if (null? failed) curr (let ((ss (reverse failed))) (if success? (loop curr ss (list) #f) (failed-subtraction ss)))) (let ((r (subtraction curr (car rest)))) (cond ((empty-shape? r) (delete-shapes (cdr rest)) (delete-shapes failed) (empty-shape)) ((failed-subtraction? r) (loop curr (cdr rest) (cons (car rest) failed) success?)) (else (loop r (cdr rest) failed #t)))))))))) (autocad ;;First, for just two shapes (if (null? (cddr ss)) (pure-subtraction2 (car ss) (cadr ss)) (let loop ((curr (car ss)) (rest (cdr ss))) (if (null? rest) curr (let ((r (pure-subtraction2 curr (car rest)))) (cond ((empty-shape? r) (delete-shapes (cdr rest)) (empty-shape)) (else (loop r (cdr rest))))))))) (opengl (displayln "WARNING: subtraction is not operational in OpenGL") (empty-shape)))))) (def-shape-op (pure-subtraction2 sh0 sh1) (rhino (let-shapes ((r0 sh0) (r1 sh1)) (let ((r (rh:boolean-difference2 r0 r1 #t))) (if r (begin (set-shape-deleted?! sh0 #t) (set-shape-deleted?! sh1 #t) (if (rh:singleton-id? r) (new-shape 'subtraction rhino (rh:singleton-id r)) (failed-union (map (lambda (r) (new-shape 'subtraction rhino r)) r)))) ;;subtraction in Rhino only tests surface subtraction ;;This means that although the surface subtraction might ;;fail, the solid subtraction might exist if one surface ;;contains the other. (cond #;((fully-not-contained? sh1 sh0) (delete-shape sh1) sh0) ((fully-contained? sh0 sh1) (delete-shape sh0) sh1) ((fully-contained? sh1 sh0) (failed-subtraction (list sh1 sh0))) ((or (partially-contained? sh0 sh1) (partially-contained? sh1 sh0)) (if (> (car (rh:surface-volume (rh:singleton-id (shape-ref sh0)))) (car (rh:surface-volume (rh:singleton-id (shape-ref sh1))))) (failed-subtraction (list sh0 sh1)) (begin (delete-shapes (list sh0 sh1)) (empty-shape)))) (else (delete-shape sh1) sh0)))))) (autocad (let-shapes ((r0 sh0) (r1 sh1)) (set-shape-deleted?! sh0 #t) (set-shape-deleted?! sh1 #t) (new-shape 'subtraction autocad (ac:boolean-subtraction r0 r1))))) (def-shape-op (resolve shape) (rhino (cond ((failed-union? shape) (let ((ss (map shape-impl (failed-operation-shapes shape)))) (rh:singleton-id (rh:boolean-union ss)))) ((failed-subtraction? shape) (let ((ss (map shape-impl (failed-operation-shapes shape)))) (rh:singleton-id (rh:boolean-difference (list (car ss)) (cdr ss))))) (else (shape-ref shape)))) (autocad (cond ((failed-union? shape) (let ((shapes (failed-operation-shapes shape))) (if (andmap curve? shapes) (ac:join-curves (map shape-ref shapes)) (let ((ss (map shape-impl (failed-operation-shapes shape)))) (foldl ac:boolean-union (car ss) (cdr ss)))))) (else (shape-ref shape))))) #| ; par (define (par-circle shape) (let ((center (circle-center-point shape)) (normal (curve-normal shape)) (radius (circle-radius shape))) (let ((translation (apply m-translation (list-of-coord center))) (rotation (m-rotation (angle-c uz normal (cross-c uz normal)) (cross-c uz normal)))) (par:make-transformation-parametric (par:make-transformation-parametric (par:make-circle-curve radius) rotation) translation)))) (define (par shape) (finally (cond ((is-circle? shape) (par-circle shape)) (else (error 'par "Unhandled par type"))) (λ () (delete-object shape)))) ; /par ; view (define (set-view-projection! projection-type) (match projection-type ((ortho-projection-type) (com:view-projection com:view-perspective com:view-projection-mode-parallel)) ((perspective-projection-type lens) (com:view-projection com:view-perspective com:view-projection-mode-perspective) (com:view-camera-lens com:view-perspective lens)))) (define (set-view-style! style) (let ((display-mode (match style ((wireframe-view-style) com:view-display-mode-wireframe) ((realistic-view-style) com:view-display-mode-render-preview)))) (com:view-display-mode com:view-perspective display-mode))) (define (auto-view direction projection-type style shape/shapes) (set-view-projection! projection-type) (com:view-camera-target com:view-perspective (*c direction -1) u0) (set-view-style! style) (let ((selected-objects (selected-objects))) (com:unselect-all-objects) (select shape/shapes) (com:zoom-selected com:view-perspective) (com:unselect-all-objects) (select selected-objects))) (define (manual-view center target projection-type style) (set-view-projection! projection-type) (com:view-camera-target com:view-perspective center target) (set-view-style! style)) (define (view type projection-type style shape/shapes) (begin0 shape/shapes (match type ((auto-view-type direction) (auto-view direction projection-type style shape/shapes)) ((manual-view-type center target) (manual-view center target projection-type style))))) ;; circle |# (def-shape-op (transform shape matrix) (rhino (rh:transform-object (shape-impl shape) matrix))) #| Compatibility operations |# (def-current-backend-op (view-parameters) (autocad (ac:get-view))) (def-current-backend-op (set-view camera target lens) (rhino (unless (rh:is-view-maximized "Perspective") (rh:maximize-restore-view "Perspective")) (rh:view-projection "Perspective" 2) ;;perspective (rh:view-camera-lens "Perspective" lens) (rh:view-camera-target "Perspective" camera target) (rh:view-display-mode "Perspective" 2)) ;;render (autocad (ac:view-conceptual) (ac:perspective 1) (ac:dview-zoom-command camera target lens (distance camera target)) (ac:skystatus 2)) (opengl (gl:set-view camera target lens))) (def-current-backend-op (2d-top) (rhino (unless (rh:is-view-maximized "Top") (rh:maximize-restore-view "Top")) (rh:view-projection "Top" 1) ;;parallel (rh:view-display-mode "Top" 0)) ;;wireframe (autocad (ac:view-wireframe) (ac:view-top)) (opengl (gl:set-view-top)) (tikz ;;Top is the default in TikZ #t)) (def-current-backend-op (zoom-extents) (rhino (rh:zoom-extents rh:com-omit #t)) (autocad (ac:zoom-extents)) (opengl (gl:zoom-extents)) (tikz ;;TikZ zooms automatically #t)) (def-current-backend-op (refresh) (opengl (gl:refresh))) ;;Renders and Films (define render-dir (make-parameter #f)) (define render-ext (make-parameter "png")) (define render-height (make-parameter 300)) (define render-width (make-parameter 300)) (define render-floor-width (make-parameter 1000)) (define render-floor-height (make-parameter 1000)) (define film-dir (make-parameter #f)) (provide set-render-dir!) (define (set-render-dir! val) (render-dir (path->directory-path (build-path val)))) (provide set-render-size!) (define (set-render-size! width heigth) (render-width width) (render-height heigth)) (provide set-film-dir!) (define (set-film-dir! val) (film-dir (path->directory-path (build-path val)))) (define floor-layer (make-parameter "Floor")) (define shapes-layer (make-parameter "DarkGray")) (set-render-dir! "F:\\Users\\aml\\Dropbox\\Renders\\autorenders") (set-render-size! 1920 1080) (provide white-renders) (define (white-renders) (shapes-layer "DarkGray") (floor-layer "Floor") (set-render-dir! "F:\\Users\\aml\\Dropbox\\Renders\\autorenders") (set-film-dir! "F:\\Users\\aml\\Dropbox\\Renders\\autofilms") (current-layer (shapes-layer))) (provide black-renders) (define (black-renders) (shapes-layer "DarkGray") (floor-layer "FloorBlack") (set-render-dir! "F:\\Users\\aml\\Dropbox\\Renders\\autorendersBlack") (set-film-dir! "F:\\Users\\aml\\Dropbox\\Renders\\autofilmsBlack") (current-layer (shapes-layer))) (define floor-distance (make-parameter 0)) (define floor-extra-width (make-parameter 2000)) (define floor-extra-factor (make-parameter 20)) (define last-make-floor-for-bounding-box #f) (provide make-floor-for-bounding-box) (define (make-floor-for-bounding-box bb) (set! last-make-floor-for-bounding-box bb) (let ((p0 (car bb)) (p1 (cdr bb))) (let ((w (max (* (floor-extra-factor) (distance p0 p1)) (floor-extra-width)))) (shape-layer (box (xyz (- (min (xyz-x p0) (xyz-x p1)) w) (- (min (xyz-y p0) (xyz-y p1)) w) (- (xyz-z p0) 1 (floor-distance))) (xyz (+ (max (xyz-x p0) (xyz-x p1)) w) (+ (max (xyz-y p0) (xyz-y p1)) w) (- (xyz-z p0) 0 (floor-distance)))) (floor-layer))))) (provide make-floor) (define (make-floor) (make-floor-for-bounding-box (all-objects-bounding-box))) ;;Bounding box (define (object-bounding-box s) (let ((bb (bounding-box s))) (cons (xyz (bbox-min-x bb) (bbox-min-y bb) (bbox-min-z bb)) (xyz (bbox-max-x bb) (bbox-max-y bb) (bbox-max-z bb))))) (define (combine-bb bb0 bb1) (cons (xyz (min (xyz-x (car bb0)) (xyz-x (car bb1))) (min (xyz-y (car bb0)) (xyz-y (car bb1))) (min (xyz-z (car bb0)) (xyz-z (car bb1)))) (xyz (max (xyz-x (cdr bb0)) (xyz-x (cdr bb1))) (max (xyz-y (cdr bb0)) (xyz-y (cdr bb1))) (max (xyz-z (cdr bb0)) (xyz-z (cdr bb1)))))) (define (objects-bounding-box objs) (let ((bb (object-bounding-box (car objs)))) (for ((obj (cdr objs))) (set! bb (combine-bb bb (object-bounding-box obj)))) bb)) (define (points-bounding-box pts) (let ((bb (cons (car pts) (car pts)))) (for ((pt (cdr pts))) (set! bb (combine-bb bb (cons pt pt)))) bb)) (define (all-objects-bounding-box) (objects-bounding-box (all-shapes))) (def-current-backend-op (render-view name) (autocad (let ((path (format "~A~A.~A" (path->string (render-dir)) name (render-ext)))) (when (file-exists? path) (delete-file path)) (ac:skystatus ac:sky-status-background-and-illumination) ;; (shapes-layer (all-shapes) (shapes-layer)) ;; (shape-layer (make-floor) (floor-layer)) (ac:render-command "P" (render-width) (render-height) path)))) (def-current-backend-op (render-stereo-view name) (autocad #t ;; (match (get-view) ;; ((list camera target lens) ;; (let ((direction (-c target camera)) ;; (l (distance camera target))) ;; (let ((d (/ (if (< l 1) (/ l 10.0) 0.1) 2.0))) ;; (let ((d+ (pol d (+ (pol-phi direction) pi/2))) ;; (d- (pol d (- (pol-phi direction) pi/2)))) ;; (set-view (+c camera d+) (if (< l 1) target (+c target d+)) lens) ;; (render-view (strcat filename "L")) ;; (set-view (+c camera d-) (if (< l 1) target (+c target d-)) lens) ;; (render-view (strcat filename "R"))))))) )) (define film-filename (make-parameter #f)) (define film-frame (make-parameter #f)) (provide start-film) (define (start-film name) (film-filename name) (film-frame 0)) (define (frame-filename filename i) (~a filename "-frame-" (~r i #:min-width 3 #:pad-string "0"))) (provide save-film-frame) (define (save-film-frame [obj #t]) (parameterize ((render-dir render-dir)) (set-render-dir! (film-dir)) (render-view (frame-filename (film-filename) (film-frame))) (film-frame (+ (film-frame) 1)) obj)) #| Utilities: think about moving them to a different file |# (provide random-range random set-ultimo-aleatorio-gerado!) (define (random-range x0 x1) (+ x0 (random (- x1 x0)))) (define ultimo-aleatorio-gerado 12345) (define (set-ultimo-aleatorio-gerado! v) (set! ultimo-aleatorio-gerado v)) (define (aleatorio) (set! ultimo-aleatorio-gerado (proximo-aleatorio ultimo-aleatorio-gerado)) ultimo-aleatorio-gerado) (define (proximo-aleatorio ultimo-aleatorio) (let ((teste (- (* 16807 (remainder ultimo-aleatorio 127773)) (* 2836 (quotient ultimo-aleatorio 127773))))) (if (> teste 0) (if (> teste 2147483647) (- teste 2147483647) teste) (+ teste 2147483647)))) (define (random x) (if (inexact? x) (* x (/ (aleatorio) 2147483647.0)) (remainder (aleatorio) x))) (def-current-backend-op (prompt-point [str "Select position"]) (autocad (ac:get-point u0 str)) (rhino (rh:get-point str))) (def-current-backend-op (prompt-integer [str "Integer?"]) (autocad (ac:get-integer str)) (rhino (rh:get-integer str))) (def-current-backend-op (prompt-real [str "Real?"]) (autocad (ac:get-real str)) (rhino (rh:get-real str))) (def-current-backend-op (prompt-shape [str "Select shape"]) (autocad (ac:shape<-ref (ac:get-entity str))) (rhino (rh:shape<-ref (rh:get-object str)))) (define (ac:shape<-ref r) (new-shape (ac:object-geometry r) autocad r)) ;;TODO: Update this to follow the approach taken for autocad (define (rh:shape<-ref r) (new-shape (cond ((rh:is-point r) 'point) ((rh:is-circle r) 'circle) ((rh:is-curve r) (if (rh:is-curve-closed r) 'closed-spline 'spline)) ((or (rh:is-line r) (rh:is-polyline r)) (if (rh:is-curve-closed r) 'closed-line 'line)) ((and (rh:is-object r) (rh:is-object-solid r)) 'solid) ((rh:is-surface r) 'surface) ((rh:is-polysurface r) 'surface) (else (error 'rh:shape<-ref "Unknown Rhino object ~A" r))) rhino r)) ;;HACK: To be finished (define (gl:shape<-ref r) (new-shape (cond ;((gl:is-point r) 'point) ;((rh:is-circle r) 'circle) ;((rh:is-curve r) 'spline) ;((rh:is-line r) 'line) ;((rh:is-polyline r) 'line) ;((and (rh:is-object r) (rh:is-object-solid r)) 'solid) ;((rh:is-surface r) 'surface) ;((rh:is-polysurface r) 'surface) (else 'solid #; (error 'gl:shape<-ref "Unknown OpenGL object ~A" r))) opengl r)) (def-current-backend-op (insert-objects-from filename [predicate #f]) (autocad (let ((doc (ac:open-dbx-doc filename))) (let ((objs (ac:all-objects (ac:modelspace doc)))) (let ((filtered-objs (if predicate (filter predicate objs) objs))) (ac:copy-objects doc filtered-objs)))))) (def-current-backend-op (save-screen-png filename) (autocad (ac:save-screen-png filename))) (def-current-backend-op (save-screen-eps filename) (autocad (ac:save-screen-eps filename))) ;(require racket/trace) ;(trace union mirror copy-shape copy-shapes map-failed-operation resolve shape-ref shape-impl) ;; (trace slice slice* mirror move rotate scale map-failed-operation) ;(trace shape-impl failed-operation? union pure-union pure-union2 failed-union intersection subtraction pure-subtraction pure-subtraction2 distribute-operation fully-contained? fully-not-contained? partially-contained? delete-shape delete-shapes surface? point?) ;(trace loft-curve-point) ;(trace guided-loft guided-loft*) (def-current-backend-op (pause) (autocad (read-char)) (rhino (read-char)) (opengl (read-char))) (def-new-shape (contour s p spacing) (rhino (rh:add-srf-contour-crvs (shape-impl s) p spacing))) (provide erase-2d-top) (define (erase-2d-top) (delete-all-shapes) (2d-top)) (provide zoom-2d-top) (define (zoom-2d-top) (2d-top) (zoom-extents)) (provide zoom-3d-conceptual) (define (zoom-3d-conceptual) "to be implemented" )