;;; --------------------------------------------------------------------------- ;;; MorphFrames.lsp ;;; code compiled by YZ August 2026 ;;; --------------------------------------------------------------------------- ;;; TWEENED ANIMATION BETWEEN TWO LINE DRAWINGS ;;; ;;; PURPOSE ;;; Draw the same shape twice - once as it starts, once as it ends - on two ;;; different layers. This walks one into the other over as many frames as you ;;; ask for, snapping a slide at each step and writing a script that plays them ;;; back. Classic "tweening": you draw the two extremes and the machine draws ;;; everything in between. ;;; ;;; Useful for a door swinging, a mechanism travelling, a roof unfolding, or ;;; any before-and-after you want to show as movement rather than two pictures. ;;; ;;; HOW THE MATCHING WORKS ;;; Lines are paired in the order they were drawn: the first line on the start ;;; layer morphs into the first line on the end layer, the second into the ;;; second, and so on. So DRAW THEM IN THE SAME ORDER. The easiest way is to ;;; draw the start frame, copy the whole thing to the end layer, then edit the ;;; copy - the order is preserved by the copy. ;;; ;;; If the two layers hold different numbers of lines, the extras are ignored ;;; and you are told how many were dropped. ;;; ;;; HOW A FRAME IS POSITIONED ;;; Each frame is interpolated straight from the two extremes: ;;; ;;; p(f) = start + (end - start) * (f - 1) / (frames - 1) ;;; ;;; The original instead added a fixed delta to the current position each time ;;; round. That accumulates rounding error, and it wrote those deltas out to a ;;; scratch file on disk and read them back for every single frame - a 1987 ;;; memory saving that costs a great deal of disk work now. Interpolating from ;;; the ends is exact at both ends and needs no file. ;;; ;;; WHAT WAS FIXED ;;; - The error handler was written (setq *ERROR* (s) ...), which is not a ;;; function definition at all. It never ran, and any interruption left two ;;; files open and the drawing frozen on one layer. ;;; - The frame count was tested with (< FRAMENUM 2) before it was ever set, ;;; so the routine failed on the first line with a bad argument type. ;;; - It walked EVERY entity in the drawing and read group 10 and 11 from each, ;;; which on a circle or a piece of text means something entirely different. ;;; Only LINE objects are considered now. ;;; - It ran SAVE on every frame, writing a complete drawing file per frame ;;; under the slide name. That is gone. ;;; - It ended with (command "del" "DELTAXXX.XXX"), and there is no DEL command ;;; in AutoCAD. The scratch file it was trying to remove no longer exists. ;;; - It left the start-frame geometry sitting at the END position when it ;;; finished, with no way back. The lines are now put back where they began. ;;; ;;; MORPH - build a tweened animation between two layers ;;; --------------------------------------------------------------------------- ;;; --------------------------------------------------------------------------- ;;; SUPPORT ;;; --------------------------------------------------------------------------- ;;; Every LINE on a given layer, in the order the drawing holds them. Model ;;; space only - paper space geometry is not part of a slide of the model. (defun Morph:LinesOn ( layer / e d out ) (setq e (entnext)) (while e (setq d (entget e)) (if (and (= "LINE" (cdr (assoc 0 d))) (= (strcase layer) (strcase (cdr (assoc 8 d)))) (/= 1 (cdr (assoc 67 (append d '((67 . 0))))))) (setq out (cons e out))) (setq e (entnext e))) (reverse out) ) ;;; True if the named layer exists. (defun Morph:LayerExists ( name ) (and name (/= "" name) (tblsearch "LAYER" name))) ;;; Ask for a layer that holds at least one line, offering what is available. (defun Morph:AskLayer ( prompt / name ) (while (not (Morph:LayerExists name)) (setq name (getstring (strcat "\n" prompt ": "))) (cond ((= "" name) (setq name nil)) ((not (Morph:LayerExists name)) (princ (strcat "\n There is no layer called \"" name "\"."))))) name ) ;;; Move a line so its two ends sit at p1 and p2. (defun Morph:Place ( ent p1 p2 / d ) (setq d (entget ent)) (entmod (subst (cons 11 p2) (assoc 11 d) (subst (cons 10 p1) (assoc 10 d) d))) ) ;;; Linear interpolation between two points, f running 0.0 to 1.0. (defun Morph:Lerp ( a b f ) (list (+ (car a) (* f (- (car b) (car a)))) (+ (cadr a) (* f (- (cadr b) (cadr a)))) (+ (caddr a) (* f (- (caddr b) (caddr a))))) ) ;;; --------------------------------------------------------------------------- ;;; MAIN COMMAND ;;; --------------------------------------------------------------------------- (defun c:MORPH ( / *error* vars vals lay1 lay2 frames prefix script scr set1 set2 pairs n dropped f frac name maxpre path froze ) (setq vars '("CMDECHO" "BLIPMODE" "CLAYER") vals (mapcar 'getvar vars)) (defun Morph:Restore ( ) ;; Put every line back where it started, whatever happened. The list of ;; pairs carries the original coordinates, so this works even if the run ;; was interrupted half way through a frame. (if pairs (foreach p pairs (vl-catch-all-apply '(lambda ( ) (Morph:Place (car p) (cadr p) (caddr p))) '()))) (if scr (vl-catch-all-apply 'close (list scr))) (setq scr nil) (mapcar 'setvar vars vals) ;; Thaw only the layer this routine froze. A blanket thaw would undo the ;; user's own layer state, which is not ours to touch. (if froze (command "_.LAYER" "_Thaw" froze "")) (setq froze nil) (while (= 8 (logand 8 (getvar 'undoctl))) (command "_.UNDO" "_End")) (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '()) (redraw) (princ) ) (defun *error* ( msg ) (Morph:Restore) (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*"))) (princ (strcat "\n** MORPH error: " msg " **"))) (princ) ) (setvar "CMDECHO" 0) (setvar "BLIPMODE" 0) ;; AutoCAD 2015 and later refuse (command) inside an *error* handler unless ;; the routine says up front that it will use one. (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '()) (command "_.UNDO" "_Begin") (princ "\nTweened animation. Draw the start and end frames as lines on two") (princ "\nlayers, in the same order, then answer the questions.") (setq lay1 (Morph:AskLayer "Layer holding the START frame") lay2 (Morph:AskLayer "Layer holding the END frame")) (setq set1 (Morph:LinesOn lay1) set2 (Morph:LinesOn lay2) n (min (length set1) (length set2)) dropped (- (max (length set1) (length set2)) n)) (cond ((= lay1 lay2) (princ "\n** The start and end layers are the same. **")) ((zerop n) (princ (strcat "\n** No lines to work with - layer \"" (if (zerop (length set1)) lay1 lay2) "\" holds no LINE objects in model space. **"))) (t (if (> dropped 0) (princ (strcat "\n Note: the layers hold different numbers of" " lines. Using the first " (itoa n) " of each and ignoring " (itoa dropped) "."))) ;; --- how many frames ------------------------------------------- (initget 6) (setq frames (getint "\nHow many frames altogether <12>: ")) (if (null frames) (setq frames 12)) (if (< frames 2) (progn (princ "\n Two is the minimum - a start and an end.") (setq frames 2))) ;; --- names ----------------------------------------------------- ;; Slide names must leave room for the frame number on the end. (setq maxpre (- 8 (strlen (itoa frames)))) (while (null prefix) (setq prefix (getstring "\nName prefix for the slides: ")) (cond ((= "" prefix) (setq prefix nil)) ((> (strlen prefix) maxpre) (princ (strcat "\n " (itoa maxpre) " characters or fewer, to leave room for the" " frame number.")) (setq prefix nil)))) (while (null script) (setq script (getstring "\nName for the playback script: ")) (if (= "" script) (setq script nil))) (if (not (wcmatch (strcase script) "*`.SCR")) (setq script (strcat script ".scr"))) ;; --- record where every line starts and ends -------------------- ;; Each entry is (start-entity original-from original-to ;; target-from target-to). Holding the originals is ;; what lets the drawing be put back afterwards. (setq pairs nil) (repeat n (setq pairs (cons (list (car set1) (cdr (assoc 10 (entget (car set1)))) (cdr (assoc 11 (entget (car set1)))) (cdr (assoc 10 (entget (car set2)))) (cdr (assoc 11 (entget (car set2))))) pairs) set1 (cdr set1) set2 (cdr set2))) (setq pairs (reverse pairs)) ;; --- hide the end frame while the slides are taken --------------- ;; Only the end-frame layer is touched. Everything else stays as you ;; set it, so if you want a clean slide, freeze what you do not want ;; before running this. (setvar "CLAYER" lay1) (command "_.LAYER" "_Freeze" lay2 "") (setq froze lay2) ;; --- write the script and snap the slides ----------------------- (setq scr (open script "w")) (if (null scr) (princ (strcat "\n** Cannot write " script " - check the folder is writable. **")) (progn (write-line ";; Animation written by MORPH." scr) (write-line ";; Run it with SCRIPT, or drop it on the drawing." scr) (setq f 1) (while (<= f frames) (setq frac (/ (float (1- f)) (float (1- frames))) name (strcat prefix (itoa f))) ;; Position every line for this frame. (foreach p pairs (Morph:Place (car p) (Morph:Lerp (cadr p) (cadddr p) frac) (Morph:Lerp (caddr p) (nth 4 p) frac))) (command "_.MSLIDE" name) (write-line (strcat "VSLIDE " name) scr) (write-line "DELAY 125" scr) (princ (strcat "\r Frame " (itoa f) " of " (itoa frames) " ")) (setq f (1+ f))) ;; Loop the playback, and leave the screen clean when the ;; viewer stops it with ESC. (write-line "VSLIDE" scr) (write-line "RSCRIPT" scr) (close scr) (setq scr nil) (setq path (findfile script)) (princ (strcat "\n\n" (itoa frames) " slides written as " prefix "1 to " prefix (itoa frames) ".")) (princ (strcat "\nScript: " (if path path script))) (princ "\nPlay it with SCRIPT, and stop it with ESC."))) ) ) (Morph:Restore) (princ) ) (princ)