#lang scheme
(require "../utils.ss")
(require "primitives-new.ss"
         "point.ss"
         "vector.ss")
;; Operations for VisualScheme

(provide (except-out (struct-out operation) make-operation))
(provide define-operation)

(define-struct operation
  ()
  #:transparent)

(define-syntax define-operation
  (syntax-rules ()
    [(_ name slot ...)
     (begin
       (provide (struct-out name))
       (define-struct (name operation)
         (slot ...)
         #:transparent))]))

(define-operation null-operation obj)

(define-syntax define-operations
  (syntax-rules ()
    [(_ operation ...)
     (begin (define-operation . operation) ...)]))


(define-operations
  ;; arrays
  (array obj x y z dx dy dz)
  (array-polar obj c pt n angle)

  ;; csg
  (subtraction object objects)
  (intersection objects)
  (union objects)

  (adjoined objects)

  ;; extrudes/sweeps/lofts
  ;; Extrude != sweep. No mínimo o extrude não alinha o objecto
  ;; com a path, mas o sweep alinha.
  (extrusion surf path taper-angle)

  (loft objects a1 m1 a2 m2)
  (guided-loft objects guides path)
  (ruled-loft objects)

  (revolution surf axis start-angle end-angle)
  (sweep surf path twist scale)

  ;; transforms
  (mirror obj plane) ;;mirror3d no autocad
  (move obj v)
  (offset curve dist)
  (rotate obj pt axis-vector angle) ;; acrescentar versão que recebe axis
  (scale obj pt v)
  (slice obj plane)
  (thicken surf w)
  (transform object matrix) ;; m -> 4x4 matrix
  (edges obj) ;; wireframe

  ;; misc
  ;;(copy obj) ; Vamos ver se é preciso...
  ;;(explode obj) ;; O que devolverá? Fará sentido?
)

(provide adjoin unite intersect subtract)
(define (unite . args*)
  (if (list? (first args*))
      (apply unite (first args*))
      (let [(args (remove empty-region args* eq?))]
        (cond [(memv universal-region args) universal-region]
              [(null? args) empty-region]
              [(= 1 (length args))
               (car args)]
              [(union? (car args))
               (make-union (append (cdr args)
                                   (union-objects (car args))))]
              [else (make-union args)]))))

(define (adjoin . args*)
  (if (list? (first args*))
      (apply adjoin (first args*))
      (let [(args (remove empty-region args* eq?))]
        (cond [(memv universal-region args) universal-region]
              [(null? args) empty-region]
              [(= 1 (length args))
               (car args)]
              [(adjoined? (car args))
               (make-adjoined (append (cdr args)
                                   (adjoined-objects (car args))))]
              [else (make-adjoined args)]))))

(define (intersect . args*)
  (let [(args (remove universal-region args* eq?))]
  (cond [(memv empty-region args) empty-region]
        [(null? args) empty-region]
        [(= 1 (length args))
         (car args)]
        [(intersection? (car args))
         (make-intersection (append (cdr args)
                                    (intersection-objects (car args))))]
        [else (make-intersection args)])))
(define (subtract o os*)
  (let [(os (if (list? os*) (remove empty-region os* eq?) os*))]
;    (if (null? os)
;        empty-region
        (make-subtraction o (ensure-list os))));)

;; (provide revolve)
;; (define revolve
;;   (case-lambda
;;     [(surf axis)
;;      (make-revolution surf axis 0 (* 2 pi))]
;;     [(surf axis start-angle end-angle)
;;      (make-revolution surf axis start-angle end-angle)]))

;; (provide extrude)
;;(extrusion surf path taper-angle)
;; (define extrude
;;   (case-lambda
;;     [(surf p)
;;      (cond [(number? p)
;;             (extrude surf (vxyz 0 0 p))]
;;            [(vector-3d? p)
;;             (extrude surf (make-line (list origin (p+v origin p))))]
;;            [else
;;             (make-extrusion surf p 0)])]
;;     [(surf p taper)
;;      (make-extrusion surf p taper)]))

;;(loft objects a1 m1 a2 m2)
;;(guided-loft objects guides path)
;;(ruled-loft objects)