| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)

Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)

Ответ
Поиск в этой теме
Непрочитано 20.07.2008, 20:12
Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)
Red Nova
 
ՃԱՐՏԱՐԱԳԵՏ, Տ.Գ.Թ.
 
Торонто
Регистрация: 23.10.2007
Сообщений: 1,980

Со школы не ладится у меня с программированием. Все предметы щелкал, а на экзамене по информатике (Visual foxpro) программку типа суммирования столбцов списал у соседа (это уже в университете).
Не смотря на эте намерен научится писать программы для Автокада на лиспе, скачал книгу Хювенена, несколько примеров создания программ, но после получасового “смотрения” таких книг мое мышление явно притормаживает.
Решил пойти другим путем.
Нашел самый короткий лисп из моей коллекции, и прошу программистов с этого форума пошагово объяснить какой символ что означает. Надеюсь на вашу помощь.


Код:
[Выделить все]
(defun c:make-blocks-explodeable (/ adoc)
  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-startundomark
  (vlax-for blk_def (vla-get-blocks adoc)
    (if (and (equal (vla-get-isxref blk_def) :vlax-false)
             (equal (vla-get-islayout blk_def) :vlax-false)
             ) ;_ end of and
      (vl-catch-all-apply '(lambda () (vla-put-explodable blk_def :vlax-true)))
      ) ;_ end of if
    ) ;_ end of vlax-for
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun
_____________________________________________________________________________________________________________

Прошло много лет и топик теперь представляет из себя площадку для обучения азов программирования для многих начинающих.
Так что начинающие лиспогрызы приветствуются .
__________________
Блог

Последний раз редактировалось Red Nova, 12.07.2017 в 05:43.
Просмотров: 1965923
 
Непрочитано 28.10.2015, 16:58
#2781
Pavel_GP

Инженер-гидрограф
 
Регистрация: 15.09.2011
г.г. Ленинград
Сообщений: 170


Кулик Алексей, как время будет пересмотри в другой вариант по примеру
Код:
[Выделить все]
 (defun tt (lst / res count)
 ;; (tt (mapcar 'cdr (vl-remove-if-not '(LAMBDA(x)(=(car x) 10)) (entget(car(entsel))))))
 (setq count 0)
 (mapcar
   (function
     (lambda (x / tmp)
         ;  (- pi
       (cond
         ((= count 0)
          (setq tmp   (angle x (nth (1+ count) lst))
                count (1+ count)
                ) ;_ end of setq
          tmp
          )
         ((= count (1- (length lst))) (angle (nth (1- count) lst) x))
         (t
          (setq tmp   (* (+ (angle (nth (1- count) lst) x)
                            (angle x (nth (1+ count) lst))
                            ) ;_ end of +
                         0.5
                         ) ;_ end of *
                count (1+ count)
                ) ;_ end of setq
          tmp
          )
         ) ;_ end of cond
         ; ) ;_ end of -
       ) ;_ end of lambda
     ) ;_ end of function
   lst
   ) ;_ end of mapcar
 ) ;_ end of defun
Пришлось все кардинально поменять,
Пример на выходе (у1 у1 у2 у2 у3 у3 .... уn уn), где у - углы. Если 2 сигмента то 4 угла и т.д.
Спс.

----- добавлено через ~21 ч. -----
Ребята, Пока основной учитель занят, подскажите как получить:
Пример (lst (1 2 3 4 5 6...n)), преобразовать в (lst (1 1 2 2 3 3 4 4 ... n n)), ну если кому не трудно. спс.
__________________
AutoCAD Civil 3D 2012г. 32-разрядная.

Последний раз редактировалось Pavel_GP, 29.10.2015 в 14:28.
Pavel_GP вне форума  
 
Непрочитано 29.10.2015, 15:09
1 | #2782
trushev


 
Регистрация: 12.01.2015
Сообщений: 261


Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
Ребята, Пока основной учитель занят, подскажите как получить:
Пример (lst (1 2 3 4 5 6...n)), преобразовать в (lst (1 1 2 2 3 3 4 4 ... n n)), ну если кому не трудно. спс.
Не профессионально, но наиболее просто и понятно
Код:
[Выделить все]
(setq lst 'nil)
(foreach k '(1 2 3 4 5 6 ... n)
            (setq lst (cons k lst)
                     lst (cons k lst)
            )
);foreach
(setq lst (reverse lst))
trushev вне форума  
 
Непрочитано 29.10.2015, 15:19
1 | #2783
ProPeller

Пастух
 
Регистрация: 16.07.2012
Питер
Сообщений: 318


Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
Ребята, Пока основной учитель занят, подскажите как получить:
Пример (lst (1 2 3 4 5 6...n)), преобразовать в (lst (1 1 2 2 3 3 4 4 ... n n)), ну если кому не трудно. спс.
Код:
[Выделить все]
 (apply 'append (mapcar '(lambda (l1) (list l1 l1)) lst))
__________________
Автоматизация должна быть автоматической.
ProPeller вне форума  
 
Непрочитано 29.10.2015, 15:51
1 | #2784
gomer

строю, ломаю
 
Регистрация: 03.04.2008
Украина
Сообщений: 5,515


Цитата:
Сообщение от ProPeller Посмотреть сообщение
(apply 'append (mapcar '(lambda (l1) (list l1 l1)) lst))
можно проще
Код:
[Выделить все]
 (apply 'append (mapcar 'list lst lst))
