Тема: LISP. Выравнивание растра по отрезку
Программу разработал Александр Ривилис по запросу участника форума под ником Forma.
Код можно сохранить в файле с именем align_image.lsp
;;-------------------------------------------------- ;; Программа для выравнивания растра по отрезку. ;; Автор Александр Ривилис ;;-------------------------------------------------- (defun C:ALIGN_IMAGE ( / ss en el p1 p2 u v ang ang_u ul vl _ce) ;; Функция вычисляет длину вектора ;; Усовершенствование: Евгений Елпанов (defun vector_len (v) (sqrt (apply (function +) (mapcar (function (lambda (x)(* x x))) v))) ) ;; (setq _ce (getvar "cmdecho")) (setvar "cmdecho" 0) (command "_.Undo" "_Group") (princ "\nВыберите отрезок, по которому будет выполняться выравнивание: ") (if (setq ss (ssget "_:S:E" '((0 . "LINE")))) (progn (setq el (entget (ssname ss 0))) (setq p1 (cdr (assoc 10 el)) p2 (cdr (assoc 11 el))) ;; Упорядочим отрезок по оси X (if (> (car p1) (car p2)) (progn (setq p1 (list p1 p2) p2 (car p1) p1 (last p1)) )) ;; (if (progn ;; Разберемся с углом: (setq ang (angle p1 p2)) (cond ((and (> ang (* PI 0.25)) (< ang (* PI 0.75))) ;; Угол с вертикалью (setq ang (angle (list (car p1) (cadr p2)) (list (car p2) (cadr p1)))) (setq ang (+ ang (* PI 0.5))) ) ((and (> ang (* PI 1.25)) (< ang (* PI 1.75))) ;; Угол с вертикалью (setq ang (angle (list (car p1) (cadr p2)) (list (car p2) (cadr p1)))) (setq ang (- ang (* PI 0.5))) ) (t ;; Угол с горизонталью (setq ang (angle (list (car p1) (cadr p2)) (list (car p2) (cadr p1)))) ) ) ;; (cond (princ "\nВыберите растр для выравнивания: ") (if (setq ss (ssget "_:S:E" '((0 . "IMAGE")))) (progn (setq el (entget (ssname ss 0))) (setq u (cdr (assoc 11 el)) v (cdr (assoc 12 el))) (setq ang_u (angle '(0.0 0.0 0.0) u)) (setq el (subst (cons 11 (polar '(0.0 0.0 0.0) (+ ang ang_u) (vector_len u))) (assoc 11 el) el)) (setq el (subst (cons 12 (polar '(0.0 0.0 0.0) (+ ang (* PI 0.5) ang_u) (vector_len v))) (assoc 12 el) el)) (entmod el) )) ;; (if (progn )) ;; (if (progn (command "_.Undo" "_end") (setvar "cmdecho" _ce) (princ) )
Возможный макрос для кнопки или пункта меню:
^C^C^P(if (not C:ALIGN_IMAGE) (load "align_image")) ALIGN_IMAGE