;;; 
;;; Отрисовка сигары с генерацией разверток и всопомгательных
;;; элементов для склейки
;;;
;;; (С) В.Водолазкий   http://come.to/vodolaz,   2002
;;;


(load "3d.lsp")

;; ------------------------------ Демонстрационный пример профиля
;;                                Чтобы не вводить его вручную
;;
;; Это макет прямоточного реактивного двигателя
;; самолета-снаряда серии Fi-103 (он же - Фау-1)
;;
;; первое число - диаметр окружности-сечения, второе - смещение
;; третий элемент массива - номер детали
;;
;; размеры - условные: снятые с чертежа снаряда в книге "Самолеты Германии"
;;
(setq example '((11.0 0.0 "С1") (16.0 4.0 "С2") (16.0 31.0 "С3") (12.0 56.0 "С4")
                (10.5 107.0 "С5")
	)
)

;; а также фюзеляж Фау-1
(setq fau-1   '( (1.0 0 "F1") (3.0 6.0 "F2") (8.0 11.0 "F3") (14.0 18.0 "F4")
		 (19.0 30.0 "F5") (22.0 44.0 "F6") (24.0 59.0 "F7") (24.0 91.0 "F8")
		 (23.0 113.0 "F9") (21.0 136.5 "F10") (16.0 166.5 "F12") (11.0 188.5 "F13")
		 (1.0 212.5 "F14")
		)
      )

(setq fab250 '( (1.0 0 "F1")
	        (20.0 27.5 "F2")
	        (20.0 72.0 "F3")
	        (15.5 87.2 "F4")
	        (5.0 98.0 "F5")
	       )
      )


;; Головная часть ракеты ЗРК "КУБ"
(setq kub-konus '(  (0.7 0 "F1") (7.5 19 "F2") (7.5 23.5 "F3")
	      (9.5 33.0 "F4")
	    )
      )

;; Фюзеляж ракеты комплекса "КУБ"
(setq kub-korpus '( (12.5 0 "K1") (13.0 3.5 "K2")
		    ( 14.5 11.0 "K4") (14.5 93.0 "K5") ( 14.5 128.0 "K6")
		   )
      )
;;; расчет реальных размеров под заданный масштаб
;;; исходим из того, что нам известен реальный размер выхлопа двигателя,
;;; который равен 400 мм

(setq scale 32)            ; масштаб Model-Art
;; в переменную mnozh мы поместим число, на которое нужно умножить каждый размер,
;; чтобы получить реальные величины в заданном масштабе
;(setq mnozh (/ 400.0 (* scale (car (last example)))))
(setq mnozh (/ 487.39  29.0))

(print "Множитель - ") (prin1 mnozh)(terpri)

;; отступ клапана в мм от самой детали
(setq zazor 5.0)
;; ширина полосы проклейки
(setq polosa 2.0)
;; толщина бумаги в мм
 (setq bumaga 0.2)


;; отрисовка окружности с заданным центром 
;; и диаметром, а также осями

(defun draw_circle ( center rad)
  ;; учитываем поправочный коэффициент
  (setq rad (* mnozh rad))
  ;; принудительно устанавливаем рабочий слой
  (command "_layer" "S" "detail" "")
  (setq r (/ rad 2))
  (command "_circle" center  r)
  (setq x1 (car center)) (setq y (cadr center))
  (setq z (caddr center))
  (setq l (list (- x1 r 2) y z))
  (setq n (list x1 (+ y r 2) z))
  (setq rr (list (+ x1 r 2) y z)) 
  (setq s (list x1 (- y r 2) z))
  (command "_layer" "S" "center" "")
  (command "_line" l rr "" "_line" n s "")
)


;; создание слоев для качественного отображения

(defun create_layers ()
  (command "_layer" "N" "detail" "C" "blue" "detail" "L" "continuous" "detail" "LW" "0.05" "detail" "")
  (command "_layer" "N" "center" "C" "green" "center" "L" "center" "center" "")
  (command "_layer" "N" "text" "C" "blue" "text" "L" "continuous" "text" "")

;; теперь включаем режим отображения, комфортный для работы

;  (command "_limits" "0,0" "420,297")
;  (command "_grid" "5")
;  (command "_snap" "0.1")
  ;; отрисовка рамки
  (command "_line" "20,5" "290,5" "290,205" "20,205" "_C" "")
  )


;; ввод данных о сечении сигары