gomer вне форума  
 
Непрочитано 29.10.2015, 15:52
#2785
ProPeller

Пастух
 
Регистрация: 16.07.2012
Питер
Сообщений: 318


Цитата:
Сообщение от gomer Посмотреть сообщение
можно проще
Чёт я тупанул
__________________
Автоматизация должна быть автоматической.
ProPeller вне форума  
 
Непрочитано 29.10.2015, 16:20
#2786
trushev


 
Регистрация: 12.01.2015
Сообщений: 261


Замечательный урок оптимизации.
trushev вне форума  
 
Непрочитано 29.10.2015, 16:58
#2787
Pavel_GP

Инженер-гидрограф
 
Регистрация: 15.09.2011
г.г. Ленинград
Сообщений: 170


Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
Пример на выходе (у1 у1 у2 у2 у3 у3 .... уn уn), где у - углы. Если 2 сигмента то 4 угла и т.д.
Спс ребятам.
получилось вот так
Код:
[Выделить все]
 (setq count 0)
	  (while (< count (1- (length xy_v)))
	    (setq az0 (angle (nth count xy_v) (nth (1+ count) xy_v)))
	    (setq az_s (append az_s (list az0)))
	    (setq count (1+ count))
	  )
	  (setq azimut_s (apply 'append (mapcar 'list az_s az_s)))
__________________
AutoCAD Civil 3D 2012г. 32-разрядная.
Pavel_GP вне форума  
 
Непрочитано 29.10.2015, 17:25
1 | #2788
ProPeller

Пастух
 
Регистрация: 16.07.2012
Питер
Сообщений: 318


Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
получилось вот так
чутка оптимизировал
Код:
[Выделить все]
  (setq
  az_s	   (mapcar 'angle (reverse (cdr (reverse xy_v))) (cdr xy_v))
  azimut_s (apply 'append (mapcar 'list az_s az_s))
 )
__________________
Автоматизация должна быть автоматической.
ProPeller вне форума  
 
Непрочитано 30.10.2015, 08:30
#2789
Pavel_GP

Инженер-гидрограф
 
Регистрация: 15.09.2011
г.г. Ленинград
Сообщений: 170


Цитата:
Сообщение от ProPeller Посмотреть сообщение
чутка оптимизировал
Добро!

----- добавлено через ~3 ч. -----
Мне необходимо к каждому элементу списка (+ или -) коэффициент (пример к=pi)
Код:
[Выделить все]
 (mapcar '(lambda (e) (+ e pi)) azimut_s)
Хорошо?
Объединяем в один код
Код:
[Выделить все]
(setq
 az_s	   (mapcar 'angle (reverse (cdr (reverse xy_v))) (cdr xy_v))
 azimut_s (apply 'append (mapcar 'list az_s az_s))
k pi
azimut_s (mapcar '(lambda (e) (+ e k)) azimut_s)
)
----- добавлено через ~1 ч. -----
есть список (lst (1 2 3...n)), необходимо получить на выходе (1 2 2 3 3...n)
Решение:
Код:
[Выделить все]
 (reverse
		 (cdr (reverse
			(cdr (apply 'append (mapcar 'list lst lst)))
		      ) ;_end of reverse
		 ) ;_end of cdr
	       ) ;_end of reverse
Правильно?
__________________
AutoCAD Civil 3D 2012г. 32-разрядная.

Последний раз редактировалось Pavel_GP, 30.10.2015 в 13:04.
Pavel_GP вне форума  
 
Непрочитано 30.10.2015, 14:59
1 | #2790
ProPeller

Пастух
 
Регистрация: 16.07.2012
Питер
Сообщений: 318


Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
есть список (lst (1 2 3...n)), необходимо получить на выходе (1 2 2 3 3...n)
Правильно?
Если нужно избавиться только от первого элемента списка, то достаточно лишь
Код:
[Выделить все]
 (cdr (apply 'append (mapcar 'list lst lst)))
Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
Объединяем в один код
Незачем так извращаться.
Код:
[Выделить все]
 (setq
 k pi
 az_s     (mapcar '(lambda (l1 l2) (+ k (angle l1 l2))) (reverse (cdr (reverse xy_v))) (cdr xy_v))
 azimut_s (apply 'append (mapcar 'list az_s az_s))
)
__________________
Автоматизация должна быть автоматической.
ProPeller вне форума  
 
Непрочитано 30.10.2015, 15:05
#2791
Pavel_GP

Инженер-гидрограф
 
Регистрация: 15.09.2011
г.г. Ленинград
Сообщений: 170


Вопрсик:
Есть список координат (lst ((x1 y1) (x2 y2) (x3 y3) (x4 y4)...(xn yn))), необходимо получить:
1. координаты пересечений между отрезками (01 02 ... 0n), где 01 ((x1 y1) (x2 y2)), 02 ((x3 y3) (x4 y4)), координаты пересечений (x_pt1 y_pt1) и т.д.
2. создать новый список ((x1 y1) (x_pt1 y_pt1) (x_pt2 y_pt2) ... (xn yn)), первый и последний списки координат не изменяются.
Благодарствую.

----- добавлено через ~5 мин. -----
Цитата:
Сообщение от ProPeller Посмотреть сообщение
Если нужно избавиться только от первого элемента списка, то достаточно лишь
Спс. Я сам ошибся избавиться от первого и последнего

----- добавлено через ~6 мин. -----
Цитата:
Сообщение от ProPeller Посмотреть сообщение
Незачем так извращаться.
За оптимизацию спасибо!
__________________
AutoCAD Civil 3D 2012г. 32-разрядная.

Последний раз редактировалось Pavel_GP, 30.10.2015 в 15:31. Причина: изменения синего цвета
Pavel_GP вне форума  
 
Непрочитано 30.10.2015, 15:35
#2792
trushev


 
Регистрация: 12.01.2015
Сообщений: 261


Цитата:
Сообщение от ProPeller Посмотреть сообщение
Незачем так извращаться.
Смущает строка 2. Почему нельзя pi применить напрямую?
trushev вне форума  
 
Непрочитано 30.10.2015, 15:40
1 | #2793
ProPeller

Пастух
 
Регистрация: 16.07.2012
Питер
Сообщений: 318


Цитата:
Сообщение от trushev Посмотреть сообщение
Смущает строка 2. Почему нельзя pi применить напрямую?
Конечно можно. Просто автор обмолвился, мол (пример к=pi). Вдруг там будет присваиваться другой коэффициент.

Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
Вопрсик:
Есть список координат (lst ((x1 y1) (x2 y2) (x3 y3) (x4 y4)...(xn yn))), необходимо получить:
1. координаты пересечений между отрезками (01 02 ... 0n), где 01 ((x1 y1) (x2 y2)), 02 ((x3 y3) (x4 y4)), координаты пересечений (x_pt1 y_pt1) и т.д.
2. создать новый список ((x1 y1) (x_pt1 y_pt1) (x_pt2 y_pt2) ... (xn yn)), первый и последний списки координат не изменяются.
Лучше всего будет использовать рекурсию. Но для начала обязательно нужно проверить чтобы список был кратный 4-м.

Код:
[Выделить все]
 (defun PPT:2D->StEnd (tmplst)
 (if
  (and
   tmplst
   (= (rem (VL-LIST-LENGTH tmplst) 4) 0)
  )
  (cons
   (inters
    (car tmplst)
    (cadr tmplst)
    (caddr tmplst)
    (cadddr tmplst)
    nil
   )
   (PPT:2D->StEnd (cddddr tmplst))
  )
 )
)

