#lang racket

(require ffi/com)

(require "../com.rkt"
         "../base/coord.rkt"
         "../base/bounding-box.rkt"
#;         (except-in "../proxies/main.rkt" id))


(provide ;(struct-out com-exn)
         load-rhino-com

         singleton-id
         singleton-id?

         ; constants
         create-preview-image-honor-flag
         create-preview-image-draw-flag
         create-preview-image-ghosted-flag
         
         domain-direction-u
         domain-direction-v
         
         knot-style-uniform-knots
         knot-style-chord-length-spacing
         knot-style-sqrt
         knot-style-periodic-uniform-spacing
         knot-style-periodic-chord-length-spacing
         knot-style-periodic-sqrt
         
         loft-type-normal
         loft-type-loose
         loft-type-straight
         loft-type-tight
         loft-type-developable
         
         loft-style-none
         loft-style-rebuild
         loft-style-refit
         
         optional
         
         view-display-mode-wireframe
         view-display-mode-shaded
         view-display-mode-render-preview
         
         view-perspective
         
         view-projection-mode-parallel
         view-projection-mode-perspective
         
         ; methods
         bounding-box
         
         clear-command-history
         close-curve
         com-omit
         
         command
         
         create-preview-image
         
         create-solid
         
;         curve-boolean-difference
;         curve-boolean-intersection
;         curve-boolean-union
         curve-domain
         curve-end-point
         curve-perp-frame
         curve-frame
         curve-normal
         curve-points
         curve-start-point
         
         duplicate-edge-curves
         
         enable-redraw
                  
         intersect-breps
         
         join-surfaces
         
         offset-surface
         surface-curvature
         view-camera-lens
         view-camera-target
         view-display-mode
         view-projection
         view-radius
         view-size
         
         (rename-out (world-x-y-plane world-xy-plane))
         (rename-out (world-y-z-plane world-yz-plane))
         (rename-out (world-z-x-plane world-zx-plane))
         zoom-selected)

; constants

(define create-preview-image-honor-flag 1)
(define create-preview-image-draw-flag 2)
(define create-preview-image-ghosted-flag 4)

(define domain-direction-u 0)
(define domain-direction-v 1)

(define knot-style-uniform-knots 0)
(define knot-style-chord-length-spacing 1)
(define knot-style-sqrt 2)
(define knot-style-periodic-uniform-spacing 3)
(define knot-style-periodic-chord-length-spacing 4)
(define knot-style-periodic-sqrt 5)

(define optional com-omit)

(define view-display-mode-wireframe 0)
(define view-display-mode-shaded 1)
(define view-display-mode-render-preview 2)

(define view-perspective "Perspective")

(define view-projection-mode-parallel 1)
(define view-projection-mode-perspective 2)


; initialization

(define rhino-com-msg "Waiting for Rhinoceros3D to be ready...")

(define (rhino-invoke name . args)
  (apply com-invoke rhino-coobject name args))

(define (rhino-check-invoke name . args)
  (error "Convert this")
 #; (let ((val (apply rhino-invoke name args)))
    (if (void? val)
        (raise-com-exn "COM error. Got no results from ~A: ~A" name args)
        val)))

(define rhino-coclass #f)
(define rhino-coobject #f)


(define (load-rhino-com)
  (set! rhino-coclass
        (let ((progid (progid->clsid "Rhino4.Interface")))
          (with-handlers ((exn?
                           (λ (e)
                             (displayln "Starting Rhinoceros 3D...")
                             (com-create-instance progid))))
            (com-get-active-object progid))))
  (com-set-property! rhino-coclass "Visible" true)
  ; edit: make better
  (set! rhino-coobject
        (try-void-connection
         rhino-com-msg
         (λ () (com-invoke rhino-coclass "GetScriptObject")))))

; marshaling

;;An id is just a string
(define id string)

;;array of ids
(define (arr-ids v)
  (cond ((string? v)
         (vector v))
        ((pair? v)
         (let ((vl (flatten v)))
           (if (andmap string? vl)
               (list->vector vl)
               (expected "string or tree of strings" v))))
        (else
         (expected "string or tree of strings" v))))

;list of ids
(define (ids v)
  (if (void? v)
      (raise-com-exn "Expecting a vector of strings but got void")
      (vector->list v)))

(define (maybe-ids v)
  (if (void? v)
      (list)
      (ids v)))

(define (ids-or-false v)
  (if (void? v)
      #f
      (ids v)))

(define (singleton-id v)
  (cond ((string? v)
         v)
        ((vector? v)
         (if (= 1 (vector-length v))
             (vector-ref v 0)
             (expected "string or vector (or list) with one string" v)))
        ((list? v)
         (if (and (not (null? v)) (null? (cdr v)))
             (car v)
             (expected "string or vector (or list) with one string" v)))
        (else
         (expected "string or vector (or list) with one string" v))))

(define (singleton-id? v)
  (cond ((string? v)
         #t)
        ((vector? v)
         (= 1 (vector-length v)))
        ((list? v)
         (and (not (null? v)) (null? (cdr v))))
        (else
         #f)))

(define (plane-from-base c)
  (let ((x (exact->inexact (xyz-x c)))
        (y (exact->inexact (xyz-y c)))
        (z (exact->inexact (xyz-z c))))
    (vector x y z 1.0 0.0 0.0 0.0 1.0 0.0)))

(define (plane c/m/p)
  (let ((arr
         (cond ((position? c/m/p)
                (let ((p (as-world c/m/p)))
                  (let ((cs (position-cs c/m/p)))
                    (vector (vector<-xyz p)
                            (vector<-xyz (cs-x cs))
                            (vector<-xyz (cs-y cs))
                            (vector<-xyz (cs-z cs))))))
               ((matrix? c/m/p)
                (plane<-matrix c/m/p)) ;;Revise this, use a struct for the matrix using the fields
               ((vector? c/m/p) ;;Rhino's plane
                c/m/p)
               (else
                (error "don't do that!")
                c/m/p))))
    (type-describe 
     arr
     '(array 4 (variant (array 3 double))))))

(define (rh-plane v)
  (check-expected
   (lambda (v)
     (and (= 4 (vector-length v))
          (for/and ((e (in-vector v)))
            (vector? e))))
   "vector of vectors" v))

(define (flat-plane p)
  (let ((v (make-vector 12)))
    (vector-copy! v 0 (vector-ref p 0))
    (vector-copy! v 3 (vector-ref p 1))
    (vector-copy! v 6 (vector-ref p 2))
    (vector-copy! v 9 (vector-ref p 3))
    v))

(define (plane<-matrix m)
  (vector
   (vector-drop-right (m-column m 3) 1)
   (vector-drop-right (m-column m 0) 1)
   (vector-drop-right (m-column m 1) 1)
   (vector-drop-right (m-column m 2) 1)))

(define (matrix<-nested-plane pl)
  (m-cols (vector-ref pl 1)
          (vector-ref pl 2)
          (vector-ref pl 3)
          (vector-ref pl 0))
  ;(list-rotate-left (vector->list pl) 1)
  )

(define (matrix<-rhino-matrix v)
  (error "Finish this")
  ;(m-lines (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))
  )

(define (matrix->rh-matrix m)
  (type-describe 
   (vector (m-line m 0)
           (m-line m 1)
           (m-line m 2)
           (vector 0 0 0 1))
   '(array 4 (array 4 any))))
;   (flat-plane<-matrix matrix)


(define-syntax (def stx)
  (syntax-case stx ()
    ((def name ins out)
     (syntax/loc stx
       (def-com rhino-coobject name ins out)))))

(def add-arc (plane radius angle) id)
(def add-box (arr-points) id)
(def add-circle (plane radius) id)
(def add-cone (point point radius #:opt boolean) id)
(def (add-cone-from-plane "AddCone") (plane real radius #:opt boolean) id)
(def add-curve (arr-points #:opt integer) id)
(def add-cut-plane (arr-ids point point #:opt point) id)
(def add-cylinder (point point radius #:opt boolean) id)
(def (add-cylinder-from-plane "AddCylinder") (plane real radius #:opt boolean) id)
(def add-edge-srf (arr-ids) id)
(def add-ellipse (plane radius radius) id)
(def add-hatch (id #:opt name real angle) id)

(define knot-style integer) ;;Revise this, use only the valid values
(def add-interp-curve (arr-points #:opt integer knot-style point point) id)
(def add-interp-curve-ex (arr-points #:opt integer knot-style boolean point point) id)

; edit: color marshaling
(def add-layer (#:opt name integer boolean boolean name) name)
(def add-line (point point) id)

(provide loft-type-normal 
         loft-type-loose
         loft-type-straight
         loft-type-tight
         loft-type-developable)

(define loft-type-normal 0)
(define loft-type-loose 1)
(define loft-type-straight 2)
(define loft-type-tight 3)
(define loft-type-developable 4)

(define loft-style-none 0)
(define loft-style-rebuild 1)
(define loft-style-refit 2)

(define loft-type integer)
(define loft-simplify integer)
(def add-loft-srf
     (arr-ids #:opt (start point) (end point) loft-type loft-simplify number (closed? boolean))
     singleton-id)

(def add-nurbs-surface
  ((arr-point-count list->vector) 
   arr-pointss 
   (arr-knot-u arr-reals) (arr-knot-v arr-reals)
   (arr-degree list->vector)
   #:opt (arr-weights arr-realss))
  id)

(def add-planar-srf (arr-ids) singleton-id)
(def add-plane-surface (plane real real) id)
(def add-point (point) id)
(def add-polyline (arr-points) id)
(def add-rev-srf (id arr-points #:opt angle angle) id)
(def add-sphere (point radius) id)

; info: API is incomplete because the last case clashes with these
(define add-srf-contour-crvs
  (case-lambda
    ((object plane)
     (vector->list
      (rhino-check-invoke
       "AddSrfContourCrvs"
       object
       plane)))
    ((object plane interval)
     (vector->list
      (rhino-check-invoke
       "AddSrfContourCrvs"
       object
       plane
       (real interval))))
    ((object start-point end-point interval)
     (vector->list
      (rhino-check-invoke
       "AddSrfContourCrvs"
       object
       (point start-point)
       (point end-point)
       (real interval))))))

(def add-srf-pt (arr-points) id)
(def add-srf-pt-grid (arr-ints arr-points arr-booleans) id)
(def add-srf-section-crvs (id plane) id)

(define text-style integer)
(def add-text (string plane #:opt positive-real string text-style) id)
(def add-torus (point real real #:opt point) id)
(def (add-torus2 "AddTorus") (plane real real) id)

(def all-objects (#:opt (select? boolean) (include-lights? boolean) (include-grips? boolean)) maybe-ids)

;;HACK: Just to be compatible with the former Rosetta
(def boolean-difference (arr-ids arr-ids #:opt boolean) ids)
(def boolean-intersection (arr-ids arr-ids #:opt boolean) ids)
(def boolean-union (arr-ids #:opt boolean) ids)

;;Don't forget to update the new code when the old one
;;becomes obsolete
(def (boolean-difference2 "BooleanDifference") (arr-ids arr-ids #:opt boolean) ids-or-false)
(def (boolean-intersection2 "BooleanIntersection") (arr-ids arr-ids #:opt boolean) ids-or-false)
(def (boolean-union2 "BooleanUnion") (arr-ids #:opt boolean) ids-or-false)

;;Excluded all other options for bounding box
(def bounding-box (arr-ids) bbox<-vector)
(def brep-closest-point (id point) identity)
(def cap-planar-holes (id) boolean)

(provide capped-planar-holes)
(define (capped-planar-holes id)
  (if (or (is-object-solid id)
          (cap-planar-holes id))
      id
      (error 'capped-planar-holes "couldn't cap planar holes of shape ~A" id)))

(def circle-center-point (id) coord<-vector)
(def circle-radius (id) number)
(def clear-command-history () void)
(def close-curve (id #:opt tolerance) id)
(def command (string #:opt (echo? boolean)) boolean)
(def copy-object (id #:opt point point) id)
(def copy-objects (arr-ids #:opt point point) ids)

(define bitmap-creation-flags integer)
(def create-preview-image 
  ((file string) (view string) (size list->vector) bitmap-creation-flags (wireframe? boolean)) 
  boolean)

(def create-solid (arr-ids #:opt delete?) singleton-id)
(def current-layer (#:opt name) name)
(def curve-boolean-difference (id id) ids)
(def curve-boolean-intersection (id id) ids)
(def curve-boolean-union (id id) ids)
(def curve-closest-point (id point #:opt integer) real)
(def curve-domain (id) vector->list)
(def curve-seam (id real) boolean)
(def curve-end-point (id) coord<-vector)
(def curve-frame (id real) matrix<-nested-plane)
(def curve-perp-frame (id real) matrix<-nested-plane)
(def curve-normal (id) coord<-vector)
(def curve-points (id) coords<-vector)
(def curve-start-point (id) coord<-vector)
(def delete-layer (name) boolean)
(def delete-object (id) boolean)
(def (delete-existing-objects "DeleteObjects") (arr-ids) integer)

(provide delete-objects)
(define (delete-objects ids)
  (if (null? ids)
      0
      (delete-existing-objects ids)))

(def duplicate-edge-curves (id #:opt boolean) ids)
(def duplicate-surface-border (id) ids)
(def ellipse-center-point (id) coord<-vector)
(def enable-redraw (#:opt boolean) boolean)
(def evaluate-curve (id real #:opt integer) coord<-vector)
(def evaluate-surface (id arr-reals) coord<-vector)
(def extrude-curve ((curve id) (path id)) id)
(def extrude-curve-point ((curve id) point) id)
(def extrude-curve-straight ((curve id) point point) id)
(def extrude-surface ((surface id) (curve id) #:opt (cap boolean)) id)

(define (maybe-singleton ids)
  (if (and (pair? ids)
           (null? (cdr ids)))
      (car ids)
      ids))

(provide extrude)
(define (extrude id dir)
  (if (is-curve id)
      (extrude-curve-straight id u0 dir)
      (maybe-singleton
       (map capped-planar-holes
            (map (lambda (b)
                   (extrude-curve-straight b u0 dir))
                 (duplicate-surface-border id))))))

(define get-object-type integer)
(def get-integer (#:opt (message string) integer integer integer) integer)
(def get-object (#:opt (message string) (type get-object-type) (pre-select? boolean) (select? boolean) (objects arr-ids)) id)
(def get-point ((message string) #:opt point radius (plane? boolean)) coord<-vector)
(def get-real (#:opt (message string) real real real) real)
(def intersect-breps (id id #:opt tolerance) ids)
(def is-circle (id) boolean)
(def is-curve (id #:opt integer) boolean)
(def is-curve-closed (id #:opt integer) boolean)
(def is-curve-closable (id #:opt tolerance) boolean)
(def is-ellipse (string) boolean)
(def is-layer (string) boolean)
(def is-line (id) boolean)
(def is-object (id) boolean)
(def is-object-in-box (id vector<-bbox boolean) boolean)
(def is-object-solid (id) boolean)
(def is-point-in-surface (id point) boolean)
(def is-polycurve (id) boolean)
(def is-polyline (id) boolean)
(def is-polysurface (id) boolean)
(def is-polysurface-closed (id) boolean)
(def is-polysurface-planar (id) boolean)
(def is-point (id) boolean)
(def is-surface (id) boolean)
(def is-view-maximized (string) boolean)

; edit: create an enum for flags
(def last-created-objects (#:opt boolean integer) ids)
(def join-curves (arr-ids #:opt delete? tolerance) singleton-id)
(def join-surfaces (arr-ids #:opt delete?) ids)
(def maximize-restore-view (string) void)
(def move-object (id point #:opt point) id)
(def move-objects (arr-ids point #:opt point) ids)
(def mirror-object (id point point #:opt boolean) id)
(def mirror-objects (arr-ids point point #:opt boolean) ids)
(def object-layer (id #:opt name) name)
(def offset-surface (id real) id)
(def plane-from-frame ((o point) (x point) (y point)) rh-plane)
(def plane-from-normal (point normal) matrix<-nested-plane #;rh-plane)
(def plane-from-points ((o point) (x point) (y point)) rh-plane)
(def point-coordinates (id #:opt point) coord<-vector)
(def purge-layer (name) name)
(def rename-layer ((old-name name) (new-name name)) name)

(provide revolve)
(define (revolve id p0 p1 a0 a1)
  (cond ((is-curve id)
         ;;HACK: there's a problem in Rhino when the curve
         ;;touches the revolution axis
         ;;Apparently, the revolve command doesn't have
         ;;this problem.
         (add-rev-srf id
                      (list p0 p1)
                      (radians->degrees a0)
                      (radians->degrees a1)))
        ((or (is-surface id) (is-polysurface id))
         (let ((border (singleton-id (duplicate-surface-border id))))
           (begin0
               (capped-planar-holes
                (add-rev-srf border
                             (list p0 p1)
                             (radians->degrees a0)
                             (radians->degrees a1)))
             (delete-object border))))
        (else
         (error 'revolve "Can't revolve the shape ~A" id))))

(require racket/trace)
(trace revolve add-rev-srf)

(def rotate-plane (plane angle (axis point)) rh-plane)
(def rotate-object (id point angle #:opt (axis point) (copy? boolean)) id)
(def rotate-objects (arr-ids point angle #:opt (axis point) (copy? boolean)) ids)
(def scale-object (id point (scale point) (copy? boolean)) id)
(def scale-objects (arr-ids point (scale point) (copy? boolean)) ids)

(def select-object (id) boolean)
(def (select-existing-objects "selectObjects") (arr-ids) boolean)
(provide select-objects)
(define (select-objects objects)
  (if (empty? objects)
    (select-existing-objects objects)
    #f))
(def selected-objects (#:opt (include-lights? boolean) (include-grips? boolean)) maybe-ids)
(def split-brep ((brep id) (cutter id) #:opt delete?) maybe-ids)
(def surface-area-centroid (id) coords<-vector)
(def surface-closest-point (id point) coord<-vector)
(define (surface-curvature object uv)
  (let ((curvature
         (rhino-check-invoke
          "SurfaceCurvature"
          object
          (vector (real (first uv)) (real (second uv))))))
    (list
     (coord<-vector (vector-ref curvature 0))
     (coord<-vector (vector-ref curvature 1))
     (vector-ref curvature 2)
     (coord<-vector (vector-ref curvature 3))
     (vector-ref curvature 4)
     (coord<-vector (vector-ref curvature 5))
     (vector-ref curvature 6)
     (vector-ref curvature 7))))

(def surface-domain (id integer) vector->list)

; edit: what a very complicated function... is it really necessary?
;; (define (surface-surface-intersection surface-a surface-b (tolerance com-omit) (create? com-omit))
;;   (rhino-check-invoke "SurfaceSurfaceIntersection" surface-a surface-b tolerance create?))

(def surface-volume (id) numbers)
(def surface-volume-centroid (id) coords<-vector)
(def add-sweep1 (id arr-ids #:opt point point boolean integer point integer number) singleton-id)
(def add-sweep2 (arr-ids arr-ids #:opt point point boolean boolean boolean integer number) singleton-id)

(provide sweep)
(define (sweep path shape)
  (let ((plane (curve-perp-frame path 0.0))
        (c (bbox-center (bounding-box shape))))
    (move-object shape (*c c -1))
    (transform-objects shape plane)
    (cond ((is-curve shape)
           (add-sweep1 path shape))
          ((is-surface shape)
           (capped-planar-holes
            (add-sweep1
             path (duplicate-surface-border shape))))
          (else
           (error "Continue this")))))
           
(def transform-object (id matrix->rh-matrix #:opt boolean) id)
(def transform-objects (arr-ids matrix->rh-matrix #:opt boolean) ids)
(def unit-absolute-tolerance (#:opt tolerance boolean) number)
(def unselect-all-objects () void)
(def unselect-object (id) boolean)
(def unselect-objects (arr-ids) integer)
(def unselected-objects (#:opt (include-lights? boolean) (include-grips? boolean)) maybe-ids)

#;(define (unselected-objects . args)
  (with-handlers ((com-exn? (λ (e) (list))))
    (vector->list
     (match args
       ((list) (rhino-check-invoke "UnselectedObjects"))
       ((list include-lights?) (rhino-check-invoke "UnselectedObjects" include-lights?))
       ((list include-lights? include-grips?) (rhino-check-invoke "UnselectedObjects" include-lights? include-grips?))))))

(def vector-create (point point) coord<-vector)
(def vector-unitize (point) coord<-vector)
(def view-c-plane (#:opt string plane) matrix<-nested-plane)
(def view-camera-lens (#:opt (view string) (length real)) number)
(def view-camera-target (#:opt (view string) (camera point) (target point)) coords<-vector)
;;AML: I guess there's a bug in the return type of the first two cases
#;
(define view-camera-target
  (case-lambda
    (() (rhino-check-invoke "ViewCameraTarget"))
    ((view) (rhino-check-invoke "ViewCameraTarget" view))
    ((view camera)
     (list<coord><-vector<vector<real>>
      (rhino-check-invoke
       "ViewCameraTarget"
       view
       (point camera))))
    ((view camera target)
     (list<coord><-vector<vector<real>>
      (rhino-check-invoke
       "ViewCameraTarget"
       view
       (point camera)
       (point target))))))

(def view-display-mode (#:opt string integer) integer)
(def view-projection (#:opt string integer) integer)
(def view-radius (#:opt (view string) (radius radius)) number)
(def view-size (#:opt string) vector->list)
(def xform-change-basis (plane plane) identity)
(def (xform-change-basis2 "XformChangeBasis") (identity identity identity identity identity identity) identity)
(def world-x-y-plane () matrix<-nested-plane #;rh-plane)
(def world-y-z-plane () matrix<-nested-plane #;rh-plane)
(def world-z-x-plane () matrix<-nested-plane #;rh-plane)
(def zoom-extents (#:opt string boolean) void)
(def zoom-selected (#:opt string boolean) void)


(provide point-in-surface)
(define (point-in-surface id)
  (coord<-vector (vector-ref (brep-closest-point id u0) 0)))
  ;; (let ((u (surface-domain id 0))
  ;;       (v (surface-domain id 1)))
  ;;   (evaluate-surface id (list (car u) (car v)))))

#|
Call Rhino.Command("-_SelNone",False)
 
    Call Rhino.SelectObjects(curveSets(0))
    Call Rhino.Command("-_Loft",False)
    Call Rhino.EnableRedraw(False)
    For i = 1 To uBound(curveSets) Step 1
        Call Rhino.SelectObjects(curveSets(i))
        Call Rhino.Command("-_Loft _enter _enter",False)
        Call Rhino.Command("-_SelNone",False)
    Next
    Call Rhino.EnableRedraw(True)

|#