(defun get_cross ()
 (setq a (getreal "Введите диаметр сечения: "))
 (setq b (getreal "Введите смещение от базовой точки: "))
 (setq c (getstring "Введите обозначение сечения: ")) 
 (list a b c)
)


;;
;;Отрисовка профиля по данным из собранного списка параметров 
(defun draw_profile  ( p )
  (setq start (getpoint "Обозначьте точку начала отрисовки профиля : "))
  (setq y (cadr start)) ; текущая вертикаль
  (setq z (caddr start)); текущий слой
  ;; теперь определяем зону отрисовки. Определяющим для нас является
  ;; размещение оси симметрии
  (setq xx1 (* mnozh (cadr (last p))))
  (setq xx2 (* mnozh (cadr (car p))))
  (setq end (list 
            (+ (- xx1 xx2) (car start))
               y z
             ))
  (princ "Start - ")(prin1 start)(terpri)
  (princ "End   - ")(prin1 end)(terpri)
    (command "_layer" "S" "center" "")
    (command "_line" start end "")
  ;; теперь отрисовываем профили
  ;; (car x) - диаметр  (cadr x) - положение
  (mapcar (function ( lambda (x)
;;		      (princ "x = ")(prin1 x)(terpri)
            ;; перестройка координат		      
            (setq xxx (list (* mnozh (car x))
			    (* mnozh (cadr x))
			    (caddr x)))
            (setq dy (/ (car xxx) 2))         		      
	   (setq from (list (+ (car start) (cadr xxx)) (- y dy) z))
	   (setq to    (list (car from) (+ y dy) z))
;;         (prin1 from)(princ " - ")(prin1 to)(terpri)
   	   (command "_layer" "S" "detail" "")
           (command "_line" from to "")
;; отрисовка номеров профилей на сборке
           (setq xx (list (+ (car from) 2) (+ y 1.5) z))
           (command "_layer" "S" "text" "")
           (command "_text" xx "1.5" "0" (caddr xxx))		      
	    ))
	 p)
  ;; Отрисовка верхней и нижней полос профиля
     	   (command "_layer" "S" "detail" "")
  (setq st (list (car start) (+ (cadr start) (/ (* mnozh (cadr (car p))) 2)) z))
  (command "_line" st st "")
  ;; начальная точка сформирована, теперь прогогняем верхнюю грань
  (mapcar (function (lambda (x)
	  (setq dy (/ (* mnozh (car x)) 2))	      
          (setq to (list (+ (car start) (* mnozh (cadr x))) (- y dy) z))
          (command "_line" "@" to "")		      

		      )) p)
  (command "_line" st st "")
  ;; начальная точка сформирована, теперь прогогняем верхнюю грань
  (mapcar (function (lambda (x)
	  (setq dy (/ (* mnozh (car x)) 2))	      
          (setq to (list (+ (car start) (* mnozh (cadr x))) (+ y dy) z))
          (command "_line" "@" to "")		      

		      )) p)

  ) ; конец определения