(append
 (list (car lst))
 (PPT:2D->StEnd lst)
 (list (last lst)
)
__________________
Автоматизация должна быть автоматической.

Последний раз редактировалось ProPeller, 30.10.2015 в 16:01.
ProPeller вне форума  
 
Непрочитано 30.10.2015, 15:45
#2794
Pavel_GP

Инженер-гидрограф
 
Регистрация: 15.09.2011
г.г. Ленинград
Сообщений: 170


Цитата:
Сообщение от trushev Посмотреть сообщение
Почему нельзя pi применить напрямую?
pi - это значение коэффициента k (как пример)

----- добавлено через ~2 мин. -----
Цитата:
Сообщение от ProPeller Посмотреть сообщение
Лучше всего будет использовать рекурсию. Но для начала обязательно нужно проверить чтобы список был кратный 4-м.
Спасибо большое , не успеваю проверить убегаю - до понедельника.
__________________
AutoCAD Civil 3D 2012г. 32-разрядная.
Pavel_GP вне форума  
 
Непрочитано 02.11.2015, 11:01
#2795
Pavel_GP

Инженер-гидрограф
 
Регистрация: 15.09.2011
г.г. Ленинград
Сообщений: 170


ув. ProPeller. Большое спасибо за твой труд.
Немного уточню что я хотел в итоге получить, и чтоб ты смог поправить свое решение если не трудно:
1.
Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
1. координаты пересечений между отрезками (01 02 ... 0n), где 01 ((x1 y1) (x2 y2)), 02 ((x3 y3) (x4 y4)), координаты пересечений (x_pt1 y_pt1) и т.д.
Здесь я хотел указать на то, первое пересечение понятно из примера, а вот последующие должны быть такими берется отрезок 02 и 03 ((x5 y5) (x6 y6)) и т.д.
2. Пример: Если полилиния состоит трех сегментов то итог : ((x1 y1) (xpt1 ypt1) (xpt2 ypt2) (xn yn)), где xpt1 ypt1 - координаты первой точки пересечения 2-х сегментов (01 и 02), xpt2 ypt2 - ... (02 и 03), а x1 y1 - координата точки первого сегмента, xn yn - координата точки последнего сегмента.
Спс.

----- добавлено через ~1 ч. -----
3. Если один сегмент, то
Код:
[Выделить все]
 (append
 (list (car lst))
 (list (last lst)
)
)), проще = lst
__________________
AutoCAD Civil 3D 2012г. 32-разрядная.

Последний раз редактировалось Pavel_GP, 02.11.2015 в 12:38.
Pavel_GP вне форума  
 
Непрочитано 02.11.2015, 12:44
#2796
ProPeller

Пастух
 
Регистрация: 16.07.2012
Питер
Сообщений: 318


Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
и чтоб ты смог поправить свое решение если не трудно
Мне-то не трудно, но проще один раз изложить все доступно и с желаемым результатом, чем каждый последующий раз просить доработать код. Мы тут с этими пересечениями уже целую страницу форума накатали.

Короче, мой код отсюда высчитывал координаты пересечений между отрезками 1 - 2, 3 - 4, 5 - 6 и т.д. Насколько я понял из последнего поста, нужно сделать 1 - 2, 2 - 3, 3 - 4 и т.д., тогда код будет таким.
Код:
[Выделить все]
  (defun PPT:2D->StEnd (tmplst)
 (if
  (and
   tmplst
   (= (rem (VL-LIST-LENGTH tmplst) 4) 0)
  )
  (cons
   (inters
    (car tmplst)
    (cadr tmplst)
    (caddr tmplst)
    (cadddr tmplst)
    nil
   )
   (PPT:2D->StEnd (cddr tmplst))
  )
 )
)

(append
 (list (car lst))
 (PPT:2D->StEnd lst)
 (list (last lst))
)
__________________
Автоматизация должна быть автоматической.

Последний раз редактировалось ProPeller, 02.11.2015 в 14:49.
ProPeller вне форума  
 
Непрочитано 02.11.2015, 14:38
#2797
Pavel_GP

Инженер-гидрограф
 
Регистрация: 15.09.2011
г.г. Ленинград
Сообщений: 170


Что-то нето...
С твоего позволения добавил скобку
(append
(list (car lst))
(PPT:2D->StEnd lst)
(list (last lst))
)

Пример: lst ((3.72449e+006 3.00249e+006) (3.72356e+006 3.00125e+006) (3.72355e+006 3.00131e+006) (3.72475e+006 3.00041e+006) (3.72476e+006 3.00035e+006) (3.72313e+006 2.99882e+006))
на выходе получаем: ((3.72449e+006 3.00249e+006) (3.72313e+006 2.99882e+006)), должно быть четыре точки, а тут две начало и конец
__________________
AutoCAD Civil 3D 2012г. 32-разрядная.
Pavel_GP вне форума  
 
Непрочитано 02.11.2015, 15:02
#2798
ProPeller

Пастух
 
Регистрация: 16.07.2012
Питер
Сообщений: 318


Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
Что-то нето...
С твоего позволения добавил скобку
(append
(list (car lst))
(PPT:2D->StEnd lst)
(list (last lst))
)

Пример: lst ((3.72449e+006 3.00249e+006) (3.72356e+006 3.00125e+006) (3.72355e+006 3.00131e+006) (3.72475e+006 3.00041e+006) (3.72476e+006 3.00035e+006) (3.72313e+006 2.99882e+006))
на выходе получаем: ((3.72449e+006 3.00249e+006) (3.72313e+006 2.99882e+006)), должно быть четыре точки, а тут две начало и конец
Изменил условие рекурсии. Должно работать.

