Author Topic: ==={Challenge}===Find the ridge lines of sloped roof  (Read 43811 times)

0 Members and 1 Guest are viewing this topic.

MSTG007

  • Water Moccasin
  • Posts: 2464
  • I can't remeber what I already asked! I need help!
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #180 on: January 06, 2021, 07:36:32 AM »
Crazy awesome, Great job!
Civil3D 2020

ribarm

  • Water Moccasin
  • Posts: 2454
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #181 on: January 07, 2021, 12:38:06 PM »
I did it... This my version finds solutions sometimes different than built-in ACAD offset command preview... Take look at picture and DWG...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:2droof ( / unique mid clockwise-p LM:Inside-p processpla distp2t removesingles findipinterschilds processtxtipl process _vl-position car-sort car-vl-member-if lw ti n pl tl tlo pla plaa ipl ipll ipldtl ipldtlo ip p1p2 tt t1 t2 a f lil txtipl tll d al iplo p pal fff ipp lipl ippp dl itt )
  2.  
  3.   (defun unique ( l )
  4.     (if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
  5.   )
  6.  
  7.   (defun mid ( p1 p2 )
  8.     (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2)
  9.   )
  10.  
  11.   (defun clockwise-p ( p1 p2 p3 )
  12.     (minusp (sin (- (angle p1 p3) (angle p1 p2))))
  13.   )
  14.  
  15.   (defun LM:Inside-p ( pt ent / unit v^v _GroupByNum fd1 fd2 par lst nrm obj tmp )
  16.  
  17.     (vl-load-com)
  18.  
  19.     (defun unit ( v / d )
  20.       (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
  21.         (mapcar (function (lambda ( x ) (/ x d))) v)
  22.       )
  23.     )
  24.  
  25.     (defun v^v ( u v )
  26.       (list
  27.         (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
  28.         (- (* (caddr u) (car v)) (* (car u) (caddr v)))
  29.         (- (* (car u) (cadr v)) (* (cadr u) (car v)))
  30.       )
  31.     )
  32.  
  33.     (defun _GroupByNum ( l n / r )
  34.       (if l
  35.         (cons (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r)) (_GroupByNum l n))
  36.       )
  37.     )
  38.  
  39.     (if (= (type ent) 'VLA-OBJECT)
  40.       (setq obj ent
  41.             ent (vlax-vla-object->ename ent))
  42.       (setq obj (vlax-ename->vla-object ent))
  43.     )
  44.  
  45.     (if (vlax-curve-isplanar ent)
  46.       (progn
  47.         (setq fd1 (vlax-curve-getfirstderiv ent (setq par (vlax-curve-getstartparam ent))))
  48.         (while (or (equal fd1 (setq fd2 (vlax-curve-getfirstderiv ent (setq par (+ par 0.001)))) 1e-3) (null (setq nrm (unit (v^v fd1 fd2))))))
  49.         (setq lst
  50.           (_GroupByNum
  51.             (vlax-invoke
  52.               (setq tmp
  53.                 (vlax-ename->vla-object
  54.                   (entmakex
  55.                     (list
  56.                       (cons 0 "RAY")
  57.                       (cons 100 "AcDbEntity")
  58.                       (cons 100 "AcDbRay")
  59.                       (cons 10 pt)
  60.                       (cons 11 (trans '(1. 0. 0.) nrm 0))
  61.                     )
  62.                   )
  63.                 )
  64.               )
  65.               'IntersectWith obj acextendnone
  66.             ) 3
  67.           )
  68.         )
  69.         (vla-delete tmp)
  70.         ;; gile:
  71.         (and
  72.           lst
  73.           (not (vlax-curve-getparamatpoint ent pt))
  74.           (= 1 (rem (length (vl-remove-if (function (lambda ( p / pa p- p+ p0 )
  75.                                                       (setq pa (vlax-curve-getparamatpoint ent p))
  76.                                                       (and (setq p- (cond ((setq p- (vlax-curve-getPointatParam ent (- pa 1e-8)))
  77.                                                                            (trans p- 0 nrm)
  78.                                                                           )
  79.                                                                           ((trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-8)) 0 nrm)
  80.                                                                           )
  81.                                                                     )
  82.                                                            )
  83.                                                            (setq p+ (cond ((setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-8)))
  84.                                                                            (trans p+ 0 nrm)
  85.                                                                           )
  86.                                                                           ((trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-8)) 0 nrm)
  87.                                                                           )
  88.                                                                     )
  89.                                                            )
  90.                                                            (setq p0 (trans pt 0 nrm))
  91.                                                            (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
  92.                                                       )
  93.                                                     )
  94.                                           ) lst
  95.                             )
  96.                     ) 2
  97.                )
  98.           )
  99.         )
  100.       )
  101.     )
  102.   )
  103.  
  104.   (defun processpla ( pla / ipl pla1 pla2 )
  105.     (setq pla1 pla)
  106.     (foreach p1 pla1
  107.       (setq pla2 (vl-remove p1 pla1))
  108.       (foreach p2 pla2
  109.         (setq ipl (cons (inters (car p1) (polar (car p1) (cadr p1) 1.0) (car p2) (polar (car p2) (cadr p2) 1.0) nil) ipl))
  110.       )
  111.     )
  112.     (setq ipl (vl-remove-if-not (function (lambda ( p ) (LM:Inside-p p lw))) (vl-remove nil ipl)))
  113.   )
  114.  
  115.   (defun distp2t ( p tt )
  116.     (distance p (inters p (polar p (+ (angle (car tt) (cadr tt)) (* 0.5 pi)) 1.0) (car tt) (cadr tt) nil))
  117.   )
  118.  
  119.   (defun removesingles ( l / a )
  120.     (while (setq a (vl-some (function (lambda ( x ) (if (= (1- (length l)) (length (vl-remove-if (function (lambda ( y ) (equal x y 1e-6))) l))) x))) l))
  121.       (setq l (vl-remove a l))
  122.     )
  123.     l
  124.   )
  125.  
  126.   (defun findipinterschilds ( ip pla / pla1 pla2 r )
  127.     (setq pla1 pla)
  128.     (foreach p1 pla1
  129.       (setq pla2 (vl-remove p1 pla1))
  130.       (foreach p2 pla2
  131.         (if (equal ip (inters (car p1) (polar (car p1) (cadr p1) 1.0) (car p2) (polar (car p2) (cadr p2) 1.0) nil) 1e-6)
  132.           (setq r (list p1 p2))
  133.         )
  134.       )
  135.     )
  136.     r
  137.   )
  138.  
  139.   (defun processtxtipl ( tl / ipl tl1 tl2 )
  140.     (setq tl1 tl)
  141.     (foreach t1 tl1
  142.       (setq tl2 (vl-remove t1 tl1))
  143.       (foreach t2 tl2
  144.         (setq ipl (cons (inters (car t1) (polar (car t1) (angle (car t1) (cadr t1)) 1.0) (car t2) (polar (car t2) (angle (car t2) (cadr t2)) 1.0) nil) ipl))
  145.       )
  146.     )
  147.     (if (vl-some (function null) ipl)
  148.       (exit)
  149.       ipl
  150.     )
  151.   )
  152.  
  153.   (defun process nil
  154.     (if ip
  155.       (setq p1p2 (findipinterschilds ip pla))
  156.       (setq p1p2 nil)
  157.     )
  158.     (setq f nil)
  159.     (if p1p2
  160.       (progn
  161.         (setq tt (vl-some (function (lambda ( x ) (if (and (assoc (car x) p1p2) (assoc (cadr x) p1p2)) (progn (setq f t) x)))) tlo))
  162.         (if
  163.           (or
  164.             (vl-some (function (lambda ( x ) (equal (distance ip (car (car p1p2))) (+ (distance ip x) (distance x (car (car p1p2)))) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x (car (car p1p2)) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x ip 1e-6))) (mapcar (function car) ipldtl))))
  165.             (vl-some (function (lambda ( x ) (equal (distance ip (car (cadr p1p2))) (+ (distance ip x) (distance x (car (cadr p1p2)))) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x (car (cadr p1p2)) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x ip 1e-6))) (mapcar (function car) ipldtl))))
  166.           )
  167.           (setq f nil)
  168.         )
  169.       )
  170.     )
  171.     f
  172.   )
  173.  
  174.   (defun _vl-position ( e l tol / car-vl-member-if )
  175.     (defun car-vl-member-if ( f l / ff r )
  176.       (setq ff (function (lambda ( x ) (if (apply f (list x)) (setq r x)))))
  177.       (vl-some ff l)
  178.       r
  179.     )
  180.     (vl-position (car-vl-member-if (function (lambda ( x ) (equal e x tol))) l) l)
  181.   )
  182.  
  183.   (defun car-sort ( lst cmp / rtn )
  184.     (setq rtn (car lst))
  185.     (foreach itm (cdr lst)
  186.       (if (apply cmp (list itm rtn))
  187.         (setq rtn itm)
  188.       )
  189.     )
  190.     rtn
  191.   )
  192.  
  193.   (defun car-vl-member-if ( f l / ff r )
  194.     (setq ff (function (lambda ( x ) (if (apply f (list x)) (setq r x)))))
  195.     (vl-some ff l)
  196.     r
  197.   )
  198.  
  199.  
  200. ;;; main 2droof ;;;
  201.  
  202.   (setq lw (car (entsel "\nPick a closed polygon : ")))
  203.   (setq ti (car (_vl-times)))
  204.   (setq n (cdr (assoc 90 (entget lw))))
  205.   (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw))))
  206.   (setq tl (mapcar (function (lambda ( a b ) (list a b))) pl (append (cdr pl) (list (car pl)))))
  207.   (setq tlo tl)
  208.   (setq pla (mapcar (function (lambda ( p mp ) (list p (angle p mp)))) pl (mapcar (function (lambda ( a b ) (if (clockwise-p (car a) (car b) (cadr b)) (mid (polar (cadr a) (angle (cadr a) (car a)) -1.0) (polar (car b) (angle (car b) (cadr b)) -1.0)) (mid (polar (cadr a) (angle (cadr a) (car a)) 1.0) (polar (car b) (angle (car b) (cadr b)) 1.0))))) (cons (last tl) tl) tl)))
  209.   (setq plaa pla)
  210.   (while (> n 0)
  211.     (if (null ipll)
  212.       (setq ipl (unique (processpla plaa)))
  213.       (setq ipl (unique (processpla (unique pla))))
  214.     )
  215.     (if (equal ipl iplo 1e-6)
  216.       (setq n 0)
  217.     )
  218.     (if fff
  219.       (progn
  220.         (setq pl (mapcar (function car) pla))
  221.         (foreach x pl
  222.           (setq lil (cons (list x ip) lil))
  223.         )
  224.         (setq n 0)
  225.       )
  226.       (progn
  227.         (setq ipldtl (mapcar (function (lambda ( p ) (list p (vl-sort (mapcar (function (lambda ( tt ) (distp2t p tt))) tlo) (function <))))) ipl))
  228.         (setq ipldtl (mapcar (function (lambda ( x ) (list (car x) (removesingles (cadr x))))) ipldtl))
  229.         (setq ipldtl (vl-remove-if (function (lambda ( x ) (< (- (length (cadr x)) (length (vl-remove-if (function (lambda ( y ) (equal y (car (cadr x)) 1e-6))) (cadr x)))) 3))) ipldtl))
  230.         (if ipll
  231.           (setq ipldtl (vl-remove-if (function (lambda ( x ) (_vl-position (car x) ipll 1e-6))) ipldtl))
  232.         )
  233.         (if (null ipll)
  234.           (setq ipldtlo ipldtl)
  235.         )
  236.         (setq ip (car (car-sort (unique (append ipldtl ipldtlo)) (function (lambda ( a b ) (< (car (cadr a)) (car (cadr b))))))))
  237.         (setq ipldtlo (vl-remove-if (function (lambda ( x ) (equal (car x) ip 1e-6))) ipldtlo))
  238.         (setq ipp nil)
  239.         (if (not (process))
  240.           (if ipll
  241.             (progn
  242.               (foreach y (reverse pal)
  243.                 (setq ipp (cons (vl-remove-if-not (function (lambda ( x ) (vl-some (function (lambda ( a ) (or (equal (rem (+ a pi) (* 2 pi)) (angle (car y) x) 1e-6) (equal a (angle (car y) x) 1e-6)))) (cadr y)))) (mapcar (function car) (vl-sort ipldtl (function (lambda ( a b ) (> (car (cadr a)) (car (cadr b)))))))) ipp))
  244.               )
  245.               (setq ipp (apply (function append) ipp))
  246.               (if p1p2
  247.                 (setq ipp (cons ip ipp))
  248.               )
  249.               (setq ipp (unique ipp))
  250.               (setq ipp (mapcar (function (lambda ( p ) (list p (findipinterschilds p pla)))) ipp))
  251.               (setq ipp (vl-remove-if (function (lambda ( x ) (null (cadr x)))) ipp))
  252.               (setq ipp (vl-remove-if (function (lambda ( x )
  253.                 (or
  254.                   (vl-some (function (lambda ( y ) (equal (distance (car x) (car (car (cadr x)))) (+ (distance (car x) y) (distance y (car (car (cadr x))))) 1e-6))) (vl-remove-if (function (lambda ( z ) (equal z (car (car (cadr x))) 1e-6))) (vl-remove-if (function (lambda ( z ) (equal z (car x) 1e-6))) (mapcar (function car) ipldtl))))
  255.                   (vl-some (function (lambda ( y ) (equal (distance (car x) (car (cadr (cadr x)))) (+ (distance (car x) y) (distance y (car (cadr (cadr x))))) 1e-6))) (vl-remove-if (function (lambda ( z ) (equal z (car (cadr (cadr x))) 1e-6))) (vl-remove-if (function (lambda ( z ) (equal z (car x) 1e-6))) (mapcar (function car) ipldtl))))
  256.                   (vl-some (function (lambda ( y / ii ) (and (setq ii (inters (car x) (car (car (cadr x))) (car y) (cadr y) t)) (not (equal ii (car x) 1e-6)) (not (equal ii (car (car (cadr x))) 1e-6)) (not (equal ii (car y) 1e-6)) (not (equal ii (cadr y) 1e-6))))) (append tlo lil))
  257.                   (vl-some (function (lambda ( y / ii ) (and (setq ii (inters (car x) (car (cadr (cadr x))) (car y) (cadr y) t)) (not (equal ii (car x) 1e-6)) (not (equal ii (car (cadr (cadr x))) 1e-6)) (not (equal ii (car y) 1e-6)) (not (equal ii (cadr y) 1e-6))))) (append tlo lil))
  258.                 ))) ipp)
  259.               )
  260.               (setq dl (mapcar (function (lambda ( y ) (car (cadr (car-vl-member-if (function (lambda ( x ) (equal (car x) y 1e-6))) ipldtl))))) (mapcar (function car) ipp)))
  261.               (if dl
  262.                 (setq ip (car (nth (vl-position (car-sort dl (function <)) dl) ipp)))
  263.               )
  264.             )
  265.           )
  266.         )
  267.         (if (vl-every (function (lambda ( x ) (equal ip (inters (car (car pla)) (polar (car (car pla)) (cadr (car pla)) 1.0) (car x) (polar (car x) (cadr x) 1.0) nil) 1e-6))) (cdr pla))
  268.           (setq fff t)
  269.         )
  270.         (setq d (car (cadr (car-vl-member-if (function (lambda ( x ) (equal (car x) ip 1e-6))) (unique (append ipldtl ipldtlo))))))
  271.         (setq al nil a nil)
  272.         (process)
  273.         (if (null p1p2)
  274.           (setq ip nil)
  275.         )
  276.         (if (and tt f)
  277.           (progn
  278.             (setq tl (vl-remove tt tl))
  279.             (setq n (1- n))
  280.           )
  281.         )
  282.         (if f
  283.           (progn
  284.             (setq t1 (vl-some (function (lambda ( x ) (if (or (assoc (car x) (list (car p1p2))) (assoc (cadr x) (list (car p1p2)))) x))) tl))
  285.             (setq t2 (vl-some (function (lambda ( x ) (if (or (assoc (car x) (list (cadr p1p2))) (assoc (cadr x) (list (cadr p1p2)))) x))) tl))
  286.           )
  287.           (setq t1 nil t2 nil)
  288.         )
  289.         (if ip
  290.           (setq ipll (cons ip ipll))
  291.         )
  292.         (if (and t1 t2 ip)
  293.           (progn
  294.             (if (null (setq itt (inters (car t1) (cadr t1) (car t2) (cadr t2) nil)))
  295.               (exit)
  296.               (setq a (angle itt ip))
  297.             )
  298.             (if a
  299.               (progn
  300.                 (setq pla (cons (list ip a) pla))
  301.                 (setq pla (vl-remove (car p1p2) pla) pla (vl-remove (cadr p1p2) pla))
  302.                 (setq lil (cons (list (car (car p1p2)) ip) lil))
  303.                 (setq lil (cons (list (car (cadr p1p2)) ip) lil))
  304.                 (setq pal (cons (list ip (list a)) pal))
  305.               )
  306.             )
  307.           )
  308.           (if (and ip (null fff))
  309.             (progn
  310.               (setq lil (cons (list (car (car p1p2)) ip) lil))
  311.               (setq lil (cons (list (car (cadr p1p2)) ip) lil))
  312.               (if (setq p (vl-some (function (lambda ( x ) (if (vl-position x plaa) x))) p1p2))
  313.                 (progn
  314.                   (setq n (1- n))
  315.                   (setq tll (vl-remove-if-not (function (lambda ( x ) (vl-some (function (lambda ( y ) (_vl-position p y 1e-6))) x))) tlo))
  316.                   (setq tll (car (vl-remove-if-not (function (lambda ( x ) (and (_vl-position (car x) (vl-remove nil (mapcar (function car) lil)) 1e-6) (_vl-position (cadr x) (vl-remove nil (mapcar (function car) lil)) 1e-6)))) tll)))
  317.                   (setq tl (vl-remove tll tl))
  318.                 )
  319.               )
  320.               (setq tll (vl-remove-if-not (function (lambda ( x ) (equal d (distp2t ip x) 1e-6))) tl))
  321.               (setq txtipl (processtxtipl tll))
  322.               (setq txtipl (vl-remove-if (function (lambda ( x ) (_vl-position x pl 1e-6))) txtipl))
  323.               (setq al (mapcar (function (lambda ( p ) (angle p ip))) txtipl))
  324.               (setq al (vl-remove-if (function (lambda ( x ) (_vl-position x (mapcar (function cadr) p1p2) 1e-6))) al))
  325.               (setq al (unique al))
  326.               (if al
  327.                 (progn
  328.                   (setq pla (append pla (mapcar (function (lambda ( a ) (list ip a))) al)))
  329.                   (setq pal (cons (list ip al) pal))
  330.                 )
  331.               )
  332.               (setq pla (vl-remove (car p1p2) pla) pla (vl-remove (cadr p1p2) pla))
  333.             )
  334.           )
  335.         )
  336.       )
  337.     )
  338.     (setq iplo ipl)
  339.   )
  340.   (setq lil (vl-remove-if (function (lambda ( x ) (equal (car x) (cadr x) 1e-6))) lil))
  341.   (setq lil (unique lil))
  342.   (setq lil (vl-remove-if (function (lambda ( x ) (vl-some (function (lambda ( y ) (null y))) x))) lil))
  343.   (setq lipl (apply (function append) lil))
  344.   (setq lipl (unique (vl-remove-if (function (lambda ( x ) (or (= (length (vl-remove x lipl)) (1- (length lipl))) (= (length (vl-remove x lipl)) (- (length lipl) 3))))) lipl)))
  345.   (if lipl
  346.     (setq lil (cons (list (car lipl) (cadr lipl)) lil))
  347.   )
  348.   (foreach li lil
  349.     (entmake (list '(0 . "LINE") (cons 10 (car li)) (cons 11 (cadr li))))
  350.   )
  351.   (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  352.   (princ)
  353. )
  354.  



Regards, and Happy New 2021. Year...
« Last Edit: January 09, 2021, 01:47:47 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

BIGAL

  • Swamp Rat
  • Posts: 581
  • 30 + years of using Autocad
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #182 on: January 07, 2021, 06:16:02 PM »
Wow pretty fantastic shape to work out a roof, its like the AUS opera house they said it could not be built.
A man who never made a mistake never made anything

ribarm

  • Water Moccasin
  • Posts: 2454
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #183 on: January 08, 2021, 09:31:46 AM »
I've tried to implement orthogonality in solution, but strangely the same rule can't be applied to this cases... Still not to be that I didn't try, here is my revision - please use better solution - previously posted code if you don't have orthogonality...

Code removed due to later revisions that are better...
« Last Edit: January 10, 2021, 05:06:21 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2454
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #184 on: January 08, 2021, 12:01:02 PM »
I solved it... It should work on any case, just like it should...
Code - Auto/Visual Lisp: [Select]
  1. (defun c:2droof (/ unique mid clockwise-p LM:Inside-p processpla distp2t removesingles removedoubles findipinterschilds processtxtipl process unioncollinearplaneprints _vl-position car-sort car-vl-member-if lw ti n pl tl tlo utlo pla plaa ipl ipll ipldtl ipldtlo ip p1p2 tt t1 t2 a f lil txtipl tll d al iplo p pal fff ipp lipl dl ipo itt)
  2.  
  3.   (defun unique (l)
  4.     (if l (cons (car l) (unique (vl-remove-if (function (lambda (x) (equal x (car l) 1e-6))) l))))
  5.   )
  6.   (defun mid (p1 p2)
  7.     (mapcar (function (lambda (a b) (/ (+ a b) 2.0))) p1 p2)
  8.   )
  9.   (defun clockwise-p (p1 p2 p3)
  10.     (minusp (sin (- (angle p1 p3) (angle p1 p2))))
  11.   )
  12.   (defun LM:Inside-p (pt ent / unit v^v _GroupByNum fd1 fd2 par lst nrm obj tmp)
  13.     (vl-load-com)
  14.     (defun unit (v / d)
  15.       (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
  16.         (mapcar (function (lambda (x) (/ x d))) v)
  17.       )
  18.     )
  19.     (defun v^v (u v)
  20.       (list
  21.         (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
  22.         (- (* (caddr u) (car v)) (* (car u) (caddr v)))
  23.         (- (* (car u) (cadr v)) (* (cadr u) (car v)))
  24.       )
  25.     )
  26.     (defun _GroupByNum (l n / r)
  27.       (if l
  28.         (cons (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r)) (_GroupByNum l n))
  29.       )
  30.     )
  31.     (if (= (type ent) 'VLA-OBJECT)
  32.       (setq obj ent ent (vlax-vla-object->ename ent))
  33.       (setq obj (vlax-ename->vla-object ent))
  34.     )
  35.     (if (vlax-curve-isplanar ent)
  36.       (progn
  37.         (setq fd1 (vlax-curve-getfirstderiv ent (setq par (vlax-curve-getstartparam ent))))
  38.         (while (or (equal fd1 (setq fd2 (vlax-curve-getfirstderiv ent (setq par (+ par 0.001)))) 1e-3) (null (setq nrm (unit (v^v fd1 fd2))))))
  39.         (setq lst
  40.           (_GroupByNum
  41.             (vlax-invoke
  42.               (setq tmp
  43.                 (vlax-ename->vla-object
  44.                   (entmakex
  45.                     (list
  46.                       (cons 0 "RAY")
  47.                       (cons 100 "AcDbEntity")
  48.                       (cons 100 "AcDbRay")
  49.                       (cons 10 pt)
  50.                       (cons 11 (trans '(1. 0. 0.) nrm 0))
  51.                     )
  52.                   )
  53.                 )
  54.               )
  55.               'IntersectWith obj acextendnone
  56.             ) 3
  57.           )
  58.         )
  59.         (vla-delete tmp)
  60.         ;; gile:
  61.         (and
  62.           lst
  63.           (not (vlax-curve-getparamatpoint ent pt))
  64.           (= 1 (rem (length (vl-remove-if (function (lambda (p / pa p- p+ p0)
  65.                                                       (setq pa (vlax-curve-getparamatpoint ent p))
  66.                                                       (and (setq p- (cond ((setq p- (vlax-curve-getPointatParam ent (- pa 1e-8)))
  67.                                                                            (trans p- 0 nrm)
  68.                                                                           )
  69.                                                                           ((trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-8)) 0 nrm)
  70.                                                                           )
  71.                                                                     )
  72.                                                            )
  73.                                                            (setq p+ (cond ((setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-8)))
  74.                                                                            (trans p+ 0 nrm)
  75.                                                                           )
  76.                                                                           ((trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-8)) 0 nrm)
  77.                                                                           )
  78.                                                                     )
  79.                                                            )
  80.                                                            (setq p0 (trans pt 0 nrm))
  81.                                                            (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
  82.                                                       )
  83.                                                     )
  84.                                           ) lst
  85.                             )
  86.                     ) 2
  87.                )
  88.           )
  89.         )
  90.       )
  91.     )
  92.   )
  93.   (defun processpla (pla / ipl pla1 pla2)
  94.     (setq pla1 pla)
  95.     (foreach p1 pla1
  96.       (setq pla2 (vl-remove p1 pla1))
  97.       (foreach p2 pla2
  98.         (setq ipl (cons (inters (car p1) (polar (car p1) (cadr p1) 1.0) (car p2) (polar (car p2) (cadr p2) 1.0) nil) ipl))
  99.       )
  100.     )
  101.     (setq ipl (vl-remove-if-not (function (lambda (p) (LM:Inside-p p lw))) (vl-remove nil ipl)))
  102.   )
  103.   (defun distp2t (p tt)
  104.     (distance p (inters p (polar p (+ (angle (car tt) (cadr tt)) (* 0.5 pi)) 1.0) (car tt) (cadr tt) nil))
  105.   )
  106.   (defun removesingles (l / a)
  107.     (while (setq a (vl-some (function (lambda (x) (if (= (1- (length l)) (length (vl-remove-if (function (lambda (y) (equal x y 1e-6))) l))) x))) l))
  108.       (setq l (vl-remove-if (function (lambda (x) (equal x a 1e-6))) l))
  109.     )
  110.     l
  111.   )
  112.   (defun removedoubles (l / a)
  113.     (while (setq a (vl-some (function (lambda (x) (if (= (- (length l) 2) (length (vl-remove-if (function (lambda (y) (equal x y 1e-6))) l))) x))) l))
  114.       (setq l (vl-remove-if (function (lambda (x) (equal x a 1e-6))) l))
  115.     )
  116.     l
  117.   )
  118.   (defun findipinterschilds (ip pla / pla1 pla2 r)
  119.     (setq pla1 pla)
  120.     (foreach p1 pla1
  121.       (setq pla2 (vl-remove p1 pla1))
  122.       (foreach p2 pla2
  123.         (if (equal ip (inters (car p1) (polar (car p1) (cadr p1) 1.0) (car p2) (polar (car p2) (cadr p2) 1.0) nil) 1e-6)
  124.           (setq r (list p1 p2))
  125.         )
  126.       )
  127.     )
  128.     r
  129.   )
  130.   (defun processtxtipl (tl / ipl tl1 tl2 intt)
  131.     (setq tl1 tl)
  132.     (foreach t1 tl1
  133.       (setq tl2 (vl-remove t1 tl1))
  134.       (foreach t2 tl2
  135.         (if (setq intt (inters (car t1) (polar (car t1) (angle (car t1) (cadr t1)) 1.0) (car t2) (polar (car t2) (angle (car t2) (cadr t2)) 1.0) nil))
  136.           (setq ipl (cons intt ipl))
  137.           (setq ipl (cons (angle (car t1) (cadr t1)) ipl))
  138.         )
  139.       )
  140.     )
  141.     ipl
  142.   )
  143.   (defun process nil
  144.     (if ip
  145.       (setq p1p2 (findipinterschilds ip pla))
  146.       (setq p1p2 nil)
  147.     )
  148.     (setq f nil)
  149.     (if p1p2
  150.       (progn
  151.         (setq tt (vl-some (function (lambda (x) (if (and (assoc (car x) p1p2) (assoc (cadr x) p1p2)) (progn (setq f t) x)))) tlo))
  152.         (if
  153.           (or
  154.             (vl-some (function (lambda (x) (equal (distance ip (car (car p1p2))) (+ (distance ip x) (distance x (car (car p1p2)))) 1e-6))) (vl-remove-if (function (lambda (x) (equal x (car (car p1p2)) 1e-6))) (vl-remove-if (function (lambda (x) (equal x ip 1e-6))) (mapcar (function car) ipldtl))))
  155.             (vl-some (function (lambda (x) (equal (distance ip (car (cadr p1p2))) (+ (distance ip x) (distance x (car (cadr p1p2)))) 1e-6))) (vl-remove-if (function (lambda (x) (equal x (car (cadr p1p2)) 1e-6))) (vl-remove-if (function (lambda (x) (equal x ip 1e-6))) (mapcar (function car) ipldtl))))
  156.             (vl-some (function (lambda (y / ii) (and (setq ii (inters ip (car (car p1p2)) (car y) (cadr y) t)) (not (equal ii ip 1e-6)) (not (equal ii (car (car p1p2)) 1e-6)) (not (equal ii (car y) 1e-6)) (not (equal ii (cadr y) 1e-6))))) (append tlo lil))
  157.             (vl-some (function (lambda (y / ii) (and (setq ii (inters ip (car (cadr p1p2)) (car y) (cadr y) t)) (not (equal ii ip 1e-6)) (not (equal ii (car (cadr p1p2)) 1e-6)) (not (equal ii (car y) 1e-6)) (not (equal ii (cadr y) 1e-6))))) (append tlo lil))
  158.           )
  159.           (setq f nil)
  160.         )
  161.       )
  162.     )
  163.     f
  164.   )
  165.   (defun unioncollinearplaneprints (tl / a b tll)
  166.     (while (setq a (car tl))
  167.       (setq b (vl-remove-if-not (function (lambda (x) (and (or (equal (angle (car a) (cadr a)) (angle (car a) (car x)) 1e-6) (equal (angle (cadr a) (car a)) (angle (car a) (car x)) 1e-6)) (or (equal (angle (car a) (cadr a)) (angle (car a) (cadr x)) 1e-6) (equal (angle (cadr a) (car a)) (angle (car a) (cadr x)) 1e-6))))) tl))
  168.       (setq tll (cons a tll))
  169.       (if b
  170.         (setq tl (vl-remove-if (function (lambda (x) (vl-position x b))) tl))
  171.         (setq tl (cdr tl))
  172.       )
  173.     )
  174.     tll
  175.   )
  176.   (defun car-vl-member-if (f l / ff r)
  177.     (setq ff (function (lambda (x) (if (apply f (list x)) (setq r x)))))
  178.     (vl-some ff l)
  179.     r
  180.   )
  181.   (defun _vl-position (e l tol)
  182.     (vl-position (car-vl-member-if (function (lambda ( x ) (equal e x tol))) l) l)
  183.   )
  184.   (defun car-sort (lst cmp / rtn)
  185.     (setq rtn (car lst))
  186.     (foreach itm (cdr lst)
  187.       (if (apply cmp (list itm rtn))
  188.         (setq rtn itm)
  189.       )
  190.     )
  191.     rtn
  192.   )
  193. ;;; main 2droof ;;;
  194.   (if (setq lw (car (entsel "\nPick a closed polygonal LWPOLYLINE...")))
  195.     (progn
  196.       (setq ti (car (_vl-times)))
  197.       (gc)
  198.       (setq n (cdr (assoc 90 (entget lw))))
  199.       (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda (x) (/= (car x) 10))) (entget lw))))
  200.       (setq tl (mapcar (function (lambda (a b) (list a b))) pl (append (cdr pl) (list (car pl)))))
  201.       (setq tlo tl)
  202.       (setq utlo (unioncollinearplaneprints tlo))
  203.       (setq pla (mapcar (function (lambda (p mp) (list p (angle p mp)))) pl (mapcar (function (lambda (a b) (if (clockwise-p (car a) (car b) (cadr b)) (mid (polar (cadr a) (angle (cadr a) (car a)) -1.0) (polar (car b) (angle (car b) (cadr b)) -1.0)) (mid (polar (cadr a) (angle (cadr a) (car a)) 1.0) (polar (car b) (angle (car b) (cadr b)) 1.0))))) (cons (last tl) tl) tl)))
  204.       (setq plaa pla)
  205.       (while (> n 0)
  206.         (if (null ipll)
  207.           (setq ipl (unique (processpla plaa)))
  208.           (setq ipl (unique (processpla (unique pla))))
  209.         )
  210.         (if (equal ipl iplo 1e-6)
  211.           (setq n 0)
  212.         )
  213.         (if fff
  214.           (progn
  215.             (setq pl (mapcar (function car) pla))
  216.             (foreach x pl
  217.               (setq lil (cons (list x ip) lil))
  218.             )
  219.             (setq n 0)
  220.           )
  221.           (progn
  222.             (setq ipo ip)
  223.             (setq ipldtl (mapcar (function (lambda (p) (list p (vl-sort (mapcar (function (lambda (tt) (distp2t p tt))) utlo) (function <))))) ipl))
  224.             (setq ipldtl (mapcar (function (lambda (x) (list (car x) (removedoubles (removesingles (cadr x)))))) ipldtl))
  225.             (setq ipldtl (vl-remove-if (function (lambda (x) (null (cadr x)))) ipldtl))
  226.             (if ipll
  227.               (setq ipldtl (vl-remove-if (function (lambda (x) (_vl-position (car x) ipll 1e-6))) ipldtl))
  228.             )
  229.             (setq ipldtl (mapcar (function (lambda (x) (list (car x) (vl-sort (cadr x) (function <))))) ipldtl))
  230.             (setq ipldtlo (vl-sort ipldtl (function (lambda (a b) (< (car (cadr a)) (car (cadr b)))))))
  231.             (setq ipldtlo (vl-remove-if (function (lambda (x) (_vl-position (car x) ipll 1e-6))) ipldtlo))
  232.             (setq ip (car (car ipldtlo)))
  233.             (while (and (not (process)) ipldtlo)
  234.               (setq ipldtlo (cdr ipldtlo))
  235.               (setq ip (car (car ipldtlo)))
  236.             )
  237.             (setq ipp nil)
  238.             (if ipll
  239.               (progn
  240.                 (foreach y (reverse pal)
  241.                   (setq ipp (cons (vl-remove-if-not (function (lambda (x) (vl-some (function (lambda (a) (or (equal (rem (+ a pi) (* 2 pi)) (angle (car y) x) 1e-6) (equal a (angle (car y) x) 1e-6)))) (cadr y)))) (mapcar (function car) (vl-remove-if (function (lambda (x) (_vl-position (car x) ipll 1e-6))) ipldtl))) ipp))
  242.                 )
  243.                 (setq ipp (apply (function append) ipp))
  244.                 (if (and ip p1p2)
  245.                   (setq ipp (cons ip ipp))
  246.                 )
  247.                 (setq ipp (unique ipp))
  248.                 (setq ipp (mapcar (function (lambda (p) (list p (findipinterschilds p pla)))) ipp))
  249.                 (setq ipp (vl-remove-if (function (lambda (x) (null (cadr x)))) ipp))
  250.                 (setq ipp (vl-remove-if (function (lambda (x)
  251.                   (or
  252.                     (vl-some (function (lambda (y) (equal (distance (car x) (car (car (cadr x)))) (+ (distance (car x) y) (distance y (car (car (cadr x))))) 1e-6))) (vl-remove-if (function (lambda (z) (equal z (car (car (cadr x))) 1e-6))) (vl-remove-if (function (lambda (z) (equal z (car x) 1e-6))) (mapcar (function car) ipldtl))))
  253.                     (vl-some (function (lambda (y) (equal (distance (car x) (car (cadr (cadr x)))) (+ (distance (car x) y) (distance y (car (cadr (cadr x))))) 1e-6))) (vl-remove-if (function (lambda (z) (equal z (car (cadr (cadr x))) 1e-6))) (vl-remove-if (function (lambda (z) (equal z (car x) 1e-6))) (mapcar (function car) ipldtl))))
  254.                     (vl-some (function (lambda (y / ii) (and (setq ii (inters (car x) (car (car (cadr x))) (car y) (cadr y) t)) (not (equal ii (car x) 1e-6)) (not (equal ii (car (car (cadr x))) 1e-6)) (not (equal ii (car y) 1e-6)) (not (equal ii (cadr y) 1e-6))))) (append tlo lil))
  255.                     (vl-some (function (lambda (y / ii) (and (setq ii (inters (car x) (car (cadr (cadr x))) (car y) (cadr y) t)) (not (equal ii (car x) 1e-6)) (not (equal ii (car (cadr (cadr x))) 1e-6)) (not (equal ii (car y) 1e-6)) (not (equal ii (cadr y) 1e-6))))) (append tlo lil))
  256.                   )
  257.                   )) ipp)
  258.                 )
  259.                 (setq dl (mapcar (function (lambda (y) (car (cadr (car-vl-member-if (function (lambda (x) (equal (car x) y 1e-6))) ipldtl))))) (mapcar (function car) ipp)))
  260.                 (if dl
  261.                   (setq ip (car (nth (vl-position (car-sort dl (function <)) dl) ipp)))
  262.                 )
  263.               )
  264.             )
  265.             (if (vl-every (function (lambda (x) (equal ip (inters (car (car pla)) (polar (car (car pla)) (cadr (car pla)) 1.0) (car x) (polar (car x) (cadr x) 1.0) nil) 1e-6))) (cdr pla))
  266.               (setq fff t)
  267.             )
  268.             (process)
  269.             (if (and p1p2 (setq itt (vl-some (function (lambda (x) (if (or (equal (distance ip (car (car p1p2))) (+ (distance ip (car x)) (distance (car x) (car (car p1p2)))) 1e-6) (equal (distance ip (car (cadr p1p2))) (+ (distance ip (car x)) (distance (car x) (car (cadr p1p2)))) 1e-6)) (car x)))) (vl-remove-if (function (lambda (x) (equal ip (car x) 1e-6))) ipp))))
  270.               (progn
  271.                 (setq ip itt)
  272.                 (process)
  273.               )
  274.             )
  275.             (if (equal ipo ip 1e-6)
  276.               (setq n 0)
  277.             )
  278.             (setq d (car (cadr (car-vl-member-if (function (lambda (x) (equal (car x) ip 1e-6))) ipldtl))))
  279.             (setq al nil a nil)
  280.             (if (and tt f)
  281.               (setq tl (vl-remove tt tl))
  282.             )
  283.             (if f
  284.               (progn
  285.                 (setq t1 (vl-some (function (lambda (x) (if (or (assoc (car x) (list (car p1p2))) (assoc (cadr x) (list (car p1p2)))) x))) tl))
  286.                 (setq t2 (vl-some (function (lambda (x) (if (or (assoc (car x) (list (cadr p1p2))) (assoc (cadr x) (list (cadr p1p2)))) x))) tl))
  287.               )
  288.               (setq t1 nil t2 nil)
  289.             )
  290.             (if ip
  291.               (setq ipll (cons ip ipll))
  292.             )
  293.             (if (and t1 t2 ip)
  294.               (progn
  295.                 (if (inters (car t1) (cadr t1) (car t2) (cadr t2) nil)
  296.                   (setq a (angle (inters (car t1) (cadr t1) (car t2) (cadr t2) nil) ip))
  297.                   (setq a (angle (car t1) (cadr t1)))
  298.                 )
  299.                 (if a
  300.                   (progn
  301.                     (setq pla (cons (list ip a) pla))
  302.                     (setq pla (vl-remove-if (function (lambda (x) (equal (car x) (car (car p1p2)) 1e-6))) pla) pla (vl-remove-if (function (lambda (x) (equal (car x) (car (cadr p1p2)) 1e-6))) pla))
  303.                     (if (car (car p1p2))
  304.                       (setq lil (cons (list (car (car p1p2)) ip) lil))
  305.                     )
  306.                     (if (car (cadr p1p2))
  307.                       (setq lil (cons (list (car (cadr p1p2)) ip) lil))
  308.                     )
  309.                     (setq pal (cons (list ip (list a)) pal))
  310.                   )
  311.                 )
  312.               )
  313.               (if (and ip (null fff))
  314.                 (progn
  315.                   (if (car (car p1p2))
  316.                     (setq lil (cons (list (car (car p1p2)) ip) lil))
  317.                   )
  318.                   (if (car (cadr p1p2))
  319.                     (setq lil (cons (list (car (cadr p1p2)) ip) lil))
  320.                   )
  321.                   (if (setq p (vl-some (function (lambda (x) (if (vl-position x plaa) x))) p1p2))
  322.                     (progn
  323.                       (setq tll (vl-remove-if-not (function (lambda (x) (vl-some (function (lambda (y) (_vl-position p y 1e-6))) x))) tlo))
  324.                       (setq tll (car (vl-remove-if-not (function (lambda (x) (and (_vl-position (car x) (vl-remove nil (mapcar (function car) lil)) 1e-6) (_vl-position (cadr x) (vl-remove nil (mapcar (function car) lil)) 1e-6)))) tll)))
  325.                       (setq tl (vl-remove tll tl))
  326.                     )
  327.                   )
  328.                   (setq tll (vl-remove-if-not (function (lambda (x) (equal d (distp2t ip x) 1e-6))) tl))
  329.                   (setq txtipl (processtxtipl tll))
  330.                   (setq txtipl (vl-remove-if (function (lambda (x) (_vl-position x pl 1e-6))) txtipl))
  331.                   (setq al (mapcar (function (lambda (p) (if (listp p) (angle p ip) p))) txtipl))
  332.                   (setq al (vl-remove-if (function (lambda (x) (or (_vl-position x (mapcar (function cadr) p1p2) 1e-6) (_vl-position (rem (+ x pi) (* 2 pi)) (mapcar (function cadr) p1p2) 1e-6)))) al))
  333.                   (setq al (unique al))
  334.                   (if al
  335.                     (progn
  336.                       (setq pla (append (mapcar (function (lambda (a) (list ip a))) al) pla))
  337.                       (setq pal (cons (list ip al) pal))
  338.                     )
  339.                   )
  340.                   (setq pla (vl-remove-if (function (lambda (x) (equal (car x) (car (car p1p2)) 1e-6))) pla) pla (vl-remove-if (function (lambda (x) (equal (car x) (car (cadr p1p2)) 1e-6))) pla))
  341.                 )
  342.               )
  343.             )
  344.           )
  345.         )
  346.         (setq iplo ipl)
  347.       )
  348.       (setq lil (vl-remove-if (function (lambda (x) (equal (car x) (cadr x) 1e-6))) lil))
  349.       (setq lil (unique lil))
  350.       (setq lil (vl-remove-if (function (lambda (x) (vl-some (function (lambda (y) (null y))) x))) lil))
  351.       (setq lipl (apply (function append) lil))
  352.       (setq lipl (unique (vl-remove-if (function (lambda (x) (or (= (length (vl-remove x lipl)) (1- (length lipl))) (= (length (vl-remove x lipl)) (- (length lipl) 3))))) lipl)))
  353.       (setq lipl (vl-remove-if (function (lambda (x) (vl-some (function (lambda (li) (and (equal (distance (car li) (cadr li)) (+ (distance (car li) x) (distance x (cadr li))) 1e-6) (not (equal x (car li) 1e-6)) (not (equal x (cadr li) 1e-6))))) lil))) lipl))
  354.       (if lipl
  355.         (setq lil (cons (list (car lipl) (cadr lipl)) lil))
  356.       )
  357.       (setq lil (vl-remove-if (function (lambda (x) (or (null (car x)) (null (cadr x))))) lil))
  358.       (foreach li lil
  359.         (entmake (list '(0 . "LINE") (cons 10 (car li)) (cons 11 (cadr li))))
  360.       )
  361.       (gc)
  362.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  363.     )
  364.   )
  365.   (princ)
  366. )
  367.  
