#lang racket
;;USE SURFSCULP to create a solid from a watertigh set of surfaces.

;(require ffi/com)
(require "../base/com.rkt")

(require (except-in "../com.rkt" name)
         "../base/coord.rkt"
         "../base/bounding-box.rkt")

(provide com-object-eq?)

(provide load-autocad-com
         
         ; constants
         ac-active-viewport
         ac-all-viewports
         
         ac-intersection
         ac-subtraction
         ac-union
         
         perspective-off
         perspective-on
         
         sky-status-off
         sky-status-background
         sky-status-background-and-illumination
         
         sun-status-off
         sun-status-on
         
         vbCr
         
         optional
         
         ; object methods
;;         object-boolean
         transform-by
         transform
         
         ; ac-cm-color properties
         get-ac-cm-color-blue
         get-ac-cm-color-green
         get-ac-cm-color-red
         
         ; application methods
         ;application-get-interface-object
         application-get-ac-cm-color-interface-object
         
         ; application properties
;         get-application-active-document
;         get-application-documents
         
         ; document methods        
         ;; active document methods
         
         ;; variables
         get-target-variable
         get-viewctr-variable
         get-viewdir-variable
         ; viewport properties
         get-viewport-center
         set-viewport-center!
         get-viewport-height
         set-viewport-height!
         get-viewport-snap-on
         set-viewport-snap-on!
         get-viewport-target
         set-viewport-target!
         get-viewport-width
         set-viewport-width!
         )


; constants

(define ac-active-viewport 0)
(define ac-all-viewports 1)
(define ac-intersection 1)
(define ac-subtraction 2)
(define ac-union 0)

(define optional com-omit)

(define perspective-off 0)
(define perspective-on 1)

(define sky-status-off 0)
(define sky-status-background 1)
(define sky-status-background-and-illumination 2)

(define sun-status-off 0)
(define sun-status-on 1)

(provide window-maximized window-minimized window-normal)
(define window-maximized 3)
(define window-minimized 2)
(define window-normal 1)

(define vbCr "\r\n")


; initialization

(define autocad-com-msg "Waiting for AutoCAD to be ready...")


(define (autocad-invoke . args)
  (error "Finish this for args ~A" args)
  #;
  (try-exn-connection
   autocad-com-msg
   (λ () (apply com-invoke args))))