Код:
[Выделить все]
 (defun PPT:2D->StEnd (tmplst)
 (if
  (and
   tmplst
   (<= 4 (VL-LIST-LENGTH tmplst))
  )
  (cons
   (inters
    (car tmplst)
    (cadr tmplst)
    (caddr tmplst)
    (cadddr tmplst)
    nil
   )
   (PPT:2D->StEnd (cddr tmplst))
  )
 )
)

(append
 (list (car lst))
 (PPT:2D->StEnd lst)
 (list (last lst))
)
__________________
Автоматизация должна быть автоматической.
ProPeller вне форума  
 
Непрочитано 02.11.2015, 15:38
#2799
Pavel_GP

Инженер-гидрограф
 
Регистрация: 15.09.2011
г.г. Ленинград
Сообщений: 170


Спс. Большое. Всё работает!

Есть решение моего вопроса, мы все кто смог помочь его решили
Код:
[Выделить все]
;;; Аналог off_set только для проекции Меркатора
;;; Большая отдельная благодарность Кулик Алексей akka_KPbIC, ProPeller http://forum.dwg.ru
(defun C:PPM (/	     dtr    ao	   bo	  f_ps	 fg	e1     e1_2
	      e2     e2_2   s	   sfg2	  ko	 pt	xi     tt
	      azimut_s	    Az	   *cdl_actvdoc* LWPoly	vertex x1
	      x2     ugol1  ugol2  obj	  ent	 OSM	k      y_pt
	      y1     y2	    az_s   az0	  xy_v	 coords	pts
	     )
  (setq OSM (getvar "OSMODE"))		;запоминаем значение объективной привязки
  (setvar "OSMODE" 0)			;выключаем объективную привязку
  (vl-load-com)
;;; Настраиваем систему координат WGS84
;;; Вспомогательные функции
  (defun dtr (a) (* pi (/ a 180.)))
  (defun deg (r) (/ (* r 180.) pi))

;;; -----------------параметры эллипсоида WGS84----------------------
  (setq	ao   6378137.			;большая полуось
	bo   6356752.3142		;малая полуось
	f_ps (/ 1. 298.25722356)	;первое сжатие
	e1   0.0818191909289067		;первый эксцентриситет
	e1_2 (sqrt (/ (- (expt ao 2.) (expt bo 2.)) (expt bo 2.)))
					;второй эксцентриситет
	e2_2 (expt e1_2 2.)
	e2   (* f_ps (- 2. f_ps))
  )
  (setq fg (getreal "\n Введите главную параллель, xx.xxx°: "))
  (setq fg (dtr fg))			;перевод градусов в радианы
  (setq s (getdist "\n Укажите расстояние смещения, метры:"))
  (setq sfg2 (expt (sin fg) 2.))
  (setq	ko (/ (cos
		fg
	      ) ;_end of cos
	      (expt (- 1. (* e2 sfg2)) 0.5)
	   ) ;_end of /
  ) ;_end of setq ko

  (if (setq obj (entsel "\n Выбрать полилинию : ")) ;|<Имя объекта:|;
    (progn
      (if (and (= (type	(setq ent (vl-catch-all-apply ;|#<VLA-OBJECT|;
				    (function
				      (lambda ()
					(car obj)
				      ) ;_ end of LAMBDA
				    ) ;_ end of function
				  ) ;_ end of VL-CATCH-ALL-APPLY
			) ;_ end of setq ent
		  ) ;_ end of type
		  'ename
	       ) ;_ end of =
	       (setq ent (vlax-ename->vla-object ent))
	       (= (vla-get-objectname ent) "AcDbPolyline")
	  ) ;_ end of and
	(progn
	  (setq	pt
		 (getpoint "\n Уажите точку, определяющую сторону смещения"
		 )
	  ) ;_end setq pt
	  (setvar "OSMODE" OSM)		;включаем объективную привязку
;;;получение списка координат вершин полилинии
	  (setq
	    xy (mapcar 'cdr
		       (vl-remove-if-not
			 '(lambda (x) (= (car x) 10))
			 (entget (car obj))
		       ) ;_end vl-remove-if-not
	       ) ;_end of mapcar
	  ) ;_end of setq xy
	  (setq
	    xy_v (reverse
		   (cdr	(reverse
			  (cdr (apply 'append (mapcar 'list xy xy)))
			) ;_end of reverse
		   ) ;_end of cdr
		 ) ;_end of reverse
	  ) ;_end of setq xy_v

;;; записываем азимуты

	  (setq	ugol1 (angle (car xy_v) pt) ;вспомогательные величины
		ugol2 (angle (car xy_v) (cadr xy_v))
					;для определения			
		x1    (caar xy_v)	;стороны смещения
		x2    (caadr xy_v)
		y_pt  (cadr pt)
		y1    (cadar xy_v)
		y2    (cadadr xy_v)
	  ) ;_end of setq(s)
	  (cond	((and (= y1 y2) (= ugol2 0) (< y_pt y1))
		 (setq k pi)
		)
		((and (= y1 y2) (> ugol2 ugol1))
		 (setq k pi)
		)
		((and (= y1 y2) (< ugol2 ugol1))
		 (setq k (* 2. pi))
		)
		((and (= x1 x2) (> ugol2 ugol1))
		 (setq k pi)
		)
		((and (= x1 x2) (< ugol2 ugol1))
		 (setq k (* 2. pi))
		)
		((and (< x1 x2) (> y_pt y1) (> ugol2 ugol1) (< y1 y2))
		 (setq k pi)
		)
		((and (< x1 x2) (> y_pt y1) (> ugol2 ugol1))
		 (setq k (* 2. pi))
		)
		((and (< x1 x2) (< y1 y2) (< ugol2 ugol1) (< y_pt y1))
		 (setq k pi)
		)
		((and (> ugol2 ugol1) (< x1 x2))
		 (setq k pi)
		)
		((and (< ugol2 ugol1) (< x1 x2))
		 (setq k (* 2. pi))
		)
		((and (> ugol2 ugol1) (> x1 x2))
		 (setq k pi)
		)
		((and (< ugol2 ugol1) (> x1 x2))
		 (setq k (* 2. pi))
		)
	  ) ;_end of cond
	  
	  (setq
	    az_s (mapcar '(lambda (l1 l2) (- k (angle l1 l2)))
			 (reverse (cdr (reverse xy)))
			 (cdr xy)
		 ) ;_end of mapcar
	    az0	 (apply 'append (mapcar 'list az_s az_s)) ;список Азимутов
	  )

;;; получаем новый список координат вершин
	  (setq n 0)
	  (foreach vertex xy_v
	    (setq Az (nth n az0))
	    (defun eval-new-coords (x	  y	/     mo    f_r	  l_r
				    nym2  c	Nm    Mm    betta gamma
				    alfa  b	w     fnew_r	  lnew_r
				    x0	  y0	tan   xy_new
				   )
	      (setq mo (- (/ pi 2.)
			  (* 2.
			     (atan (exp	(/ (* -1. y) (* ao ko))
				   ) ;_end of exp
			     ) ;_end of atan
			  ) ;_end of *
		       ) ;_end of -
	      ) ;_end of setq mo
;;; преобразование прямоугольных в географические координаты
	      (setq f_r
		     (+	(+ (+ (+ mo
				 (* (sin (* 2. mo))
				    (+ (+ (+ (/ (expt e1 2.) 2.)
					     (* 5. (/ (expt e1 4.) 24.))
					  ) ;_end of +
					  (/ (expt e1 6.) 12.)
				       ) ;_end of +
				       (* 13. (/ (expt e1 8.) 360.))
				    ) ;_end of +
				 ) ;_end of *
			      ) ;_end of +
			      (* (sin (* 4. mo))
				 (+ (+ (* 7. (/ (expt e1 4.) 48.))
				       (* 29. (/ (expt e1 6.) 240.))
				    ) ;_end of +
				    (* 811. (/ (expt e1 8.) 11520.))
				 ) ;_end of +
			      ) ;_end of *
			   ) ;_end of +
			   (* (sin (* 6. mo))
			      (+ (* 7. (/ (expt e1 6.) 120.))
				 (* 81. (/ (expt e1 8.) 1120.))
			      ) ;_end of +
			   ) ;_end of *
			) ;_end of +
			(* (sin (* 8. mo))
			   (* 4279. (/ (expt e1 8.) 161280.))
			) ;_end of *
		     ) ;_end of +
	      ) ;_end of setq f_r
	      (setq f_r	  (abs f_r)	; широта в радианах
		    l_r	  (/ x (* ao ko))
		    l_r	  (abs l_r)	; долгота в радианах
;;; вычисление новых координат вершин

;;; **************************************************************
		    nym2  (* e2_2 (expt (cos f_r) 2.))
		    c	  (* bo (+ 1. e2_2))
		    Nm	  (/ c (sqrt (+ 1. nym2)))
		    Mm	  (/ Nm (+ 1. nym2))
		    betta (/ (* s (cos Az)) Mm)
		    gamma (/ (* s (sin Az)) (* Nm (cos f_r)))
		    alfa  (sin f_r)
		    b	  (* betta (1+ (/ (+ (* 2. (expt gamma 2.))) 24.)))
	      ) ;_end of setq(s)
	      (setq
		w (* gamma
		     (1+ (/ (- (expt alfa 2.) (expt betta 2.)) 24.))
		  ) ;_end of *
	      ) ;_end of setq w
	      (setq fnew_r (+ f_r b))	;широта новой вершины
	      (setq lnew_r (+ l_r w))	;долгота новой вершины

;;; **************************************************************		  

	      (setq x0 (* (* ao ko) lnew_r))
	      (setq tan	(/ (sin (+ (/ pi 4.) (/ fnew_r 2.)))
			   (cos (+ (/ pi 4.) (/ fnew_r 2.)))
			) ;_end of /
	      ) ;_end of setq tan
	      (setq y0 (* (* ao ko)
			  (log (* tan
				  (expt	(/ (- 1. (* e1 (sin fnew_r)))
					   (+ 1. (* e1 (sin fnew_r)))
					) ;_end of /
					(/ e1 2.)
				  ) ;_end of expt
			       ) ;_end of *
			  ) ;_end of expt
		       ) ;_end of *
	      ) ;_end of setq y0
	      (setq xy_new (list x0 y0)); список прямоугольных координат новой вершины
	    ) ;_end of defun eval-new-coords
;;; список прямоугольных координат новых вершин
	    (setq coords
		   (cons (eval-new-coords (car vertex) (cadr vertex))
			 coords
		   ) ;_end of cons
	    ) ;_end of setq coords
	    (setq n (1+ n))
	  ) ;_end of foreach

	  (defun PPT:2D->StEnd (tmplst)
	    (if
	      (and
		tmplst
		(<= 4 (VL-LIST-LENGTH tmplst))
	      ) ;_end of and
	       (cons
		 (inters
		   (car tmplst)
		   (cadr tmplst)
		   (caddr tmplst)
		   (cadddr tmplst)
		   nil
		 ) ;_end of inters
		 (PPT:2D->StEnd (cddr tmplst))
	       ) ;_end of cons
	    ) ;_end of if
	  ) ;_end defun PPT:2D->StEnd

	  (setq	pts (append
		      (list (car coords))
		      (PPT:2D->StEnd coords)
		      (list (last coords))
		    ) ;_end append
	  ) ;_end of pts

	  (setq	*cdl_actvdoc*
		 (vla-get-ActiveDocument
		   (vlax-get-acad-object)
		 ) ;_end of vla-get-ActiveDocument
	  ) ;_end of setq *cdl_actvdoc*
;;; Строим полилинию по новым вершинам
	  (defun LWPoly	(pts / templst entg)
	    (vla-AddLightWeightPolyline
	      (vla-get-Block (vla-get-ActiveLayout *cdl_actvdoc*))
	      (vlax-safearray-fill
		(vlax-make-safearray
		  vlax-vbDouble
		  (vl-list* 0
			    (1-	(length	(setq templst
					       (apply
						 'append
						 (mapcar
						   (function
						     (lambda (x)
						       (cond
							 ((= 3 (length x))
							  (reverse (cdr (reverse x)))
							 )
							 (T x)
						       ) ;_end of cond
						     ) ;_end of lambda
						   ) ;_end of function
						   pts
						 ) ;_end of mapcar
					       ) ;_end of apply
					) ;_end of setq templst
				) ;_end of length
			    ) ;_end of 1-
		  ) ;_end of vl-list*
		) ;_end of vlax-make-safearray
		templst
	      ) ;_end of vlax-safearray-fill
	    ) ;_end of vla-AddLightWeightPolyline
	    (setq entg (entget (entlast)))
	    (entmod (append entg (list (cons 370 30) (cons 62 1))))
	  ) ;_end of defun LWPoly
	  (LWPoly pts)
	) ;_end of progn
	(princ "\n Это не тип полилинии.")
      ) ;_end of if
    ) ;_end of progn
    (princ "\n Объект не выбран.")
  ) ;_end of if
  (princ)
  (gc)
) ;_end of defun C:PPM