« Last Edit: January 20, 2021, 01:59:22 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

d2010

  • Newt
  • Posts: 125
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #185 on: January 08, 2021, 01:42:11 PM »
Wow pretty fantastic shape to work out a roof, its like the AUS opera house they said it could not be built.
Code - Auto/Visual Lisp: [Select]
  1. ;;;
  2. (defun c:2droof ( / nn_unique nn_mid nn_clockwisep nn_insidep nn_processpla nn_distp2t nn_removesingles nn_findipinterschilds nn_processtxtipl nn_prefetch nn_positionvl nn_carsort nn_car_vlmember_if lw ti n pl tl tlo pla plaa ipl ipll ipldtl ipldtlo ip p1p2 tt t1 t2 a f lil txtipl tll d al iplo p pal fff ipp lipl ippp dl )
  3.  
  4.   (defun nn_unique ( l )
  5.     (if l (cons (car l) (nn_unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
  6.   )
  7.  
  8.   (defun nn_mid ( p1 p2 )
  9.     (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2)
  10.   )
  11.  
  12.   (defun nn_clockwisep ( p1 p2 p3 )
  13.     (minusp (sin (- (angle p1 p3) (angle p1 p2))))
  14.   )
  15.  
  16.   (defun nn_insidep ( pt ent / nn_unit nn_pmuld nn_groupbynum fd1 fd2 par lst nrm obj tmp )
  17.  
  18.     (vl-load-com)
  19.  
  20.     (defun nn_unit ( v / d )
  21.       (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
  22.         (mapcar (function (lambda ( x ) (/ x d))) v)
  23.       )
  24.     )
  25.  
  26.     (defun nn_pmuld ( u v )
  27.       (list
  28.         (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
  29.         (- (* (caddr u) (car v)) (* (car u) (caddr v)))
  30.         (- (* (car u) (cadr v)) (* (cadr u) (car v)))
  31.       )
  32.     )
  33.  
  34.     (defun nn_groupbynum ( l n / r )
  35.       (if l
  36.         (cons (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r)) (nn_groupbynum l n))
  37.       )
  38.     )
  39.  
  40.     (if (= (type ent) 'VLA-OBJECT)
  41.       (setq obj ent
  42.             ent (vlax-vla-object->ename ent))
  43.       (setq obj (vlax-ename->vla-object ent))
  44.     )
  45.  
  46.     (if (vlax-curve-isplanar ent)
  47.       (progn
  48.         (setq fd1 (vlax-curve-getfirstderiv ent (setq par (vlax-curve-getstartparam ent))))
  49.         (while (or (equal fd1 (setq fd2 (vlax-curve-getfirstderiv ent (setq par (+ par 0.001)))) 1e-3) (null (setq nrm (nn_unit (nn_pmuld fd1 fd2))))))
  50.         (setq lst
  51.           (nn_groupbynum
  52.             (vlax-invoke
  53.               (setq tmp
  54.                 (vlax-ename->vla-object
  55.                   (entmakex
  56.                     (list
  57.                       (cons 0 "RAY")
  58.                       (cons 100 "AcDbEntity")
  59.                       (cons 100 "AcDbRay")
  60.                       (cons 10 pt)
  61.                       (cons 11 (trans '(1. 0. 0.) nrm 0))
  62.                     )
  63.                   )
  64.                 )
  65.               )
  66.               'IntersectWith obj acextendnone
  67.             ) 3
  68.           )
  69.         )
  70.         (vla-delete tmp)
  71.         ;; gile:
  72.         (and
  73.           lst
  74.           (not (vlax-curve-getparamatpoint ent pt))
  75.           (= 1 (rem (length (vl-remove-if (function (lambda ( p / pa p- p+ p0 )
  76.                                                       (setq pa (vlax-curve-getparamatpoint ent p))
  77.                                                       (and (setq p- (cond ((setq p- (vlax-curve-getPointatParam ent (- pa 1e-8)))
  78.                                                                            (trans p- 0 nrm)
  79.                                                                           )
  80.                                                                           ((trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-8)) 0 nrm)
  81.                                                                           )
  82.                                                                     )
  83.                                                            )
  84.                                                            (setq p+ (cond ((setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-8)))
  85.                                                                            (trans p+ 0 nrm)
  86.                                                                           )
  87.                                                                           ((trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-8)) 0 nrm)
  88.                                                                           )
  89.                                                                     )
  90.                                                            )
  91.                                                            (setq p0 (trans pt 0 nrm))
  92.                                                            (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
  93.                                                       )
  94.                                                     )
  95.                                           ) lst
  96.                             )
  97.                     ) 2
  98.                )
  99.           )
  100.         )
  101.       )
  102.     )
  103.   )
  104.  
  105.   (defun nn_processpla ( pla / ipl pla1 pla2 )
  106.     (setq pla1 pla)
  107.     (foreach p1 pla1
  108.       (setq pla2 (vl-remove p1 pla1))
  109.       (foreach p2 pla2
  110.         (setq ipl (cons (inters (car p1) (polar (car p1) (cadr p1) 1.0) (car p2) (polar (car p2) (cadr p2) 1.0) nil) ipl))
  111.       )
  112.     )
  113.     (setq ipl (vl-remove-if-not (function (lambda ( p ) (nn_insidep p lw))) (vl-remove nil ipl)))
  114.   )
  115.  
  116.   (defun nn_distp2t ( p tt )
  117.     (distance p (inters p (polar p (+ (angle (car tt) (cadr tt)) (* 0.5 pi)) 1.0) (car tt) (cadr tt) nil))
  118.   )
  119.  
  120.   (defun nn_removesingles ( l / a )
  121.     (while (setq a (vl-some (function (lambda ( x ) (if (= (1- (length l)) (length (vl-remove-if (function (lambda ( y ) (equal x y 1e-6))) l))) x))) l))
  122.       (setq l (vl-remove a l))
  123.     )
  124.     l
  125.   )
  126.  
  127.   (defun nn_findipinterschilds ( ip pla / pla1 pla2 r )
  128.     (setq pla1 pla)
  129.     (foreach p1 pla1
  130.       (setq pla2 (vl-remove p1 pla1))
  131.       (foreach p2 pla2
  132.         (if (equal ip (inters (car p1) (polar (car p1) (cadr p1) 1.0) (car p2) (polar (car p2) (cadr p2) 1.0) nil) 1e-6)
  133.           (setq r (list p1 p2))
  134.         )
  135.       )
  136.     )
  137.     r
  138.   )
  139.  
  140.   (defun nn_processtxtipl ( tl / ipl tl1 tl2 )
  141.     (setq tl1 tl)
  142.     (foreach t1 tl1
  143.       (setq tl2 (vl-remove t1 tl1))
  144.       (foreach t2 tl2
  145.         (setq ipl (cons (inters (car t1) (polar (car t1) (angle (car t1) (cadr t1)) 1.0) (car t2) (polar (car t2) (angle (car t2) (cadr t2)) 1.0) nil) ipl))
  146.       )
  147.     )
  148.     (setq ipl (vl-remove nil ipl))
  149.   )
  150.  
  151.   (defun nn_prefetch nil
  152.     (if ip
  153.       (setq p1p2 (nn_findipinterschilds ip pla))
  154.       (setq p1p2 nil)
  155.     )
  156.     (setq f nil)
  157.     (if p1p2
  158.       (progn
  159.         (setq tt (vl-some (function (lambda ( x ) (if (and (assoc (car x) p1p2) (assoc (cadr x) p1p2)) (progn (setq f t) x)))) tlo))
  160.         (if (or (vl-some (function (lambda ( x ) (equal (distance ip (car (car p1p2))) (+ (distance ip x) (distance x (car (car p1p2)))) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x (car (car p1p2)) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x ip 1e-6))) (mapcar (function car) ipldtl)))) (vl-some (function (lambda ( x ) (equal (distance ip (car (cadr p1p2))) (+ (distance ip x) (distance x (car (cadr p1p2)))) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x (car (cadr p1p2)) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x ip 1e-6))) (mapcar (function car) ipldtl)))))
  161.           (setq f nil)
  162.         )
  163.       )
  164.     )
  165.   )
  166.  
  167.   (defun nn_positionvl ( e l tol / nn_car_vlmember_if )
  168.     (defun nn_car_vlmember_if ( f l / ff r )
  169.       (setq ff (function (lambda ( x ) (if (apply f (list x)) (setq r x)))))
  170.       (vl-some ff l)
  171.       r
  172.     )
  173.     (vl-position (nn_car_vlmember_if (function (lambda ( x ) (equal e x tol))) l) l)
  174.   )
  175.  
  176.   (defun nn_carsort ( lst cmp / rtn )
  177.     (setq rtn (car lst))
  178.     (foreach itm (cdr lst)
  179.       (if (apply cmp (list itm rtn))
  180.         (setq rtn itm)
  181.       )
  182.     )
  183.     rtn
  184.   )
  185.  
  186.   (defun nn_car_vlmember_if ( f l / ff r )
  187.     (setq ff (function (lambda ( x ) (if (apply f (list x)) (setq r x)))))
  188.     (vl-some ff l)
  189.     r
  190.   )
  191.  
  192.  
  193. ;;; main 2droof ;;;
  194.  
  195.   (setq lw (car (entsel "\nPick a closed polygon : ")))
  196.   (setq ti (car (_vl-times)))
  197.   (setq n (cdr (assoc 90 (entget lw))))
  198.   (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw))))
  199.   (setq tl (mapcar (function (lambda ( a b ) (list a b))) pl (append (cdr pl) (list (car pl)))))
  200.   (setq tlo tl)
  201.   (setq pla (mapcar (function (lambda ( p mp ) (list p (angle p mp)))) pl (mapcar (function (lambda ( a b ) (if (nn_clockwisep (car a) (car b) (cadr b)) (nn_mid (polar (cadr a) (angle (cadr a) (car a)) -1.0) (polar (car b) (angle (car b) (cadr b)) -1.0)) (nn_mid (polar (cadr a) (angle (cadr a) (car a)) 1.0) (polar (car b) (angle (car b) (cadr b)) 1.0))))) (cons (last tl) tl) tl)))
  202.   (setq plaa pla)
  203.   (while (> n 0)
  204.     (if (null ipll)
  205.       (setq ipl (nn_unique (nn_processpla plaa)))
  206.       (setq ipl (nn_unique (nn_processpla (nn_unique pla))))
  207.     )
  208.     (if (equal ipl iplo 1e-6)
  209.       (setq n 0)
  210.     )
  211.     (if fff
  212.       (progn
  213.         (setq pl (mapcar (function car) pla))
  214.         (foreach x pl
  215.           (setq lil (cons (list x ip) lil))
  216.         )
  217.         (setq n 0)
  218.       )
  219.       (progn
  220.         (setq ipldtl (mapcar (function (lambda ( p ) (list p (vl-sort (mapcar (function (lambda ( tt ) (nn_distp2t p tt))) tlo) (function <))))) ipl))
  221.         (setq ipldtl (mapcar (function (lambda ( x ) (list (car x) (nn_removesingles (cadr x))))) ipldtl))
  222.         (setq ipldtl (vl-remove-if (function (lambda ( x ) (< (- (length (cadr x)) (length (vl-remove-if (function (lambda ( y ) (equal y (car (cadr x)) 1e-6))) (cadr x)))) 3))) ipldtl))
  223.         (if ipll
  224.           (setq ipldtl (vl-remove-if (function (lambda ( x ) (nn_positionvl (car x) ipll 1e-6))) ipldtl))
  225.         )
  226.         (if (null ipll)
  227.           (setq ipldtlo ipldtl)
  228.         )
  229.         (setq ip (car (nn_carsort (nn_unique (append ipldtl ipldtlo)) (function (lambda ( a b ) (< (car (cadr a)) (car (cadr b))))))))
  230.         (setq ipldtlo (vl-remove-if (function (lambda ( x ) (equal (car x) ip 1e-6))) ipldtlo))
  231.         (setq ipp nil)
  232.         (if (progn (nn_prefetch) (not f))
  233.           (if ipll
  234.             (progn
  235.               (foreach y (reverse pal)
  236.                 (setq ipp (cons (vl-remove-if-not (function (lambda ( x ) (vl-some (function (lambda ( a ) (or (equal (rem (+ a pi) (* 2 pi)) (angle (car y) x) 1e-6) (equal a (angle (car y) x) 1e-6)))) (cadr y)))) (mapcar (function car) (vl-sort ipldtl (function (lambda ( a b ) (> (car (cadr a)) (car (cadr b)))))))) ipp))
  237.               )
  238.               (setq ipp (apply (function append) ipp))
  239.               (if p1p2
  240.                 (setq ipp (cons ip ipp))
  241.               )
  242.               (setq ipp (nn_unique ipp))
  243.               (setq ipp (mapcar (function (lambda ( p ) (list p (nn_findipinterschilds p pla)))) ipp))
  244.               (setq ipp (vl-remove-if (function (lambda ( x ) (null (cadr x)))) ipp))
  245.               (setq ipp (vl-remove-if (function (lambda ( x ) (or (vl-some (function (lambda ( y ) (equal (distance (car x) (car (car (cadr x)))) (+ (distance (car x) y) (distance y (car (car (cadr x))))) 1e-6))) (vl-remove-if (function (lambda ( z ) (equal z (car (car (cadr x))) 1e-6))) (vl-remove-if (function (lambda ( z ) (equal z (car x) 1e-6))) (mapcar (function car) ipldtl)))) (vl-some (function (lambda ( y ) (equal (distance (car x) (car (cadr (cadr x)))) (+ (distance (car x) y) (distance y (car (cadr (cadr x))))) 1e-6))) (vl-remove-if (function (lambda ( z ) (equal z (car (cadr (cadr x))) 1e-6))) (vl-remove-if (function (lambda ( z ) (equal z (car x) 1e-6))) (mapcar (function car) ipldtl)))) (vl-some (function (lambda ( y / ii ) (and (setq ii (inters (car x) (car (car (cadr x))) (car y) (cadr y) t)) (not (equal ii (car x) 1e-6)) (not (equal ii (car (car (cadr x))) 1e-6)) (not (equal ii (car y) 1e-6)) (not (equal ii (cadr y) 1e-6))))) (append tlo lil)) (vl-some (function (lambda ( y / ii ) (and (setq ii (inters (car x) (car (cadr (cadr x))) (car y) (cadr y) t)) (not (equal ii (car x) 1e-6)) (not (equal ii (car (cadr (cadr x))) 1e-6)) (not (equal ii (car y) 1e-6)) (not (equal ii (cadr y) 1e-6))))) (append tlo lil))))) ipp))
  246.               (setq dl (mapcar (function (lambda ( y ) (car (cadr (nn_car_vlmember_if (function (lambda ( x ) (equal (car x) y 1e-6))) ipldtl))))) (mapcar (function car) ipp)))
  247.               (if dl
  248.                 (setq ip (car (nth (vl-position (nn_carsort dl (function <)) dl) ipp)))
  249.               )
  250.             )
  251.           )
  252.         )
  253.         (if (vl-every (function (lambda ( x ) (equal ip (inters (car (car pla)) (polar (car (car pla)) (cadr (car pla)) 1.0) (car x) (polar (car x) (cadr x) 1.0) nil) 1e-6))) (cdr pla))
  254.           (setq fff t)
  255.         )
  256.         (setq d (car (cadr (nn_car_vlmember_if (function (lambda ( x ) (equal (car x) ip 1e-6))) (nn_unique (append ipldtl ipldtlo))))))
  257.         (setq al nil a nil)
  258.         (nn_prefetch)
  259.         (if (null p1p2)
  260.           (setq ip nil)
  261.         )
  262.         (if (and tt f)
  263.           (progn
  264.             (setq tl (vl-remove tt tl))
  265.             (setq n (1- n))
  266.           )
  267.         )
  268.         (if f
  269.           (progn
  270.             (setq t1 (vl-some (function (lambda ( x ) (if (or (assoc (car x) (list (car p1p2))) (assoc (cadr x) (list (car p1p2)))) x))) tl))
  271.             (setq t2 (vl-some (function (lambda ( x ) (if (or (assoc (car x) (list (cadr p1p2))) (assoc (cadr x) (list (cadr p1p2)))) x))) tl))
  272.           )
  273.           (setq t1 nil t2 nil)
  274.         )
  275.         (if ip
  276.           (setq ipll (cons ip ipll))
  277.         )
  278.         (if (and t1 t2 ip)
  279.           (progn
  280.             (setq a (angle (inters (car t1) (cadr t1) (car t2) (cadr t2) nil) ip))
  281.             (if a
  282.               (progn
  283.                 (setq pla (cons (list ip a) pla))
  284.                 (setq pla (vl-remove (car p1p2) pla) pla (vl-remove (cadr p1p2) pla))
  285.                 (setq lil (cons (list (car (car p1p2)) ip) lil))
  286.                 (setq lil (cons (list (car (cadr p1p2)) ip) lil))
  287.                 (setq pal (cons (list ip (list a)) pal))
  288.               )
  289.             )
  290.           )
  291.           (if (and ip (null fff))
  292.             (progn
  293.               (setq lil (cons (list (car (car p1p2)) ip) lil))
  294.               (setq lil (cons (list (car (cadr p1p2)) ip) lil))
  295.               (if (setq p (vl-some (function (lambda ( x ) (if (vl-position x plaa) x))) p1p2))
  296.                 (progn
  297.                   (setq n (1- n))
  298.                   (setq tll (vl-remove-if-not (function (lambda ( x ) (vl-some (function (lambda ( y ) (nn_positionvl p y 1e-6))) x))) tlo))
  299.                   (setq tll (car (vl-remove-if-not (function (lambda ( x ) (and (nn_positionvl (car x) (vl-remove nil (mapcar (function car) lil)) 1e-6) (nn_positionvl (cadr x) (vl-remove nil (mapcar (function car) lil)) 1e-6)))) tll)))
  300.                   (setq tl (vl-remove tll tl))
  301.                 )
  302.               )
  303.               (setq tll (vl-remove-if-not (function (lambda ( x ) (equal d (nn_distp2t ip x) 1e-6))) tl))
  304.               (setq txtipl (nn_processtxtipl tll))
  305.               (setq txtipl (vl-remove-if (function (lambda ( x ) (nn_positionvl x pl 1e-6))) txtipl))
  306.               (setq al (mapcar (function (lambda ( p ) (angle p ip))) txtipl))
  307.               (setq al (vl-remove-if (function (lambda ( x ) (nn_positionvl x (mapcar (function cadr) p1p2) 1e-6))) al))
  308.               (setq al (nn_unique al))
  309.               (if al
  310.                 (progn
  311.                   (setq pla (append pla (mapcar (function (lambda ( a ) (list ip a))) al)))
  312.                   (setq pal (cons (list ip al) pal))
  313.                 )
  314.               )
  315.               (setq pla (vl-remove (car p1p2) pla) pla (vl-remove (cadr p1p2) pla))
  316.             )
  317.           )
  318.         )
  319.       )
  320.     )
  321.     (setq iplo ipl)
  322.   )
  323.   (setq lil (vl-remove-if (function (lambda ( x ) (equal (car x) (cadr x) 1e-6))) lil))
  324.   (setq lil (nn_unique lil))
  325.   (setq lil (vl-remove-if (function (lambda ( x ) (vl-some (function (lambda ( y ) (null y))) x))) lil))
  326.   (setq lipl (apply (function append) lil))
  327.   (setq lipl (nn_unique (vl-remove-if (function (lambda ( x ) (or (= (length (vl-remove x lipl)) (1- (length lipl))) (= (length (vl-remove x lipl)) (- (length lipl) 3))))) lipl)))
  328.   (if lipl
  329.     (setq lil (cons (list (car lipl) (cadr lipl)) lil))
  330.   )
  331.   (foreach li lil
  332.     (entmake (list '(0 . "LINE") (cons 10 (car li)) (cons 11 (cadr li))))
  333.   )
  334.   (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  335.   (princ)
  336. )
  337.  

ribarm

  • Water Moccasin
  • Posts: 2454
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #186 on: January 08, 2021, 02:13:45 PM »
@d2010, I've revised my last code, so perhaps you'll have to revise your too...
Sorry for inconvenience...
M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

d2010

  • Newt
  • Posts: 125
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #187 on: January 08, 2021, 05:38:49 PM »
In my BrisCad2020 x86 , your-program failed to work.
 :reallysad:
@d2010, I've revised my last code, so perhaps you'll have to revise your too...
Sorry for inconvenience...
M.R.
« Last Edit: January 08, 2021, 05:47:45 PM by d2010 »

ronjonp

  • Needs a day job
  • Posts: 7216
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #188 on: January 08, 2021, 11:51:59 PM »
In my BrisCad2020 x86 , your-program failed to work.
 :reallysad:
@d2010, I've revised my last code, so perhaps you'll have to revise your too...
Sorry for inconvenience...
M.R.
Your post is very strange.  :?

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC

ribarm

  • Water Moccasin
  • Posts: 2454
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #189 on: January 09, 2021, 12:50:33 AM »
My BricsCAD did ultimate roof at approx. 13 min...

Here is picture :

Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2454
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #190 on: January 11, 2021, 01:53:17 PM »
On this example, my code is wrong and 2droof-final.lsp from zip I posted finds solution (ch_lhjd's code) - though after iterations of checking...

:(
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2454
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #191 on: January 13, 2021, 05:03:49 AM »
I've debugged last posted DWG example and this is version I use now...

M.R.

[EDIT : LSP file removed due to lack of interest for download...]
« Last Edit: January 21, 2021, 01:09:05 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 2454
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #192 on: January 13, 2021, 05:08:50 AM »
Still there is another example, where AutoCAD crashed from normal mode - unhandeled exception occurred (CX000, bla, bla, bla,...) and from VLIDE - debugging mode, it passed... I wonder is it my PC machines (very low hardware performances, low RAM, or something...) From BricsCAD it worked well...

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

BIGAL

  • Swamp Rat
  • Posts: 581
  • 30 + years of using Autocad
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #193 on: January 13, 2021, 07:54:23 PM »
I tried it on Bricscad V19 works great maybe 1 suggestion use acet-progress-bar function so looks like something happening maybe use the vertice number.

So would have like 1-44. Just did 10 vertice it was instant a more typical shape, so would not be needed maybe around 20+ vertice.

Code: [Select]
;; EXAMPLE LISP SHORT VERSION OF PROGRESS-BAR

(defun progressbar (a b c d)
(cond ((= 0 a)
(acet-ui-progress-init d 100)
(setq c 0)
)
((= 1 a)
(setq c (+ (/ 100.0 b) c))
(acet-ui-progress-safe c)
)
((= 2 a)
(acet-ui-progress-done)
)
)
c
)


(setq repeatvariable 45) ; 45 just a sample number
(setq progress (Progressbar 0 repeatvariable progress "Processing:")) ;Create the progress bar, total length is repeatvariable or 10000
(repeat repeatvariable
(setq progress (Progressbar 1 repeatvariable progress ""))
(alert "press") ; code goes here
)
(Progressbar 2 0 0 "") ;arg(a) is set to 2 to close the progress bar, arg (b), (c) & (d) can be blanks
« Last Edit: January 13, 2021, 08:04:12 PM by BIGAL »
A man who never made a mistake never made anything

ribarm

  • Water Moccasin
  • Posts: 2454
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #194 on: January 13, 2021, 11:33:15 PM »
@BIGAL, thanks for suggestion and review...
I have to inform you that I had typo on one place - should be tree1 and not tree2, and plus, it should be (vl-remove-if-not ... ) and not (vl-remove-if ... )... I reattached corrected version. IMHO it's now good, but you'll never know - I mod. it at least 10 times and it was always something stupid...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube