#lang scheme
;; acad-utils.ss
;; AutoCAD specific utility functions (view manipulation and stuff)

(require "../../utils.ss"
         "../../common/primitives-new.ss" ;; For creating primitives

         "base.ss"
         "com-utils.ss")

(provide copy-entity

         entlast

         erase-all

         zoom-3d-conceptual
         zoom-2d-top

         erase-2d-top
         ;command

         with-layer
         init-layer-stack
         destroy-layer-stack
         )


;(define (command* str)
;  (command str)
;  (entlast))
;
(define (command str)
  (invoke SendCommand
          (get-property (acad) ActiveDocument)
          str))

(define (copy-entity ent)
  (display "Copying...")(newline)
  (invoke Copy
          ent))


(define (erase-entity obj)
  (invoke Erase obj))

(define (entlast)
  (invoke Item (acad-mspace)
          (- (get-property (acad-mspace) Count) 1)))

(define (erase-2d-top)
  (zoom-2d-top)
  (erase-all))

(define (erase-all)
  (ensure-autocad-is-started)
  (command "._erase _all \n"))
;  (define (erase-aux n)
;    (if (negative? n)
;        #t
;        (begin (display* "n: " n ", obj: " (invoke Item (acad-mspace) n)
;                         ", Count: " (get-property (acad-mspace) Count))
;          (erase-object (invoke Item (acad-mspace) n))
;          (erase-aux (- n 1)))))
;  (erase-aux (- (get-property (acad-mspace) Count) 1)))

(define (zoom-3d-conceptual)
  (ensure-autocad-is-started)
  (command "_.-view _swiso ")
  (command "_.vscurrent _Conceptual ")
  (command "_.zoom _e "))

(define (zoom-2d-top)
  (ensure-autocad-is-started)
  (command "_.vscurrent _2dwireframe ")
  (command "_.-view _top "))


(define-primitive layer
  [name string?]
  [obj primitive?])

(define layer-stack '())
(define-syntax with-layer
  (syntax-rules ()
    [(_ name stmt ...)
     (begin
       (push-layer! name)
       stmt ...
       (pop-layer!))]))

(define (init-layer-stack)
  (set! layer-stack (list (current-layer)))
  (set-layer))

(define (destroy-layer-stack)
  (set-layer (last layer-stack))
  (set! layer-stack '()))

(define (push-layer! l)
  (set! layer-stack (list* l layer-stack))
  (set-layer))

(define (pop-layer!)
  (set! layer-stack (rest layer-stack))
  (set-layer))

(define set-layer
  (case-lambda
    [()
     (command "._layer" "_M" (first layer-stack) "")] ;; _Make
    [(l)
     (command "._layer" "_M" l "")]))

(define (current-layer)
  (get-property
   (get-property
    (get-property
     (acad)
     ActiveDocument)
    ActiveLayer)
   Name))