Это аналог функции оффсет только для моих условий.
Что можешь посоветовать по решению такой вот проблемки:
Когда я выбираю сторону отложения новой полилинии мне приходится прописать ряд функций (начиная со строки (setq ugol1...), на мой взгляд это не правильно мне кажеться что-то должно быть чтоб автокад понимал где право а где лево.
Код:
[Выделить все]
 (setq	ugol1 (angle (car xy_v) pt) ;вспомогательные величины
		ugol2 (angle (car xy_v) (cadr xy_v))
					;для определения			
		x1    (caar xy_v)	;стороны смещения
		x2    (caadr xy_v)
		y_pt  (cadr pt)
		y1    (cadar xy_v)
		y2    (cadadr xy_v)
	  ) ;_end of setq(s)
	  (cond	((and (= y1 y2) (= ugol2 0) (< y_pt y1))
		 (setq k pi)
		)
		((and (= y1 y2) (> ugol2 ugol1))
		 (setq k pi)
		)
		((and (= y1 y2) (< ugol2 ugol1))
		 (setq k (* 2. pi))
		)
		((and (= x1 x2) (> ugol2 ugol1))
		 (setq k pi)
		)
		((and (= x1 x2) (< ugol2 ugol1))
		 (setq k (* 2. pi))
		)
		((and (< x1 x2) (> y_pt y1) (> ugol2 ugol1) (< y1 y2))
		 (setq k pi)
		)
		((and (< x1 x2) (> y_pt y1) (> ugol2 ugol1))
		 (setq k (* 2. pi))
		)
		((and (< x1 x2) (< y1 y2) (< ugol2 ugol1) (< y_pt y1))
		 (setq k pi)
		)
		((and (> ugol2 ugol1) (< x1 x2))
		 (setq k pi)
		)
		((and (< ugol2 ugol1) (< x1 x2))
		 (setq k (* 2. pi))
		)
		((and (> ugol2 ugol1) (> x1 x2))
		 (setq k pi)
		)
		((and (< ugol2 ugol1) (> x1 x2))
		 (setq k (* 2. pi))
		)
	  ) ;_end of cond
__________________
AutoCAD Civil 3D 2012г. 32-разрядная.
Pavel_GP вне форума  
 
Непрочитано 02.11.2015, 16:18
#2800
ProPeller

Пастух
 
Регистрация: 16.07.2012
Питер
Сообщений: 318


Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
Есть решение моего вопроса, мы все кто смог помочь его решили
Рекомендую описание функции PPT:2D->StEnd переместить из цикла по списку (foreach), например в начало описания программы, где у тебя комментарий ;;; Вспомогательные функции, иначе функция будет переопределяться столько раз, сколько элементов у тебя будет в списке.

Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
мне приходится прописать ряд функций
Не очень понятно, что у тебя и откуда. Нужно рассматривать на реальном примере. Что касается твоего примера, то тут нужна оптимизация и что-то мне подсказывает, что есть некторое количество неучтённых вариантов определения сторонности которые приведут к ошибке.
Если мы на сто процентов уверены, что существует только лишь два варианта k, то я бы начал с этого, а потом стал бы думать дальше.
Код:
[Выделить все]
 (setq
 ugol1 (angle (car xy_v) pt) 
 ugol2 (angle (car xy_v) (cadr xy_v)) 		
 x1    (caar xy_v) 
 x2    (caadr xy_v)
 y_pt  (cadr pt)
 y1    (cadar xy_v)
 y2    (cadadr xy_v)
 k     (if
	(or
	 (and (= y1 y2) (= ugol2 0) (< y_pt y1))
	 (and (= y1 y2) (> ugol2 ugol1))
	 (and (= x1 x2) (> ugol2 ugol1))
	 (and (< x1 x2) (> y_pt y1) (> ugol2 ugol1) (< y1 y2))
	 (and (< x1 x2) (< y1 y2) (< ugol2 ugol1) (< y_pt y1))
	 (and (> ugol2 ugol1) (< x1 x2))
	 (and (> ugol2 ugol1) (> x1 x2))
	)
	pi
	(* 2 pi)
       )
)
Цитата:
Сообщение от Pavel_GP Посмотреть сообщение
на мой взгляд это не правильно мне кажеться что-то должно быть чтоб автокад понимал где право а где лево.
Нет, он не способен это определить. Понятие лево и право субъективно, а соответственно неконкретно. Как говорится "Смотря, как смотреть."
__________________
Автоматизация должна быть автоматической.

Последний раз редактировалось ProPeller, 02.11.2015 в 16:26.
ProPeller вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Научите лиспу на примере (или как kpblc, VVA и компания пытаются обучить чайника лиспу)

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
LISP. Вставка в таблицу поля, соотвествующего площади примитива Profan Готовые программы 272 06.06.2021 23:12
Сейсмозащита и сейсмоизоляция существующих, построенных зд. IANationalInformAgentstvo Прочее. Архитектура и строительство 216 20.01.2015 16:51
Мониторы LCD CRT Разное 94 17.06.2008 10:51
ЮМОР 2006 =) Perezz!! Разное 1122 04.01.2007 00:46