#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"
  )