(defun dialog_collect ()
;; Собираем список для отрисовки
(setq profile '())
(while 
   (not (equal (car (setq prof (get_cross))) 0
    )   )
 ;  (prin1 prof)(terpri)     
   (setq profile (append profile (list prof)))
 ;  (prin1 profile)(terpri)
 profile
  ) ; while
)

;;; ------------------- Отрисовка сечений с вводом координат


(defun plot_circles (p)

  (mapcar (function (lambda (xxx)
            (setq c (getpoint "Введите координаты сечения "))
            (draw_circle c (car xxx))		      
            ;; теперь выводим подпись под сечением
		(setq dy (/ (car xxx) 2)) (prin1 dy)  
		(setq xx (cadr c))
		(setq yy  (- xx 3 dy))
		     
            (setq podpis (list (car c) yy (caddr c)))
            (command "_layer" "S" "text" "")
            (command "_text" podpis "1.5" "0" (caddr xxx)) 		      
		      )) p)
  )

;;; функция смещения заданной точки по Иксам
;;; возвращает координаты новой точки
(defun xplus (arg shift)
  (list (+ (car arg) shift)
	 (cadr arg)
	 (caddr arg)
	 )
    )

(defun xminus (arg shift)
   (cons (- (car arg) shift)
	 (cdr arg)
	 )
  )

(defun yminus (arg shift)
    (list (car arg) (- (cadr arg) shift) (caddr arg))
  )

;;; и аналогичная по игрекам
(defun yplus (arg sh)
   (list (car arg)
	 (+ (cadr arg) sh)
	 (caddr arg)
	 )
  )

;; смещение координат точки по Х и У
(defun xyplus (arg sh sh2)
  (yplus (xplus arg sh) sh2)
  )


;;; отрисовка развертки цилиндра

(defun plot_cylinder (start c1 c2)
   ;; вначале вычисляем размеры
  (setq height (* mnozh (- (cadr c2) (cadr c1)))) ; высота сегмента
  (setq width  (* mnozh pi (car c1)))
;  (princ "высота цилиндра -  ")(prin1 height)(terpri)
;  (princ "ширина развертки - ")(prin1 width)(terpri)

  (setq p2 (list (+ (car start) height) (cadr start) (caddr start)))
  (setq p3 (list (car p2) (+ (cadr start) width) (caddr start)))
  (setq p4 (list (car start) (cadr p3) (caddr start)))
  (command "_layer" "S" "detail" "")
  (command "_line"  start p2 p3 p4 "C" "")
  ;; теперь отрисовываем маленькие меточки на осях симметрии
  (setq p5 (list (car start) (+ (cadr start) (/ width 2)) (caddr start)))
  (setq p51 (list (+ (car p5) 1) (cadr p5) (caddr p5)))
  (setq p6 (list (car p2) (+ (cadr p2) (/ width 2)) (caddr start)))
  (setq p61 (list (- (car p6) 1) (cadr p6) (caddr p5)))
  (command "_layer" "S" "center" "")
  (command "_line"  p5 p51 "") (command "_line" p6 p61 "")
  ;; подписываем сечения
  (command "_layer" "S" "text" "")
  (command "_text" p2 "1.5" "0" (caddr c2))
  (command "_text" p4 "1.5" "0" (caddr c1))
  ;; СЛЕДУЮЩИЙ ЭТАП  - отрисовка соединительного клапана
  ;; должен выводиться параллельно длинной стороне на расстоянии 0.5 см снизу
  (setq klapan1 (yminus start  zazor))
  (setq klapan2 (yminus p2  zazor))
	
  (setq polosa1 (yminus klapan1 polosa)) 
  (setq polosa2 (yminus klapan2 polosa ))

   (setq klapan3 (yminus polosa1 polosa))
  (setq klapan4 (yminus polosa2 polosa))

  (princ "Клапан  - ")(prin1 klapan1)(princ " ")(prin1 klapan4)(terpri)
  (princ "Полоска - ")(prin1 polosa1)(princ " ")(prin1 polosa2)(terpri)
  
 (command "_layer" "_S" "center" "")
 (command "_line" polosa1 polosa2 "")
 
 (command "_layer" "_S" "detail" "")
  (command "_line" klapan1 klapan3 klapan4 klapan2 "_C" "" )
  
  
  )

;;; и срезанного конуса

(defun plot_cone  (start c1 c2)
  (prin1 c1)(princ " - ")(prin1 c2)(terpri)
  ;; построение идет слева направо
  (setq height (* mnozh (- (cadr c2) (cadr c1))))
  (princ "Высота сегмента - ")(prin1 height)(terpri)
  (if (> (car c1) (car c2))
    (progn
          (setq tmp c1) (setq c1 c2)
          (setq c2 tmp)
      ))
  ;; выделяем диаметры
  (setq d1  (* mnozh (car c1)))
  (setq d2  (* mnozh (car c2)))
   ;;  рассчитываем параметры развертки
    (setq p1 (- d2 d1)) (setq p2 (* p1 p1))
    (setq koren (sqrt (+ (* 4 height height)
			 p2)))
    (setq rs (/ (* d1 koren)
		(* 2 p1)))
    (setq rb (/ (* d2 koren)
		(* 2 p1)))
    (setq alpha (/ (* 2 pi p1)
		   koren))
  (princ "внутренний радиус - ")(prin1 rs)(terpri)
  (princ "внешний радиус    - ")(prin1 rb)(terpri)
  (princ "угол раскрыва     - ")(prin1 alpha)(terpri)
   ;; параметры определены, осталось построить развертку
   ;; это две прямые и две дуги
   ;;
   ;; предже всего, определим координаты вершины 
  (setq dx (* rb (sin (/ alpha 2))))
  (setq dy (* rb (cos (/ alpha 2))))
  (setq verh (list (+ (car start) dx) (+ (cadr start) dy) (caddr start)))
  ;; теперь рассчитаем координаты опорных точек
  ;; учтем, что првая из них намизвестна - это START - левый нижний угол
  (setq p4 (list (+ (car start) dx dx) (cadr start) (caddr start)))
  (setq p2 (list
	   (+ (car start) (- dx (* rs (sin (/ alpha 2)))))
	   (+ (cadr start) (- dy (* rs (cos (/ alpha 2)))))
	   (caddr start)
	 ))
  (setq p3 (list
	   (- (car p4) (- dx (* rs (sin (/ alpha 2)))))
           (cadr p2)
	   (caddr start)
	 ))
  ;; приступаем, наконец, к рисованию
  (command "_layer" "S" "detail" "")
  (command "_line" start p2 "")
  (command "_line" p3 p4 "")
  (command "_arc" "CE" verh p2 p3)
  (command "_arc" "CE" verh start p4)
  (command "_layer" "S" "text" "")
  (command "_text" p2 "1.5" "0" (caddr c1))
  (command "_text" p4 "1.5"  "0" (caddr c2))
  )


;;
;; Упрощенная версия развертки конуса
;;
(defun simple_cone  (start c1 c2)
  (prin1 c1)(princ " - ")(prin1 c2)(terpri)
  ;; построение идет слева направо
  (setq height (- (cadr c2) (cadr c1)))
  (princ "Высота сегмента - ")(prin1 height)(terpri)
  (if (> (car c1) (car c2))
    (progn
          (setq tmp c1) (setq c1 c2)
          (setq c2 tmp)
      ))
  ;; выделяем диаметры
  (setq d1 (/ (car c2) 2)) (setq d2 (/ (car c1) 2))
  (setq l1 (* d1 pi)) (setq l2 (* d2 pi))
  ;; приступаем, наконец, к рисованию
  (setq p1 (list (- (car start) l1) (+ (cadr start) height) (caddr start)))
  (setq p2 (list (+ (car start) l1) (+ (cadr start) height) (caddr start)))
  (setq p3 (list (- (car start) l2) (cadr start) (caddr start)))
  (setq p4 (list (+ (car start) l2) (cadr start) (caddr start)))

  (command "_layer" "_S" "detail" "")
  (command "_line" p1 p2 p4 p3 "C" "")
  (command "_layer" "_S" "text" "")
  (command "_text" p2 "1.5" "0" (caddr c1))
  (command "_text" p4 "1.5"  "0" (caddr c2))
  )


;;; Теперь вводим функцию, осуществляющую отрисовку проекции
;;; цилиндра или срезанного конуса в зависимости от значений
;;; верхнего и нижнего диаметра
;;;
;;;  c1 - параметры первого сегмента
;;;  с2 - параметры второго сегмента
;;;
(defun plot_segment (c1 c2)
   (setq start (getpoint "Введите место отрисовки сегмента"))
   (cond
        ((eq (car c1) (car c2))
              (plot_cylinder start c1 c2))
	(t
	      (plot_cone start c1 c2))
	 )
     
  )

;; Наконец: нам необходимо осуществить последовательную отрисовку всех
;; сегментов выбирая их из списка попарно
(defun all_segments (p)
 (setq l  (length p))
  ;; не особо размышляя формируем цикл
  (setq i 0)
  (while (< i l)
      (plot_segment (nth i p) (nth (+ i 1) p))
      (setq i (+ i 1))
    )
  )



;; Отрисовка трехмерного конуса, привязанного к базовой точке
;; base. После завершения отрисовки производится перенос базовой точки

(defun plot-3d-cone (base a b)
   (setq rad (/ (car a) 2))   ; начальный радиус
   (setq top (/ (car b) 2))   ; конечный радиус
   (setq height (- (cadr b) (cadr a)))      ; длина сегмента
   (setq numseg 48)   
   (setq elev (caddr base)) ; Z - начальной точки
   (setvar "SURFTAB1" numseg)

  ; Draw base circle
  (command "_.CIRCLE" base rad)
  (setq undoit T)
  (setq e1 (entlast))
  (setq cen2 (list (car base) (cadr base) (+ (caddr base) height)))
  (setq oldelev (getvar "ELEVATION"))
  (command "_.ELEV" (+ elev height) "")
  (cond 
    ; Draw top point or circle
    ((= top 0.0) (command "_.POINT" cen2))  
    (t (command "_.CIRCLE" cen2 top))
  )
  (setq e2 (entlast))
  (setvar "ELEVATION" oldelev)
  
  (prin1 e1)(terpri)(prin1 e2)(terpri)
  
  ; Draw cone
  (command "_.RULESURF" (list e1 base) (list e2 cen2))
  (entdel e1) 
  (entdel e2)
  ;; переносим базовую точку отрисовки
  (setq base (list (car base) (cadr base) (+ (caddr base) height)))
)



;;;
;;;  отрисовка трехмерного изображения сигары
;;;

(defun 3dcigara (a)
  ;; переходим в режим трехмерной отрисовки
  (setq base (getpoint "Точка начала отрисовки?"))
 
  (terpri)(princ "Есть! Приступаю к отрисовке")(terpri) 	
  (setq l (length a))
  (setq i 0)
  (while (< i (- l 1))
     (plot-3d-cone base (nth i a) (nth (+ i 1) a))
         (setq dlina (- (cadr (nth (+ i 1) a)) (cadr (nth i a))))
         (setq base (list (car base) (cadr base) (+ dlina (caddr base))))
     (setq i (+ i 1))
    )
  )


;; общая отрисовка профилей и разверток

(defun all_draw (a)
  
(create_layers)
 
 (draw_profile a)
 (plot_circles a)
(all_segments a)
(command "_zoom" "A")
)


;; генерация полосы обклейки с учетом диаметра обклеиваемой зоны и
;; толщины бумаги
;;
;;  diam - диаметр обклеиваемого цилиндра
;;  wid  - ширина полосы
;;  point - базовая точка, куда помещается изображение
;;


(defun obkleika (diam wid point/ l)
   (setq l (* pi (+ diam bumaga bumaga))) ; общая длина
   (command "_rectangle" point
	     (xyplus point wid l))
  )


;; расчет угла образующей кормы бомбы с формированием координат точки
;; пера стабилизатора, соответствующего вычисленной прямой
;;
;;  profile - список с профилем бомбы
;; tochka1  - начало пера стабилизатора
;; tochka2  - конец пера стабилизатора на осевой линии 

(defun bomba-ugol (profile tochka1 tochka2 / l dlina)
  (setq l (length profile))   ; определяем размер профиля
  (princ "Длина профиля ")(prin1 l)(princ " элементов")(terpri)
  (setq el1 (nth  (- l 1) profile))
  (princ "Последний элемент - ")(prin1 el1)(terpri)
  (setq el2 (nth  (- l 2) profile))
  (princ "Предпоследний элемент - ")(prin1 el2)(terpri)
  
  (setq rad1 (/ (car el2) 2)) ; радиус первого профиля
  (setq rad2 (/ (car el1) 2)) ; и второго
  (setq dlina (- (cadr el1)    ; длина сегмента
		 (cadr el2)
		 ))

  (setq drad (- rad1 rad2))    ; дельточка

   (princ "Длина сегмента - ")(prin1 dlina)(terpri)
   (princ "Возвышение       - ")(prin1 drad)(terpri)
    (setq ugol (angle '(0 0) (list dlina drad)))  ; а вот и уголок
    (princ "Расчитанный угол - ") (prin1 ugol)(terpri)
  
     ; теперь необходимо рассчитать координаты точки, которая выходит
     ; под данным углом из tochka1 и пересекается с прямой, параллельной
     ; оси Y и проходящей через tochka2. Для  этого формируем две промежуточные
     ; точки

  (princ "Угол посчитан")(terpri)
    (setq tochka22 (yminus tochka2 50.0))
    (setq tochka21 (xyplus tochka1 (* 50.0 (cos ugol)) (* 50.0 (sin ugol))))

  (princ " Точки сформированы")(terpri)
  (setq point (inters tochka1  tochka21  tochka2  tochka22  nil))
     ; а теперь отрисовываем отрезки
  (command "_line" tochka1 point tochka2 "")
)
  


(defun startup (/ dcl_id)
  (if (< (setq dcl_id (Load_dialog "bombardir/start.dcl")) 0)
                (princ "Не могу загрузить диалог")
		(exit))
  (prin1 dcl_id)(terpri)
  (if (not (new_dialog "bombardir" dcl_id)) (exit))
   (princ "2")
    (start_dialog)
    (unload_dialog dcl_id)
    (princ "Программа \"Бомбардир\"  запущена!")(terpri)
  
 )


; (startup)


; (3dcigara fab250)

(setq p1 (getpoint))
(setq p2 (getpoint))

(draw_profile fab250)

(bomba-ugol fab250 p1 p2)

;(command "_zoom" "A")