LISP. Быстрая отрисовка 3D трубопроводов (экструдирование) (Страница 2 из 3)

; Команда построения 3-х мерной полилинии с дополнительными опциями управления текущей ПСК.
; Перед указанием каждой следующей вершины полилинии имеется возможность установить желаемую ориентацию осей ПСК.
; Опции командной строки похожи на опции команды UCS, но имеются особенности:
; 1. Точка начала ПСК всегда переносится в последнюю построенную вершину полилинии.
;    Все изменения ПСК с помощью доступных опций касаются только направления её осей X и Y.
;    Точка начала ПСК остается неизменной. Это позволяет задавать координаты вершин (кроме первой)
;    с командной строки в абсолютных координатах (не используя @).
; 2. Oпция Above.
;    Запрашивает смещение следующей вершины относительно последней построенной вдоль оси Z ПСК.
;    Строит новую вершину и переносит в неё ПСК.
; 3. Опция ZDepth.
;    Запрашивает смещение ПСК вдоль оси Z относительно последней вершины, переносит ПСК, но вершину не строит,
;    а ждет указания точки уже в новой плоскости построений.
; 4. Опция Prev.
;    Ориентирует оси текущей ПСК в соответствии с ориентацией осей ближайшей ПСК из списка отката, у которой
;    направление осей не совпадает с текущим. Начало текущей ПСК остается неизменным.
; Загружать весь файл.
; Вызов с командной строки: 3DPLINE
;
;
(defun c:3dpline ( /
      read-ucs; локальная функция.
      ucs; список — состояние ПСК на момент вызова команды.
      icon; текущее состояние системной переменной UCSICON.
      )
  ; Определение локальной функции:
  (defun read-ucs ( / org)
    (setq org (getvar 'ucsorg))
    (list org
    (mapcar '+ (getvar 'ucsxdir) org)
    (mapcar '+ (getvar 'ucsydir) org)
    ); return.
  ); end defun.
  ;
  (begin-undo-group 0)
  ;
  (setq icon (getvar 'ucsicon))
  (setq ucs (read-ucs))
  ;
  (vl-catch-all-apply 'brokenline)
  ;
  ; Восстановление исходной ПСК и видимости пиктограммы:
  (setvar 'ucsicon 0)
  (command "_.ucs" "_World" "_.ucs" "_3point" (car ucs) (cadr ucs) (caddr ucs))
  (setvar 'ucsicon icon)
  ;
  (end-undo-group)
  (princ)
); end defun.
; BROKENLINE.
; Внешняя функция: READ-UCS.
; Внешняя переменная: icon — состояние системной переменной UCSICON на момент вызова команды.
; Переменная уровня документа: ::model_space — указатель пространства модели.
(defun brokenline ( /
       pt; результат запроса точки.
       brol; vla-указатель.
       disp; смещение начала ПСК.
       nullbase; точка (0.0 0.0 0.0).
       org; точка начала ПСК.
       act; список с информацией о последнем действии пользователя.
       actions; список действий.
       coords; список координат построенной полилинии.
       )
  (setq nullbase '(0.0 0.0 0.0))
  (if (not ::model_space) (setq ::model_space (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))));
  ;
  (initget "eXit")
  (setq pt (getpoint "\nSpecify first vertex or [eXit] <exit>: "))
  (if (or (not pt) (= pt "eXit")) (quit));
  (setq actions (append (list (cons nil (read-ucs))) actions))
  (command "_.ucs" "_Origin" pt)
  (while pt
    (initget 0 "Above ZDepth Top Bottom Front BAck Left Right X Y Z Prev Undo")
    (setq pt (getpoint
         nullbase
         "\nSpecify next vertex or [Above/ZDepth/Top/Bottom/Front/BAck/Left/Right/X/Y/Z/Prev/Undo] <exit>: "
       )
    ); setq.
    (cond
      ((not pt)); конец построений.
      ((listp pt); указана точка:
       (cond
   (brol; добавляем новую вершину:
    (setq actions (append (list (cons T (read-ucs))) actions))
    (command "_.ucs" "_Origin" pt)
    (vlax-invoke-method brol 'AppendVertex (vlax-3d-point (trans nullbase 1 0)))
    (vlax-invoke-method brol 'update)
    );
   (T; создаем полилинию из 2х вершин:
    (setq brol (vlax-invoke-method
           ::model_space
           'Add3Dpoly
           (vlax-make-variant
       (vlax-safearray-fill
         (vlax-make-safearray vlax-vbdouble '(0 . 5))
         (append (trans nullbase 1 0) (trans pt 1 0))
         )
       (+ vlax-vbarray vlax-vbdouble)
       );
           );
    ); setq.
    (setq actions (append (list (cons T (read-ucs))) actions))
    (command "_.ucs" "_Origin" pt)
   );
       ); end cond.
      );
      ((= pt "ZDepth"); указание на смещение ПСК вдоль оси Z:
       (setq disp nil)
       (while (not disp)
   (initget 128)
   (setq disp (getpoint "\nSpecify Z-elevation for new UCS origin: "))
   (cond
     ((not disp) (princ "\nInvalid input. Please retry.")); пустой ввод. Повтор.
     ((listp disp) (setq disp (caddr disp)));
     ((numberp (setq disp (atof disp))));
     (T (princ "\nInvalid input. Please retry.") (setq disp nil));
     ); end cond.
   ); end while.
       (setq actions (append (list (cons nil (read-ucs))) actions))
       (command "_.ucs" "_Move" "_Zdepth" disp)
      );
      ((= pt "Above"); указание на построение следующей вершины смещением предыдущей по оси Z:
       (setq disp nil)
       (while (not disp)
   (initget 128)
   (setq disp (getpoint "Specify Z-elevation for next vertex: "))
   (cond
     ((not disp) (princ "\nInvalid input. Please retry.")); пустой ввод. Повтор.
     ((listp disp) (setq disp (caddr disp)));
     ((numberp (setq disp (atof disp))));
     (T (princ "\nInvalid input. Please retry.") (setq disp nil));
     ); end cond.
   ); end while.
       (setq actions (append (list (cons T (read-ucs))) actions))
       (command "_.ucs" "_Origin" (setq pt (list 0.0 0.0 disp)))
       (vlax-invoke-method brol 'AppendVertex (vlax-3d-point (trans nullbase 1 0)))
       (vlax-invoke-method brol 'update)
      );
      ((wcmatch pt "[XYZ]"); поворот вокруг оси:
       (setq ang (getreal (strcat "\nSpecify rotation angle about " pt " axis <0.0>: ")))
       (cond
   (ang
    (setq actions (append (list (cons nil (read-ucs))) actions))
    (command "_.ucs" (strcat "_" pt) ang)
   );
       ); end cond.
      );
      ((or (wcmatch (substr pt 1 1) "[TBFLRW]") (= pt "BAck"))
       (setq actions (append (list (cons nil (read-ucs))) actions))
       (setq org (getvar 'ucsorg))
       (setvar 'ucsicon 0)
       (command "_.ucs" (strcat "_" pt))
       (setq org (trans org 0 1))
       (command "_.ucs" "_Origin" org)
       (setvar 'ucsicon icon)
      );
      ((= pt "Prev")
       (setq pt 0)
       (setq act (car actions))
       (while (and act (equal
       (list (getvar 'ucsxdir) (getvar 'ucsydir))
       (list (mapcar '- (caddr act) (cadr act)) (mapcar '- (cadddr act) (cadr act)))
       1e-9; точность сравнения.
           );
        ); and.
   (setq pt (1+ pt))
   (setq act (nth pt actions))
       ); end while.
       (cond
   (act; найдена ПСК в списке отката, которая отличается от текущей:
    (setq org (getvar 'ucsorg))
    (setq actions (append (list (cons nil (read-ucs))) actions))
    (setvar 'ucsicon 0)
    (command "_.ucs" "_World" "_.ucs" "_3point" (cadr act) (caddr act) (cadddr act))
    (setq org (trans org 0 1))
    (command "_.ucs" "_Origin" org)
    (setvar 'ucsicon icon)
   );
   (T (princ "All previous UCSs not differs from current UCS."));
       ); end cond.
      );
      ((= pt "Undo"); отмена последнего действия:
       (setq act (car actions)); последнее зафиксированное действие.
       (setq actions (cdr actions))
       (cond
   ((car act); последним действием была добавлена вершина полилинии:
    (setq coords (reverse (vlax-safearray->list (vlax-variant-value (vlax-get-property brol 'coordinates)))))
    (cond
      ((= (length coords) 6); полилиния из oдного сегмента:
       (vlax-invoke-method brol 'delete)
       (vlax-release-object brol)
       (setq brol nil)
      );
      (T; полилиния из 2х и более сегментов:
       (vlax-invoke-method brol 'delete)
       (vlax-release-object brol)
       (setq coords (reverse (cdddr coords)))
       (setq brol (vlax-invoke-method
        ::model_space
        'Add3Dpoly
        (vlax-make-variant
          (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length coords)))) coords)
          (+ vlax-vbarray vlax-vbdouble)
        );
      );
       ); setq.
      );
    ); end cond.
    (setvar 'ucsicon 0)
    (command "_.ucs" "_World" "_.ucs" "_3point" (cadr act) (caddr act) (cadddr act))
    (setvar 'ucsicon icon)
   );
   (actions; изменялась только ПСК и список отката не пустой:
    (setvar 'ucsicon 0)
    (command "_.ucs" "_World" "_.ucs" "_3point" (cadr act) (caddr act) (cadddr act))
    (setvar 'ucsicon icon)
   );
   (T
    (setvar 'ucsicon 0)
    (command "_.ucs" "_World" "_.ucs" "_3point" (cadr act) (caddr act) (cadddr act))
    (setvar 'ucsicon icon)
    (initget "eXit")
    (setq pt (getpoint "\nSpecify first vertex or [eXit] <exit>: "))
    (if (or (not pt) (= pt "eXit")) (quit));
    (setq actions (append (list (cons nil (read-ucs))) actions))
    (command "_.ucs" "_Origin" pt)
   );
       ); end cond.
      );
    ); end cond.
  ); end while.
  (princ)
); end defun.
; BEGIN-UNDO-GROUP.
; Установка отметки начала группы команд.
; Возврат: набор объектов предварительного выбора или nil.
(defun begin-undo-group (mode; режим обработки набора предварительно выбранных объектов.
       /
       undo_state; текущая настройка команды UNDO.
       ss; набор объектов предварительного выбора.
       )
  (cond
    ((= mode 0) (sssetfirst nil nil)); не разрешен предварительный выбор.
    ((= mode 1); команда может использовать набор предварительного выбора:
     (if (and (setq ss (ssget "_I")) (= 0 (getvar 'pickfirst))) (sssetfirst nil nil)); end if.
    );
    ((= mode 2); функция не меняет набор предварительного выбора:
     (setq ss (ssget "_I"))
    );
  ); end cond.
  ;
  (setq undo_state (getvar 'undoctl))
  (setvar 'cmdecho 0)
  (cond
    ((= 0 (logand undo_state 1)) (command "_.undo" "_All")); если отключена возможность отмены.
    ((= 2 (logand undo_state 2)) (command "_.undo" "_control" "_all")); если запрещена отмена более одной команды.
  ); end cond.
  (if (= 0 (logand undo_state 8)) (command "_.undo" "_begin")); если нет открытой группы команд.
  (if (and (= mode 2) ss) (sssetfirst nil ss))
  ss; return.
); end defun.
; END-UNDO-GROUP.
; Установка отметки окончания группы команд.
; Возврат: nil.
(defun end-undo-group ( / )
  (setvar 'cmdecho 0)
  (if (= 8 (logand (getvar 'undoctl) 8))(command "_.undo" "_end")); end if.
); end defun.