(define application #f)
(define active-document #f)
(define active-modelspace #f)
(define utility #f)
(define autolisp-functions #f)

(define (load-autocad-com)
  (set! application
        (let ((progid (progid->clsid "AutoCAD.Application")))
          (with-handlers ((exn?
                           (λ (e)
                             (displayln "Starting AutoCAD...")
                             (com-create-instance progid))))
            (com-get-active-object progid))))
  (set! active-document
        (com-get-property application "ActiveDocument"))
  (set! active-modelspace
        (com-get-property active-document "ModelSpace"))
  (set! utility
        (com-get-property active-document "Utility"))
  ;;start AutoLISP
  (vl-load-com)
  (let ((lisp (get-interface-object "VL.Application.16")))
    (set! autolisp-functions (com-get-property (com-get-property lisp "ActiveDocument") "Functions"))))


;;To access AutoLISP defined functions
(define-syntax (def-autolisp stx)
  (syntax-case stx ()
    ((def (name autolisp-name))
     (syntax/loc stx 
       (define (name . args)
         (let ((ref (do-com-invoke 'com-get-property autolisp-functions "Item" '(autolisp-name) 2)))
           (set! name (lambda args
                        (apply com-invoke ref "funcall" args))))
         (apply name args))))
    ((def name)
     (with-syntax ((str (string-upcase (symbol->string (syntax-e #'name)))))
       (syntax/loc stx
         (def (name str)))))))

(def-autolisp (al-read "read"))
(def-autolisp (al-eval "eval"))

;;Defines an AutoLISP function
(define-syntax (defun stx)
  (syntax-case stx ()
    ((defun name (param ...) body ...)
     (with-syntax ((str (symbol->string (syntax-e #'name))))
       (syntax/loc stx
         (define name
           (let ((form (syntax->datum #'(defun name (param ...) body ...))))
             (lambda () ;;param ...)
               (al-eval (al-read (format "~S" form)))
               (let ((ref (do-com-invoke 'com-get-property autolisp-functions "Item" '(str) 2)))
                 (set! name (lambda args
                              (apply com-invoke ref "funcall" args)))
                 (name)))))))))); param ...))))))))))


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

(define-syntax (def-model stx)
  (syntax-case stx ()
    ((def name ins out)
     (syntax/loc stx
       (def-com active-modelspace name ins out)))))

(define-syntax (def-doc stx)
  (syntax-case stx ()
    ((def name ins out)
     (syntax/loc stx
       (def-com active-document name ins out)))))

(define-syntax (def-app stx)
  (syntax-case stx ()
    ((def name ins out)
     (syntax/loc stx
       (def-com application name ins out)))))

(define-syntax (def-obj stx)
  (syntax-case stx ()
    ((def name (in ...) out)
     (syntax/loc stx
       (def-com obj name ((obj com) in ...) out)))))


;;Application methods
;  "Eval"
;  "GetAcadState"
(def-app get-interface-object (string) com)
;  "ListArx"
(def-app load-arx (string) void)
;  "LoadDVB"
;  "Quit"
;  "RunMacro"
;  "UnloadArx"
;  "UnloadDVB"
;  "Update"
;  "Zoom"
(def-app zoom-all () void)
(def-app zoom-center (point real) void)
(def-app zoom-extents () void)
;  "ZoomPickWindow"
;  "ZoomPrevious"
;  "ZoomScaled"
;  "ZoomWindow"

;;Active document methods

;  "Activate"
;  "AuditInfo"
(def-doc close (boolean) identity)
;  "CopyObjects"
(def-doc end-undo-mark () identity)
;  "Export"
(def-doc get-variable (string) identity)
;  "HandleToObject"
;  "Import"
;  "LoadShapeFile"
;  "New"
;  "ObjectIdToObject"
;  "ObjectIdToObject32"
;  "Open"
;  "PurgeAll"
(def-doc regen (string) void)
;  "Save"
;  "SaveAs"
(def-doc send-command (string) void)
(def-doc set-variable (string identity) identity)
(def-doc start-undo-mark () identity)
;  "Wblock"

;;Active ModelSpace methods

(def-model add-3d-face (point point point point) com)
(def-model add-3d-mesh (integer integer arr-points) com)
(def-model add-3d-poly (arr-points) com)
(def-model add-arc (point radius angle angle) com)
;  "AddAttribute"
(def-model add-box (point real real real) com)
(def-model add-circle (point radius) com)
(def-model add-cone (point radius real) com)
;  "AddCustomObject"
(def-model add-cylinder (point radius real) com)
;  "AddDim3PointAngular"
;  "AddDimAligned"
;  "AddDimAngular"
;  "AddDimArc"
;  "AddDimDiametric"
;  "AddDimOrdinate"
;  "AddDimRadial"
;  "AddDimRadialLarge"
;  "AddDimRotated"
(def-model add-ellipse (point point real) com)
;  "AddEllipticalCone"
;  "AddEllipticalCylinder"
(def-model add-extruded-solid ((profile com) (height real) angle) com)
(def-model add-extruded-solid-along-path ((profile com) (path com)) com)

; edit: not used?
;; (define (add-light-weight-polyline vertices)
;;   (autocad-invoke
;;    (get-active-document-modelspace)
;;    "AddLightWeightPolyline"
;;    vertices))

;  "AddHatch"
;  "AddLeader"
;  "AddLightWeightPolyline"
(def-model add-line (point point) com)
;  "AddMInsertBlock"
;  "AddMLeader"
;  "AddMLine"
;  "AddMText"
(def-model add-point (point) com)
(def-model add-polyface-mesh (arr-points arr-ints2) com)
(def-model add-polyline (arr-points) com) ; the last coord must be repeated to define 3-coord faces
;  "AddRaster"
;  "AddRay"
(def-model add-region (arr-coms) coms)
;  "AddRevolvedSolid"
(def-model add-section (point point point) com)
;  "AddShape"
;  "AddSolid"
(def-model add-sphere (point radius) com)
(def-model add-spline (arr-points point point) com)
;  "AddTable"
(def-model add-text (string point positive-real) com)
;  "AddTolerance"
(def-model add-torus (point radius radius) com)
;  "AddTrace"
;  "AddWedge"
;  "AddXline"
;  "AttachExternalReference"
;  "Bind"
;  "Delete"
;  "Detach"
;  "Erase"
;  "GetExtensionDictionary"
;  "InsertBlock"
;  "Item"
;  "Reload"
;  "Unload"


;;Object methods

;  "ArrayPolar"
;  "ArrayRectangular"
(provide boolean-union boolean-intersection boolean-subtraction)

(define (boolean-union obj0 obj1)
  (com-invoke obj0 "Boolean" ac-union obj1)
  obj0)

(define (boolean-intersection obj0 obj1)
  #;(intersection-command (list obj0) (list obj1))
  (com-invoke obj0 "Boolean" ac-intersection obj1)
  obj0)

(define (boolean-subtraction obj0 obj1)
  (com-invoke obj0 "Boolean" ac-subtraction obj1)
  obj0)


;  "CheckInterference"
(def-obj copy () com)
(def-obj delete () void)
(def-obj explode () coms)

;  "Erase"
;  "GetBoundingBox"
;  "GetExtensionDictionary"
(provide get-x-data)
(define (get-x-data obj app-name)
  (let ((b0 (box #f))
        (b1 (box #f)))
    (com-invoke obj "GetXData" app-name b0 b1)
    (values (unbox b0) (unbox b1))))
;  "Highlight"
(provide ac-extend-none ac-extend-this-entity ac-extend-other-entity ac-extend-both)
(define ac-extend-none 0)
(define ac-extend-this-entity 1)
(define ac-extend-other-entity 2)
(define ac-extend-both 3)
(def-obj intersect-with (com integer) coords<-flat-vector-or-false)
;  "Mirror"
(def-obj mirror3d (point point point) com)
(def-obj move (point point) void)
;  "Rotate"
(def-obj rotate3d (point point real) void)
(def-obj scale-entity (point real) void)
(def-obj offset (real) coms)
(def-obj section-solid (point point point) com)
(provide set-x-data)
(define (set-x-data obj types data)
  (com-invoke obj "setXData" ;;Don't change this name
              (type-describe types `(array ,(vector-length types) short-int))
              (type-describe data `(array ,(vector-length data) any))))
;  "SliceSolid"
(def-obj transform-by (com<-matrix) void)
(define (transform obj matrix)
  (transform-by obj matrix)
  obj)
;  "Update"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; document methods

(provide add-layer)
(define (add-layer name)
  (add (layers active-document) name))

(provide get-layer)
(define (get-layer name)
  (item (layers active-document) name))

(provide add-material)
(define (add-material name)
  (add (materials active-document) name))


(provide open-dbx-doc)
(define (open-dbx-doc filename)
  (let ((dbx-doc
         (get-interface-object
          (string-append "ObjectDBX.AxDbDocument."
			 (substring (acadver) 0 2)))))
    (open dbx-doc filename)
    dbx-doc))

; marshaling

(define (color<-ac-cm-color col)
  (error "To be finished") #;
  (let ((red (get-ac-cm-color-red col))
        (green (get-ac-cm-color-green col))
        (blue (get-ac-cm-color-blue col)))
    (color-of-rgb red green blue)))

(define (ac-cm-color<-color col)
  (error "To be finished") #; 
  (let-values (((red green blue) (rgb-of-color col)))
    (let ((ac-cm-color (application-get-ac-cm-color-interface-object)))
      (ac-cm-color-set-rgb! ac-cm-color red green blue)
      ac-cm-color)))


; object methods



(provide copy-objects)
(define (copy-objects from-doc objs [to-doc active-modelspace])
  (com-invoke from-doc "CopyObjects" (arr-coms objs) to-doc))

(provide bounding-box)
(define (bounding-box object)
  (let ((min-point (box #f))
        (max-point (box #f)))
  (com-invoke object "GetBoundingBox" min-point max-point)
  (make-bbox
   (box-corners-pp
    (coord<-vector (unbox min-point))
    (coord<-vector (unbox max-point))))))

;;;;;;;;;;;;;;;;;;;;;;;XDATA

(provide set-data! get-data)

(define (x-data-type value)
  (cond ((string? value) 1000)
        ;; ((com? value) 1005)
        ;; ((xyz? value) 1010)
        ((real? value) 1040)
        ((integer? value) 1071)
        (else
         (error 'x-data-type<-value "Unnaceptable value" value))))

(define (set-data! obj data)
  (set-x-data obj
              (list->vector
               (cons 1001 (map x-data-type data))
               (cons "Racket" data))))

(define (get-data obj)
  (let-values (((types data) (get-x-data obj "Racket")))
    (vector->list data)))

;;;;;;;;;;;;;;;;;;;;;;;XDATA

;;Predicates:

(define object-geometry-types (make-hash))
(define-syntax define-object-predicate
  (syntax-rules ()
    ((_ name str type)
     (begin
       (provide name)
       (define (name id)
         (string=? (object-name id) str))
       (hash-set! object-geometry-types str 'type)))))

(define-object-predicate 2d-polyline? "AcDb2dPolyline" open-or-closed-line)
(define-object-predicate 3d-face? "AcDbFace" surface)
(define-object-predicate 3d-polyline? "AcDb3dPolyline" open-or-closed-line)
(define-object-predicate 3d-solid? "AcDb3dSolid" solid)
(define-object-predicate arc? "AcDbArc" arc)
(define-object-predicate circle? "AcDbCircle" circle)
(define-object-predicate ellipse? "AcDbEllipse" ellipse)
(define-object-predicate lightweight-polyline? "AcDbPolyline" open-or-closed-line)
(define-object-predicate line? "AcDbLine" line)
(define-object-predicate point? "AcDbPoint" point)
(define-object-predicate region? "AcDbRegion" surface)
(define-object-predicate spline? "AcDbSpline" open-or-closed-spline)
(define-object-predicate surface? "AcDbSurface" surface)
(define-object-predicate text? "AcDbText" text)
(define-object-predicate surface-grid? "AcDbPolygonMesh" surface)

(provide object-geometry)
(define (object-geometry obj)
  (let ((type (hash-ref object-geometry-types (object-name obj))))
    (cond ((eq? type 'open-or-closed-line)
           (if (closed obj) 'closed-line 'line))
          ((eq? type 'open-or-closed-spline)
           (if (closed obj) 'closed-spline 'spline))
          (else
           type))))

(provide curve?)
(define (curve? object)
  (member (object-name object)
          '("AcDb3dPolyline" "AcDb2dPolyline"
            "AcDbArc" "AcDbCircle" "AcDbEllipse"
            "AcDbPolyline" "AcDbLine" "AcDbSpline")))

(provide as-surface)
(define (as-surface obj)
  (if (list? obj)
      (singleton-or-union (map as-surface obj))
      (let ((name (object-name obj)))
        (cond ((string=? name "AcDbRegion")
               (begin0
                   (conv-to-surface obj)
                 (delete obj)))
              ((string=? name "AcDbPolygonMesh")
               (let ((s (mesh-smooth obj 0)))
                 (begin0
                     (conv-to-surface s 1)
                   (delete obj)
                   (delete s))))
              (else
               obj)))))

(def-obj item (identity) com)
(def-com-property count)

(define (last-item obj)
  (item obj (- (count obj) 1)))

(define (created-items obj prev)
  (let ((curr (count obj)))
    (cond ((< curr prev)
           (error 'created-items "Items were eliminated"))
          ((= curr prev)
           (error 'created-items "No new items"))
          (else
           (for/list ((i (in-range prev curr 1)))
             (item obj i))))))

(define (created-item obj prev)
  (let ((curr (count obj)))
    (cond ((< curr prev)
           (error 'created-item "Items were eliminated"))
          ((= curr prev)
           (error 'created-item "No new item"))
          ((> curr (+ prev 1))
           (error 'created-item "More than one new items"))
          (else
           (item obj prev)))))

; object properties

(def-com-property center coord<-vector)
(def-com-property closed (boolean boolean))
(def-com-property control-points coords<-flat-vector)
(def-com-property elevation)
(def-com-property end-angle)
(def-com-property end-point coord<-vector)
(def-com-property handle)
(def-com-property material (string string))
(def-com-property m-close (boolean boolean))
(def-com-property n-close (boolean boolean))
(def-com-property object-name)
(def-com-property object-normal coord<-vector)
(def-com-property position coord<-vector)
(def-com-property (circle-radius "Radius") real)
(def-com-property start-angle)
(def-com-property start-point coord<-vector)
(def-com-property true-color (ac-cm-color<-color color<-ac-cm-color))
(def-com-property custom-scale real)

(provide ac-simple-mesh ac-quad-surface-mesh ac-cubic-surface-mesh ac-bezier-surface-mesh)
(define ac-simple-mesh 0)
(define ac-quad-surface-mesh 5)
(define ac-cubic-surface-mesh 6)
(define ac-bezier-surface-mesh 8)
(def-com-property type (integer integer))

(def-com-property visible (boolean boolean))
(def-com-property coordinates coords<-flat-vector)
(def-com-property (2d-coordinates "Coordinates") coords<-vector-xy) ;;for 2d-polyline?
(def-com-property (point-coordinates "Coordinates") coord<-vector) ;;for point?

(def-com-property width (number number))
(def-com-property height (number number))
(def-com-property window-state (number number))

; ac-cm-color methods

(define (ac-cm-color-set-rgb! object red green blue)
  (autocad-invoke object "SetRGB" red green blue))


; ac-cm-color properties

(define (get-ac-cm-color-blue object)
  (com-get-property object "Blue"))

(define (get-ac-cm-color-green object)
  (com-get-property object "Green"))

(define (get-ac-cm-color-red object)
  (com-get-property object "Red"))

; application methods

(def-obj documents () com)
;(def-obj active-document () com)
(def-obj interface-object (string) com)

(define ac-cm-color-name "AutoCAD.AcCmColor.18")

; info: avoid caching because com-objects returned by 'GetInterfaceObject' seem to
; be always different according to 'com-object-eq?'
(define (application-get-ac-cm-color-interface-object)
  (interface-object application ac-cm-color-name))



;; variables

(define-syntax (def-autocad-variable stx)
  (syntax-case stx ()
    ((def name)
     (with-syntax ((str (string-upcase (symbol->string (syntax-e #'name)))))
       (syntax/loc stx 
         (def name str))))
    ((def name str)
     (syntax/loc stx
       (begin
         (provide name)
         (define name
           (case-lambda
             (() (get-variable str))
             ((val) 
              (set-variable str val)))))))))

(def-autocad-variable delobj)
(def-autocad-variable facetersmoothlev)
(def-autocad-variable smoothmeshconvert)
(def-autocad-variable loftnormals)
(def-autocad-variable loftang1)
(def-autocad-variable loftang2)
(def-autocad-variable loftmag1)
(def-autocad-variable loftmag2)
(def-autocad-variable loftparam)
(def-autocad-variable nomutt)
(def-autocad-variable perspective)
(def-autocad-variable skystatus)
(def-autocad-variable sunstatus)
(def-autocad-variable cmdecho)
(def-autocad-variable lenslength)
(def-autocad-variable acadver)
(def-autocad-variable clayer)
(def-autocad-variable osmode)
(def-autocad-variable expert)
(def-autocad-variable filedia)
(def-autocad-variable vsmin)
(def-autocad-variable vsmax)
(def-autocad-variable viewsize)
(def-autocad-variable viewctr)
(def-autocad-variable undoctl)

(define-syntax (with-autocad-variable stx)
  (syntax-case stx ()
    ((with (name new-value) body ...)
     (syntax/loc stx
       (let ((previous (name))
             (new new-value))
         (unless (= previous new)
           (name new))
         (begin0
           (begin body ...)
           (unless (= previous new)
             (name previous))))))))

;;; target

(define target-name "TARGET")

(define (get-target-variable)
  (coord<-vector
   (get-variable target-name)))


;;; view ctr

(define view-ctr-name "VIEWCTR")

(define (get-viewctr-variable)
  (coord<-vector
   (get-variable view-ctr-name)))


;;; view dir

(define view-dir-name "VIEWDIR")

(define (get-viewdir-variable)
  (coord<-vector
   (get-variable view-dir-name)))


; document properties

(def-com-property active-layer (string string))
(def-com-property layer (string string))
(def-com-property layers)
(def-com-property active-viewport)
(def-com-property materials)
(def-com-property modelspace)
(def-com-property name)
(def-com-property views)

;; view properties

(def-com-property direction coord<-vector)
(def-com-property target coord<-vector)

;; viewport properties

(def-com-property lens-length (real real))

; documents methods

(def-obj open (string) void)
(def-obj add (string) com)

; modelspace methods

(provide all-objects)
(define (all-objects [modelspace active-modelspace])
  (for/list ((i (in-range 0 (count modelspace) 1)))
    (item modelspace i)))


(define (variant-double v)
  (type-describe (vector (real v) 0.0 0.0) '(variant double)))

; viewport

;; viewport properties

(define (get-viewport-center viewport)
  (coord<-vector
   (com-get-property viewport "Center")))

(define (set-viewport-center! viewport center)
  (com-set-property! viewport "Center" (point center)))


(define (get-viewport-height viewport)
  (com-get-property viewport "Height"))

(define (set-viewport-height! viewport height)
  (com-set-property! viewport "Height" height))


(define (get-viewport-snap-on viewport)
  (com-get-property viewport "SnapOn"))

(define (set-viewport-snap-on! viewport snap-on?)
  (com-set-property! viewport "SnapOn" snap-on?))


(define (get-viewport-target viewport)
  (coord<-vector
   (com-get-property viewport "Target")))

(define (set-viewport-target! viewport target)
  (com-set-property! viewport "Target" (point target)))


(define (get-viewport-width viewport)
  (com-get-property viewport "Width"))

(define (set-viewport-width! viewport width)
  (com-set-property! viewport "Width" width))

;; Commands

(define-syntax (def-cmd stx)
  (syntax-case stx ()
    ((_ name (in ...) body ...)
     (syntax/loc stx
       (begin
         (provide name)
         (define (name in ...)
           (send-command (string-append body ...))))))))

(define-syntax (def-new-shape-cmd stx)
  (syntax-case stx ()
    ((_ name (in ...) body ...)
     (syntax/loc stx
       (begin
         (provide name)
         (define (name in ...)
           (let ((prev-count (count active-modelspace)))
             (send-command (string-append body ...))
             (created-item active-modelspace prev-count))))))))

(define-syntax (def-new-shapes-cmd stx)
  (syntax-case stx ()
    ((_ name (in ...) body ...)
     (syntax/loc stx
       (begin
         (provide name)
         (define (name in ...)
           (let ((prev-count (count active-modelspace)))
             (send-command (string-append body ...))
             (created-items active-modelspace prev-count))))))))

;;The most fundamental one:

(def-new-shape-cmd new-shape-from (str)
  str)

(def-new-shapes-cmd new-shapes-from (str)
  str)

(def-cmd erase-all () "_.erase _all" vbCr vbCr)
(def-cmd dview-zoom-command (center target lens distance)
  (format "_.dview  _z ~A _po ~A ~A _d ~A" lens (point-string target) (point-string center) distance)
  vbCr)

(def-new-shape-cmd add-cone-frustum (c base-radius top-radius height)
  "_.cone "
  (point-string c)
  (format " ~A _T ~A ~A " base-radius top-radius height))

(def-cmd reset-ucs () "_.ucs _W ")
(def-cmd view-top () "_.-view _top ")
(def-cmd view-wireframe () "_.vscurrent _2dwireframe ")
(def-cmd view-conceptual () "_.vscurrent _conceptual ")

(def-cmd vl-load-com () "(vl-load-com)\n")

;(def-cmd zoom-extents () "_.zoom _e ")

;;To refer to com objects in commands

(define (handent-string handle)
  (string-append "(handent \"" handle "\")"))

(define (handent object)
  (handent-string (handle object)))

(define (handents objects)
  (string-join (map handent objects) " "))

(def-cmd union-command (objects)
  "_.union " (handents objects) vbCr)

(def-cmd subtraction-command (objects0 objects1)
   "_.subtract ~A~A~A~A"
   (handents objects0)
   vbCr;" "
   (handents objects1)
   vbCr)


(def-cmd intersection-command (objects0 objects1)
   "_.intersection ~A~A~A~A"
   (handents objects0)
   vbCr;" "
   (handents objects1)
   vbCr)

(def-cmd join-command (objects)
   "._join " (handents objects) vbCr)

;;Really poor's man approach to detect erased objects
(define (erased-object? obj)
  (with-handlers ((exn:fail? (lambda (e) 
                               (regexp-match? "Object was erased" (exn-message e)))))
    (object-name obj)
    #f))
  
(provide join-curves)
(define (join-curves curves)
  ;;Sometimes, AutoCAD reuses the first shape,
  ;;someother times it creates a new shape
  (join-command curves)
  (if (erased-object? (car curves))
      (item active-modelspace (- (count active-modelspace) 1))
      (car curves)))

;; spline (to avoid tangents)

(def-new-shape-cmd spline-command (points v0 v1)
  (format "_.spline _mo _Fit ~A ~A~A~A~A"
          (point-string (car points))
          (if v0 (format "_T ~A " v0) "")
          (string-join (map point-string (cdr points)) " ")
          vbCr
          (if v1 (format "_T ~A " v1) "")))

; loft

(provide loftnormals-ruled
         loftnormals-smooth-fit
         loftnormals-start-cross-section
         loftnormals-end-cross-section
         loftnormals-start-and-end-cross-section
         loftnormals-all-cross-sections
         loftnormals-use-draft-angle-and-magnitude)

(define loftnormals-ruled 0)
(define loftnormals-smooth-fit 1)
(define loftnormals-start-cross-section 2)
(define loftnormals-end-cross-section 3)
(define loftnormals-start-and-end-cross-section 4)
(define loftnormals-all-cross-sections 5)
(define loftnormals-use-draft-angle-and-magnitude 6)

(provide loftparam-no-twist
         loftparam-align-direction
         loftparam-simplify
         loftparam-close)

(define loftparam-no-twist 1)
(define loftparam-align-direction 2)
(define loftparam-simplify 4)
(define loftparam-close 8)

(provide loft-objects-string)
(define (loft-objects-string objects solid?)
  (format
   "._loft _mo ~A ~A~A_cross\n"
   (if solid? "_so" "_su")
   (handents objects)
   vbCr))

(provide loft-objects-guides-string)
(define (loft-objects-guides-string objects guides solid?)
  (format
   "._loft _mo ~A ~A~A_guides ~A~A"
   (if solid? "_so" "_su")
   (handents objects)
   vbCr;" "
   (handents guides)
   vbCr))

(provide loft-to-point-string)
(define (loft-to-point-string object point solid?)
  (format
   "._loft _mo ~A ~A _po ~A~A"
   (if solid? "_so" "_su")
   (handent object)
   (point-string point)
   vbCr))

(provide loft-command)
(define (loft-command loft-string normals closed?)
  (let ((previous-param (loftparam))
        (previous-normals (loftnormals)))
    (let ((param
           (if closed?
               (bitwise-ior previous-param loftparam-close)
               (bitwise-and previous-param (bitwise-not loftparam-close)))))
      (unless (= previous-param param)
        (loftparam param))
      (unless (= previous-normals normals)
        (loftnormals normals))
      (let ((prev (count active-modelspace)))
        (send-command loft-string)
        (unless (= previous-param param)
          (loftparam previous-param))
        (unless (= previous-normals normals)
          (loftnormals previous-normals))
        (singleton-or-union
         (created-items active-modelspace prev))))))

;;Sweep

(provide sweep-string)
(define (sweep-string object perpendicular? path solid? rotation scale)
  (format
   "._sweep _mo ~A ~A  _A ~A ~A~A~A "
   (if solid? "_so" "_su")
   (handent object)
   (if perpendicular? "_Yes" "_No")
   (if (= scale 1) "" (format "_S ~A " scale))
   (if (= rotation 0) "" (format "_T ~A " (radians->degrees rotation)))
   (handent path)))

;;HACK replace with def-new-shape-cmd?
(provide sweep-command)
(define (sweep-command object perpendicular? path solid? rotation scale)
  (new-shapes-from (sweep-string object perpendicular? path solid? rotation scale)))

;;Extrude

(provide extrude-length-string)
(define (extrude-length-string object length solid?)
  (format "._extrude _mo ~A ~A  ~A "
          (if solid? "_so" "_su")
          (handent object)
          length))

(provide extrude-direction-string)
(define (extrude-direction-string object start-point end-point solid?)
  (format "._extrude _mo ~A ~A  _d ~A ~A "
          (if solid? "_so" "_su")
          (handent object)
          (point-string start-point)
          (point-string end-point)))

;;HACK replace with def-new-shape-cmd?
(provide extrude-command-length)
(define (extrude-command-length object length solid?)
  (new-shapes-from (extrude-length-string object length solid?)))

;;HACK replace with def-new-shapes-cmd?
(provide extrude-command-direction)
(define (extrude-command-direction object start-point end-point solid?)
  (new-shapes-from (extrude-direction-string object start-point end-point solid?)))

;;Revolve

(provide revolve-string)
(define (revolve-string object axis-p0 axis-p1 a0 a1 solid?)
  (format "_.revolve _mo ~A ~A~A~A ~A _start ~A ~A\n"
          (if solid? "_so" "_su")
          (handent object)
          vbCr
          (point-string axis-p0)
          (point-string axis-p1)
          (radians->degrees a0) (radians->degrees (- a1 a0))))

(provide revolve-command)
(define (revolve-command object axis-p0 axis-p1 fi d-fi solid?)
  (singleton-or-union (new-shapes-from (revolve-string object axis-p0 axis-p1 fi d-fi solid?))))

;;Convtosurface

(provide mesh-smooth)
(define (mesh-smooth object [smooth-level 0])
  (with-autocad-variable (facetersmoothlev smooth-level)
    (new-shape-from
     (format "._meshsmooth ~A~A~A"
             (handent object)
             vbCr
             vbCr))))

(provide conv-to-surface)
(define (conv-to-surface object [smooth-level 0])
  (with-autocad-variable (smoothmeshconvert (if (> smooth-level 0) 0 2))
    (new-shape-from
     (format "._convtosurface ~A~A"
             (handent object)
             vbCr))))

(provide conv-to-solid)
(define (conv-to-solid object [smooth-level 0])
  (with-autocad-variable (smoothmeshconvert (if (> smooth-level 0) 0 2))
    (new-shape-from
     (format "._convtosolid ~A~A"
             (handent object)
             vbCr))))

;;Thicken

(define (thicken-string object length)
  (format "._thicken ~A~A~A\n"
          (handent object)
          vbCr
          length))

;;HACK replace with def-new-shape-cmd?
(provide thicken-command)
(define (thicken-command object length)
  (new-shape-from
   (thicken-string object length)))

;;Solid
(def-new-shape-cmd interior-solid (surfaces)
  (format "_.surfsculp ~A~A"
          (handents surfaces)
          vbCr))

;;Section

(provide slice-command)
#;(define (slice-command object p0 p1 p2 in)
  (send-command
   (format "_.slice ~A~A_3P ~A ~A ~A ~A\n"
           (handent object)
           vbCr
           (point-string p0)
           (point-string p1)
           (point-string p2)
           (point-string in)))
  object)

(define (slice-command object p n)
  (send-command
   (format "_.slice ~A~A_zaxis ~A ~A ~A\n"
           (handent object)
           vbCr
           (point-string p)
           (point-string (+c p n))
           (point-string (-c p n))))
  object)

;(provide slice-with-surface)
(def-new-shapes-cmd slice-with-surface (solid surface)
  (format "_.slice ~A~A_Surface ~A _Both\n"
          (handent solid)
          vbCr
          (handent surface)))

(provide fillet-command)
(define (fillet-command object0 object1 radius)
  (new-shape-from
   (format "_.fillet _Radius ~A ~A ~A\n"
           radius
           (handent object0)
           (handent object1))))

(provide xedges-command)
(define (xedges-command objects)
  (new-shapes-from
   (format "_.xedges ~A\n"
           (handents objects))))

(provide flatshot-command)
(define (flatshot-command objects)
  (new-shape-from
   (format "_.flatshot 0,0,0 1 1 0\n"
           #;#;#;
           (handents objects)
           vbCr
           vbCr)))

;; (define (gen-section pt1 pt2 com)
;;   (let ((plane (xyz 0 0 1)))
;;     (let ((s (add-section pt1 pt2 plane)))
;;       (com-set-property! s "TopHeight" 3)
;;       (com-set-property! s "BottomHeight" 1)
;;       (com-set-property! s "State" acSectionStatePlane
;; Set ss = .Settings
;; End With

;; With ss
;; .CurrentSectionType = acSectionType2dSection
;; End With

;; Dim acSectionTypeSettings As AcadSectionTypeSettings
;; Set acSectionTypeSettings = ss.GetSectionTypeSettings(acSectionType2dSection)
;; With acSectionTypeSettings
;; .ForegroundLinesVisible = True
;; .BackgroundLinesHiddenLine = True
;; .IntersectionFillHatchPatternName = "ANSI31"
;; 'and other settings
;; End With

;; sec.GenerateSectionGeometry x3DSolid, BoundaryObjs, FillObjs, BakcGroundObjs, ForegroundObjs, CurveTangencyObjs

;; End Sub



;;Utils

(provide closed-lines-points)
(define (closed-lines-points ls)
  (let loop ((chain (list (end-point (car ls)) (start-point (car ls)))) (ls (cdr ls)))
    (if (null? ls)
      (reverse chain)
      (let ((end (car chain)))
        (let ((next (findf (lambda (l1) (=c? end (start-point l1))) ls)))
          (if next
              (loop (cons (end-point next) chain) (remq next ls))
              (error 'closed-lines-points "Missing line segment")))))))
#|
(defun lib:pline_clockwise ( lw  / LST MAXP MINP)
  (if (= (type lw) 'ENAME)
      (setq lw (vlax-ename->vla-object lw)))  
  (vla-GetBoundingBox lw 'MinP 'MaxP)
  (setq
   minp(vlax-safearray->list minp)
   MaxP(vlax-safearray->list MaxP)
   lst(mapcar(function(lambda(x)
                        (vlax-curve-getParamAtPoint lw
                                                    (vlax-curve-getClosestPointTo lw x))))
             (list minp (list(car minp)(cadr MaxP))
                   MaxP (list(car MaxP)(cadr minp)))))
  (if(or
      (<=(car lst)(cadr lst)(caddr lst)(cadddr lst))
      (<=(cadr lst)(caddr lst)(cadddr lst)(car lst))
      (<=(caddr lst)(cadddr lst)(car lst)(cadr lst))
      (<=(cadddr lst)(car lst)(cadr lst)(caddr lst))) t nil))

(defun C:OFF40 ( )
(vl-load-com)
(if  
(and
  (setq en (car(entsel)))
  (wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE")
  (or (initget 7) t)
  (setq d (getdist "\nOffset distanse: "))
  (setq en (vlax-ename->vla-object en))
  (vlax-write-enabled-p en)
  (vlax-method-applicable-p en 'Offset)
  (if (lib:pline_clockwise en)
    d
    (setq d (- 0 d))  ;_ Plus or minus To change a sign
    )
  (setq i 1)
  (repeat 40
    (vl-catch-all-apply
      '(lambda()
         (vla-offset en (* i d))
         (setq i (1+ i))
         )
      )
    )
  )
(princ " Offset OK")
(princ "Not a polyline or on locket layer")
)
  (princ)
  )
|#

(provide 2dpoly<-3dpoly)
(define (2dpoly<-3dpoly 3dpoly)
  (let ((pts (coordinates 3dpoly))
        (closed? (closed 3dpoly)))
    ;;Just for testing, ignore the fact that the
    ;;3dpoly might not be contained in the XY plane
    (let ((2dpoly (add-polyline (if closed? (append pts (list (car pts))) pts))))
      (when closed? 
        (closed 2dpoly #t))
      2dpoly)))
;    (let ((p0 (car pts))
;          (p1 (cadr pts))
;          (p2 (last pts)))
;      (let ((base (xyz-on-points p0 p1 p2 p0)))
;     
;   
;(defun c:p3p2 (/ eg cl en e nc fp pt)
; (princ "\n[Change 3D Polyline to 2D Polyline.]")
; (setq e  (entsel "  Select a 3DPoly: ")          ; get the header data
;       en (car e)
;       cl (if(=(cdr(assoc 70(entget en)))1)1)             ; closed flag 1=yes
;       p1 (cdr(assoc 10(entget(entnext en))))
;       p2 (cdr(assoc 10(entget(entnext(entnext en)))))
; )
; (command "ucs" "3" p1 p2 "")
; (setq fp (trans p1 0 1))                                  ; save first point
;;       en (entnext en))                                   ; leave header
; (command "pline")
; (command fp)                                             ; id first vertex
; (while (/=(cdr(assoc 0(setq eg(entget(setq en(entnext en))))))"SEQEND")
;  (setq pt (trans(cdr(assoc 10 eg))0 1))
;  (if pt (command pt))
;  (if (and (not pt) cl)(command fp))
; );endwhile
; (command "")
; (command "ucs" "w")
; (princ)
;)
;;

(def-utility get-point (#:opt point string) coord<-vector)
(provide get-entity)
(define (get-entity [str "Select shape"])
  (define point (box (vector 0.0 0.0 0.0)))
  (define entity (box utility))
  (com-invoke utility "GetEntity" entity point str)
  (displayln (object-name (unbox entity)))
  (unbox entity))
(def-utility get-integer (#:opt string) number)
(def-utility get-real (#:opt string) number)

(provide singleton-or-union)
(define (singleton-or-union lst)
  (cond ((null? lst)
         (error 'singleton-or-union "Empty list"))
        ((null? (cdr lst))
         (car lst))
        (else
         (let ((s (copy (car lst))))
           (union-command (cons s (cdr lst)))
           (car lst)))))

;;Turn undo on or off

(provide undo-off)
(define (undo-off)
  (unless (even? (undoctl))
    (send-command (format "_.undo _C _None\n"))))

(provide undo-on)
(define (undo-on)
  (when (even? (undoctl))
    (send-command (format "_.undo _All\n"))))

;;Render

(def-cmd render-command (quality width height filename)
  (format "._-render ~A _R ~A ~A _yes ~A\n" quality width height filename))

(provide save-screen-png)
(define (save-screen-png filename)
  (let ((filename (string-append filename ".png")))
    (let ((prev-filedia (filedia)))
      (filedia 0)
      (when (file-exists? filename)
        (delete-file filename))
      (send-command
       (format "_.pngout ~A ~A"
               filename
               vbCr))
      (filedia prev-filedia))))

(provide save-screen-eps)
(define (save-screen-eps filename)
  (let ((filename (string-append filename ".eps")))
    (let ((prev-filedia (filedia)))
      (filedia 0)
      (when (file-exists? filename)
        (delete-file filename))
      (send-command
       (format "_.PSOUT ~A ~A _D _N _M 1 1=1 5000,5000\n" filename vbCr))
      (filedia prev-filedia))))


(define (save-eps filename)
  (let ((filename (string-append filename ".eps")))
    (let ((prev-filedia (filedia)))
      (filedia 0)
      (when (file-exists? filename)
        (delete-file filename))
;;      (send-command (format "_select _all ~A\n" vbCr))
      (send-command 
       (format "_.PSOUT ~A ~A _D _N _M 1 1=1 5000,5000\n" filename vbCr))
      (filedia prev-filedia))))



(provide view-parameters)
(define (view-parameters)
  (send-command "-VIEW _S foo\n")
  (let ((view (last-item (views active-document))))
    (begin0
        (list (direction view)
              (target view)
              ;(lens-length (active-viewport active-document))
              (let-values (((types data) (get-x-data view "ACAD")))
                data))
      (delete view)
      ;; (send-command "-VIEW _D foo\n")
      )))

(provide 2d-view)
(define (2d-view [center #f] [magnification #f])
  (if center
      (zoom-center center magnification)
      (values (apply xyz (vector->list (viewctr)))
              (viewsize))))

(provide window-size)
(define (window-size [new-width #f] [new-height #f])
  (if new-width
      (begin
        (width application new-width)
        (height application new-height))
      (values  
       (width application)
       (height application))))

(provide window-status)
(define (window-status [state #f])
  (if state
      (window-state application state)
      (window-state application)))

;;get-view
(defun alisp-get-view (/ params)
  (setq params (tblsearch "VIEW" "foo"))
  (setq params (cddr params))
  (vl-princ-to-string
   (list (mapcar '+ (cdr (assoc 12 params)) (cdr (assoc 11 params)))
         (cdr (assoc 12 params))
         (cdr (assoc 42 params)))))

(provide get-view)
(define (get-view)
  (send-command (format "-VIEW _S foo\n"))
  (begin0
    (match (with-input-from-string (alisp-get-view) read)
      [(list (list xa ya za) (list xb yb zb) l)
       `(set-view (xyz ,xa ,ya ,za) (xyz ,xb ,yb ,zb) ,l)])
    (send-command (format "-VIEW _D foo\n"))))