Полезные коды и авторские программы на Lisp

(progn
;***************
;;;; Анимация. *
;***************
;;; Движение Коловорота и Фона [осветление].
(defun rotateKoloMoveBackgraund (/ osmode nabor-kolo kolo center new-center
                                   start-angle new-angle
                                   nabor-background background point x y new-x
                                   nabor-stars stars
                                )
  ;; сброс установок
  (setvar "cmdecho" 0)
  (setq osmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  ;; начальный угол Kolovorot
  (setq start-angle 1.8685748)
  (repeat 57  ;70 - за правый край
    ;; набор слоя Kolovorot
    (setq nabor-kolo (ssget "_X" (list (cons 8 "Kolovorot")))
          kolo (entget (ssname nabor-kolo 0)))
    ;; поворот вокруг своей оси
    ;; код поворота 50
    (setq rotate (cdr (assoc 50 kolo))
          new-R (- rotate 0.15)
          kolo (subst (cons 50 new-R) (assoc 50 kolo) kolo))
    (entmod kolo)
    ;; поворот вокруг опорной точки
    ;; центр примитива
    (setq center (cdr (assoc 10 kolo))
          new-angle (- start-angle 0.0087)
          start-angle new-angle
          new-center (polar '(5.5 -15.7917 0.0) new-angle 17.041699)
          kolo (subst (cons 10 new-center) (assoc 10 kolo) kolo))
    (entmod kolo)
    ;; двигать фон
    ;; набор Background
    (setq nabor-background (ssget "_X" (list (cons 8 "Background")))
          background (entget (ssname nabor-background 0)))
    (setq point (assoc 10 background)
          x (cadr point)
          y (caddr point)
          new-x (+ x 0.13) ; shift parameter
          background (subst (list 10 new-x y 0.0) point background))
    (entmod background)
    ;; плавность хода
    (command "_.delay" 70)
  );repeat
  ;; возврат установок
  (setvar "OSMODE" osmode)
  (setvar "cmdecho" 1)
  (princ)
);(rotateKoloMoveBackgraund)
;**************************************************************************************
;;; Движение Облака и Дождя.
(defun moveCloudRain (/ osmode nabor-rain
                        drops-1 drops-2 drops-3 drops-4 drops-5 drops-6
                        coord-1 coord-2 coord-3 coord-4 coord-5 coord-6
                        nabor-cloud cloud point x y new-x
                     )
  ;; сброс установок
  (setvar "cmdecho" 0)
  (setq osmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  ;; повторения
  (repeat 82
    ;; набор слоя Rain
    (setq nabor-rain (ssget "_X" (list (cons 8 "Rain"))))
    (setq drops-1 (entget (ssname nabor-rain 0)))
    (setq drops-2 (entget (ssname nabor-rain 1)))
    (setq drops-3 (entget (ssname nabor-rain 2)))
    (setq drops-4 (entget (ssname nabor-rain 3)))
    (setq drops-5 (entget (ssname nabor-rain 4)))
    (setq drops-6 (entget (ssname nabor-rain 5)))
    ;; находим 1-ю, запоминаем
    (setq coord-1 (assoc 10 drops-1))
    ;; находим 2-ю запоминаем и меняем
    (setq coord-2 (assoc 10 drops-2))
    (setq drops-2 (subst coord-1 coord-2 drops-2))
    (entmod drops-2)
    (command "_.delay" 10)
    ;; находим 3-ю запоминаем и меняем
    (setq coord-3 (assoc 10 drops-3))
    (setq drops-3 (subst coord-2 coord-3 drops-3))
    (entmod drops-3)
    (command "_.delay" 10)
    ;; находим 4-ю запоминаем и меняем
    (setq coord-4 (assoc 10 drops-4))
    (setq drops-4 (subst coord-3 coord-4 drops-4))
    (entmod drops-4)
    (command "_.delay" 10)
    ;; находим 5-ю запоминаем и меняем
    (setq coord-5 (assoc 10 drops-5))
    (setq drops-5 (subst coord-4 coord-5 drops-5))
    (entmod drops-5)
    (command "_.delay" 10)
    ;; находим 6-ю запоминаем и меняем
    (setq coord-6 (assoc 10 drops-6))
    (setq drops-6 (subst coord-5 coord-6 drops-6))
    (entmod drops-6)
    (command "_.delay" 10)
    ;; меняем 1-ю
    (setq drops-1 (subst coord-6 coord-1 drops-1))
    (entmod drops-1)
    (command "_.delay" 10)
    ;; движение дождя
    (command "_.move" nabor-rain "" (list 0.0 0.0 0.0) (list 0.15 0.0 0.0))
    ;; движение облака
    ;; набор слоя Cloud
    (setq nabor-cloud (ssget "_X" (list (cons 8 "Cloud")))
          cloud (entget (ssname nabor-cloud 0)))
    (setq point (assoc 10 cloud)
          x (cadr point)
          y (caddr point)
          new-x (+ x 0.15) ; shift parameter
          cloud (subst (list 10 new-x y 0.0) point cloud))
    (entmod cloud)
    ;; мера времени движения
    (command "_.delay" 25)
  );repeat
  ;; возврат установок
  (setvar "OSMODE" osmode)
  (setvar "cmdecho" 1)
  (princ)
);(moveCloudRain)
;**************************************************************************************
(defun PythagorasTree (point-base point-dir color order / osmode cecolor order coeff nabor)
  ;*******************************
  ;;;; Фрактал. Дерево Пифагора. *
  ;*******************************
  ;-----------------------------------------------------------------
  ;;; Aux: drawBranch.
  ;;; Плоды дерева. Как только уровень равен 1.
  (defun Fruit (nabor-acc / count nabor-len elevens-acc)
    ;; достать все 11 точки
    (setq count 0
          nabor-len (sslength nabor-acc)
          elevens-acc nil)
    (repeat nabor-len
      (setq elevens-acc 
            (cons (car (mapcar '(lambda (x) (cdr x))
                                  (vl-remove-if '(lambda (x)
                               (/= (car x) 11)) (entget (ssname nabor-acc count)))))
                  elevens-acc))
      (setq count (1+ count)));repeat
    (mapcar '(lambda (x) 
               (entmake (list
                          '(0 . "INSERT")
                          '(100 . "AcDbEntity") '(67 . 0) '(410 . "Model")
                          '(8 . "Fruit")
                          '(100 . "AcDbBlockReference")
                          '(2 . "Fruit")
                          (cons 10 x)));entmake
             );lambda
            elevens-acc);mapcar
  );(Fruit nabor-acc)
  ;-----------------------------------------------------------------
  ;;; Aux: PythagorasTree.
  ;;; Отрисовка. Для каждого имеющегося отрезка дорисовать ещё два.
  (defun drawBranch (nabor coeff level 
                     / count  branch point-base dist Length ucsicon nabor-acc
                    )
    ;; набор для новых веток
    (setq nabor-acc (ssadd))
    ;; счетчик в цикле для набора
    (setq count 0)
    (repeat (sslength nabor)
      ;; данные из текущей ветки
      (setq branch (ssname nabor count)
            point-base (cdr (assoc 11 (entget branch)))
            dist (distance (cdr (assoc 10 (entget branch))) point-base)
            Length (* dist coeff))
      (command "_.ucs" "_ob" branch)
      ;; правая ветка
      (command "_.ucs" (list dist 0.0 0.0) "" "_.ucs" "_z" -30)
      (command "_.line" "0,0" (list Length 0.0 0.0) "")
      (ssadd (entlast) nabor-acc)
      ;; левая ветка
      (command "_.ucs" "_z" 75)
      (command "_.line" "0,0" (list Length 0.0 0.0) "")
      (ssadd (entlast) nabor-acc)
      ;; из текущего набора по счетчику
      (setq count (1+ count))
      (command "_.delay" 15)
    );repeat
    ;; условие выхода
    (if (not (= 1 level))
        (drawBranch nabor-acc coeff (1- level))
        (Fruit nabor-acc)))
  ;-----------------------------------------------------------------
  (setq coeff 0.7)
  ;; сброс установок
  (setvar "cmdecho" 0)
  (setq osmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq cecolor (getvar "CECOLOR"))
  (setvar "CECOLOR" color)
  ;; видимость пск
  (setq ucsicon (getvar 'ucsicon))
  (setvar 'ucsicon 2)
  ;; вес линий
  ;(setvar 'PLINEWID 1.0)
  ;; отрисовать ветку
  (setq nabor (ssadd)) 
  (command "_.line" point-base point-dir "")
  (ssadd (entlast) nabor)
  ;; отрисовка веток согласно порядку
  (drawBranch nabor coeff order)
  ;; возврат установок
  (command "_.ucs" "_w")
  (setvar "OSMODE" osmode)
  ;(setvar 'PLINEWID 0.0)
  (setvar "CECOLOR" cecolor)
  (setvar 'ucsicon ucsicon)
  (setvar "cmdecho" 1)
  (princ)
);(PythagorasTree '(7.3907 -3.67347 0.0) '(7.47394 -3.17699 0.0) "0,194,0" 9)
);progn
;**************************************************************************************
;;; Тест.
(progn
  (moveCloudRain)
  (command "_.delay" 10)
  (rotateKoloMoveBackgraund)
  (command "_.delay" 10)
  (PythagorasTree '(7.3907 -3.67347 0.0) '(7.47394 -3.17699 0.0) "0,194,0" 9)
  (command "_.delay" 10)
  (PythagorasTree '(5.03726 -3.60341 0.0) '(5.11556 -3.17285 0.0) "255,191,0" 8)
  (command "_.delay" 10)
  (PythagorasTree '(2.63735 -3.66797 0.0) '(2.57477 -3.20321 0.0) "214,0,214" 9)
)
;**************************************************************************************