Author Topic: [challenge ] A34 hatch area total list  (Read 712 times)

0 Members and 1 Guest are viewing this topic.

BIGAL

  • Swamp Rat
  • Posts: 1037
  • 40 + years of using Autocad
[challenge ] A34 hatch area total list
« on: March 15, 2022, 05:55:40 AM »
I had a look but could not find anything, the question is sum the areas of hatch but for multiple layers, so its a 2 item list, need either  a sub list of common 1st item or totals as a list (item1 tot)(item2 tot) This is a often asked type task could be common shapes with plines.

An example list it has been sorted if that helps.
(("ANSI31" 36.8678417158616) ("ANSI31" 56.0686416358776) ("ANSI31" 26.6) ("BLOCKS" 36.8678417158616) ("BLOCKS" 26.6) ("BLOCKS" 36.2241153739494) ("SOLID" 28.1248709943797) ("SOLID" 36.8678417158616) ("SOLID" 26.6) ("SOLID" 23.24))

so
(("Ansi131" totarea1)("BLOCKS" totarea2)("SOLID" totarea 3))
or
((("ANSI31" 36.8678417158616) ("ANSI31" 56.0686416358776) ("ANSI31" 26.6))(("BLOCKS" 36.8678417158616) ("BLOCKS" 26.6) ("BLOCKS" 36.2241153739494))( ("SOLID" 28.1248709943797) ("SOLID" 36.8678417158616) ("SOLID" 26.6) ("SOLID" 23.24)))
A man who never made a mistake never made anything

kirby

  • Newt
  • Posts: 110
Re: [challenge ] A34 hatch area total list
« Reply #1 on: March 15, 2022, 11:40:04 AM »
Thanks, brain needed a break after A33.

May not return entirely as requested.  Output returns count of hatch entities and total area, by layer and/or by pattern.

Test drawing with 3 layers and 3 hatch patterns attached.

Code - Auto/Visual Lisp: [Select]
  1. (defun C:TestHA (/ MySet Ans)
  2. ; Test routine for 'HatchAreas-kirby'
  3. ; Creates global OptWhatOutput
  4. ; Uses custom functions:
  5. ;       getoption
  6. ;       hatchareas-kirby
  7.  
  8. (prompt "\nSelect some entities to summarize hatch areas...")(princ)
  9. (setq MySet (ssget))
  10.  
  11. (if (not (member OptWhatOutput (list 0 1 2 3))) (setq OptWhatOutput 1))
  12. (setq OptWhatOutput (getoption "I" "Output 0-dump all  1-summary by layer and pattern  2-by layer  3-by pattern (0-3) " OptWhatOutput (list 0 1 2 3)))
  13.  
  14. (setq Ans (hatchareas-kirby MySet OptWhatOutput))
  15.  
  16. ; Quick and dirty output
  17.         ((eq OptWhatOutput 0)
  18.           (progn
  19.                 (prompt "\nResult = ")(princ Ans)
  20.           )
  21.         )
  22.         ((eq OptWhatOutput 1)
  23.           (progn
  24.                 (prompt "\n  Layers = ")(princ (nth 0 Ans))(prompt "  Patterns = ")(princ (nth 1 Ans))
  25.                 (prompt "\n  Outout Matrix = ")
  26.  
  27.                 ; dump one row at a time (Patterns in rw)
  28.                 (setq CNT 0)
  29.                 (repeat (length (nth 2 Ans))
  30.                         (prompt "\n    Layer = ")(princ (nth CNT (nth 0 Ans)))(prompt "  Results by pattern = ")(princ (nth CNT (nth 2 Ans)))
  31.                         (princ)
  32.                         (setq CNT (1+ CNT))
  33.                 ) ; close repeat       
  34.                
  35.                 (prompt "\n  Totals by Layer = ")(princ (nth 3 Ans))
  36.                 (prompt "\n  Totals by Pattern = ")(princ (nth 4 Ans))
  37.           )
  38.         )
  39.         ((eq OptWhatOutput 2)
  40.           (progn
  41.                 (prompt "\n  Totals by Layer = ")(princ Ans)
  42.           )
  43.         )      
  44.         ((eq OptWhatOutput 3)
  45.           (progn
  46.                 (prompt "\n  Totals by Pattern = ")(princ Ans)
  47.           )
  48.         )      
  49. ) ; close cond 
  50.  
  51.  
  52. ; next steps report overall total, build table of output, or save to csv file...
  53.  
  54. )
  55.  
  56.  
  57.  
  58. (defun HatchAreas-kirby (MySet RetCode /
  59.                         ;OutList CNT MyEnt EntData EntType MyLayer MyPattern MyArea MyLayerList MyPatternList
  60.                         ;MyItem ullValue RowList TotalList RowID ColID NewCount NewTotal
  61.                         ;LayerOutList MyCount MyTotalArea CNT1 CNt2 PatternOutList
  62.                         )
  63. ; Challenge A34 - Hatch area list
  64. ; Input:
  65. ;       MySet - (selection set) set of entities.
  66. ;       ByLayer - (integer) code 0 ot nil to ignore layer, 1 to also summarize by layer
  67. ;       ByPattern - (integer) code 0 or nil to ignore pattern, 1 to also summarize by hatch pattern name
  68. ;       RetCode - (integer) code indicating what to return
  69. ;                       0 or nil =  dump entire list
  70. ;                       1 = return matrix of counts and areas by Pattern and Layer
  71. ;                       2 = return counts and areas by Layer
  72. ;                       3 = return counts and areas by Pattern
  73. ; Returns:
  74. ;       lists as indicated by RetCode
  75. ; Uses custom functions:
  76. ;       uniquesublist
  77. ;       replace1
  78.  
  79. (if (not RetCode) (setq RetCode 0))
  80.  
  81. (setq OutList nil)
  82.  
  83. (if (> (sslength MySet) 0)
  84.   (progn
  85.  
  86.         (setq CNT 0)
  87.         (repeat (sslength MySet)
  88.                 (setq MyEnt (ssname MySet CNT))
  89.                 (setq EntData (entget MyEnt))
  90.  
  91.                 (setq EntType (strcase (cdr (assoc 0 EntData))))
  92.  
  93.                 (if (eq EntType "HATCH")
  94.                   (progn
  95.                         (setq MyLayer (strcase (cdr (assoc 8 EntData))))
  96.                         (setq MyPattern (cdr (assoc 2 EntData)))
  97.                         (setq MyArea (vlax-get (vlax-ename->vla-object MyEnt) 'area))   ; Cheat!, avoid multi polyline gymnastics
  98.  
  99.                         ;(prompt "\nCNT = ")(princ CNT)(prompt "  Layer = ")(princ MyLayer)(prompt "  Pattern = ")(princ MyPattern)(prompt "  Area = ")(princ MyArea)(princ)
  100.  
  101.  
  102.                         ; Build list of (0-Ename 1-Layer 2-Pattern 3-Area)
  103.                         (setq OutList (cons (list MyEnt MyLayer MyPattern MyArea) OutList))
  104.                   )    
  105.                 ) ; close if
  106.  
  107.                 (setq CNT (1+ CNT))
  108.         ) ; close repeat
  109.         (setq OutList (reverse OutList))
  110.        
  111.   )
  112. ) ; close if
  113.  
  114. ; Get sorted lists of layer and pattern names using custom function
  115. (setq MyLayerList (uniquesublist OutList 1 1))
  116. (setq MyPatternList (uniquesublist OutList 2 1))
  117.  
  118. ;(prompt "\n  Layers = ")(princ MyLayerList)(prompt "  Patterns = ")(princ MyPatternList)(princ)
  119.  
  120.  
  121. ; Build matrix to hold Pattern and Layer totals
  122. (setq NullValue (list 0 0.0))           ; initialize elements (0-Count 1-Total Area)
  123.  
  124. ; Initialize Sublist / Row for each pattern
  125. (setq RowList nil)
  126. (repeat (length MyPatternList)
  127.         (setq RowList (cons NullValue RowList))         ; contents = NullValue for each pattern
  128. )
  129.  
  130. ;(prompt "\nRow List = ")(princ RowList)(princ)
  131.  
  132. ; Initialize List / Column for each layer
  133. (setq TotalList nil)
  134. (repeat (length MyLayerList)
  135.         (setq TotalList (cons RowList TotalList))       ; contents = sublists of null values for each layer
  136. )
  137.  
  138. ;(prompt "\nTotal List = ")(princ TotalList)(princ)
  139.  
  140.  
  141. ; Populate matrix with counts and area totals
  142. (setq CNT 0)
  143. (repeat (length OutList)
  144.         (setq MyItem (nth CNT OutList))
  145.         (setq MyLayer (nth 1 MyItem))
  146.         (setq MyPattern (nth 2 MyItem))
  147.         (setq MyArea (nth 3 MyItem))
  148.        
  149.         ; Get matrix positions
  150.         (setq ColID (vl-position MyLayer MyLayerList))          ; index of pattern
  151.         (setq RowID (vl-position MyPattern MyPatternList))      ; index of layer
  152.        
  153.         ; Increment count and total area
  154.         (setq NewCount (1+ (nth 0 (nth RowID (nth ColID TotalList)))))
  155.         (setq NewTotal (+ MyArea (nth 1 (nth RowID (nth ColID TotalList)))))
  156.        
  157.         ; Update row
  158.         (setq RowList (replace1 (nth ColID TotalList) RowID (list NewCount NewTotal)))
  159.         ;(prompt "\n  Row List = ")(princ RowList)(princ)
  160.         ; Update matrix
  161.         (setq TotalList (replace1 TotalList ColID RowList))
  162.         ;(prompt "\n  Total List = ")(princ TotalList)(princ)
  163.        
  164.         (setq CNT (1+ CNT))
  165. ) ; close repeat       
  166.  
  167. ; Total by Layer
  168. (setq LayerOutList nil)
  169.  
  170. (setq CNT1 0)
  171. (repeat (length MyLayerList)
  172.        
  173.         (setq MyCount 0)
  174.         (setq MyTotalArea 0.0)
  175.        
  176.         (setq CNT2 0)
  177.         (repeat (length MyPatternList)
  178.                 (setq MyItem (nth CNT2 (nth CNT1 TotalList)))
  179.                 (setq MyCount (+ MyCount (nth 0 MyItem)))
  180.                 (setq MyTotalArea (+ MyTotalArea (nth 1 MyItem)))
  181.                
  182.                 (setq CNT2 (1+ CNT2))
  183.         ) ; close repeat       
  184.  
  185.         ; Build layer output list with sublist elements (0-LayerName 1-Count 2-Total Area)
  186.         (setq LayerOutList (cons (list (nth CNT1 MyLayerList) MyCount MyTotalArea) LayerOutList))
  187.  
  188.         (setq CNT1 (1+ CNT1))
  189. ) ; close repeat
  190. (setq LayerOutList (reverse LayerOutList))
  191.  
  192.  
  193. ; Total by Pattern
  194. (setq PatternOutList nil)
  195.  
  196. (setq CNT1 0)
  197. (repeat (length MyPatternList)
  198.        
  199.         (setq MyCount 0)
  200.         (setq MyTotalArea 0.0)
  201.        
  202.         (setq CNT2 0)
  203.         (repeat (length MyLayerList)
  204.                 (setq MyItem (nth CNT1 (nth CNT2 TotalList)))
  205.                 (setq MyCount (+ MyCount (nth 0 MyItem)))
  206.                 (setq MyTotalArea (+ MyTotalArea (nth 1 MyItem)))
  207.                
  208.                 (setq CNT2 (1+ CNT2))
  209.         ) ; close repeat       
  210.  
  211.         ; Build layer output list with sublist elements (0-LayerName 1-Count 2-Total Area)
  212.         (setq PatternOutList (cons (list (nth CNT1 MyPatternList) MyCount MyTotalArea) PatternOutList))
  213.  
  214.         (setq CNT1 (1+ CNT1))
  215. ) ; close repeat       
  216. (setq PatternOutList (reverse PatternOutList))
  217.  
  218. ; Return results according to RetCode
  219.         ; if RetCode = 0, just return Outlist
  220.         ((eq RetCode 1)
  221.                 ; Return list of 5 elements (0-MyLayerNames 1-MyPatternNames 2-Data 3-LayerTotals 4-PatternTotals)
  222.                 ; where data is 2D Matrix of (0-Count 1-Total Area) elements, compiled as sublist by Pattern name, then by Layer name
  223.                 ; e.g. (   (Lyr0Pat0 Lyr0Pat1 Lyr0Pat2) (Lyr1Pat0 Lyr1Pat1 Lyr1Pat2) (Lyr2Pat0 Lyr2Pat1 Lyr2Pat2) (Lyr3Pat0 Lyr3Pat1 Lyr3Pat2) )
  224.                                
  225.                 (setq OutList (list MyLayerList MyPatternList TotalList LayerOutList PatternOutList))
  226.         )
  227.         ((eq RetCode 2)
  228.                 ; Totals by layer
  229.                 (setq OutList LayerOutList)
  230.         )
  231.         ((eq RetCode 3)
  232.                 ; Totals by pattern
  233.                 (setq OutList PatternOutList)
  234.         )      
  235. ) ; close cond
  236.  
  237. OutList
  238. )
  239.  
  240.  
  241.  
  242. (defun UniqueSubList (MyList Pos RetCode / OutList CNT MyItem)
  243. ; Make a unique (no duplicates) list of elements from a nested list
  244. ; KJM - May 1990, Mod KJM 2002
  245. ; Input:
  246. ;       MyList - (list) a list containing sublists.  Only single depth of nesting is considered
  247. ;       Pos - (integer) position of interest is in a sublist, ignored if MyList does not contain sublists.  Normal 0 based lisp index.
  248. ;       RetCode - (integer) code.  0 or nil to return elements as encountered, 1 to return sorted elements
  249. ; Returns:
  250. ;       List of unique items (duplicated are deleted)
  251. ;       Strings made uppercase
  252.  
  253. (setq OutList nil)
  254.  
  255. (setq CNT 0)
  256. (repeat (length MyList)
  257.         (setq MyItem (nth CNT MyList))
  258.  
  259.         (if (eq (type MyItem) 'List)
  260.           (progn
  261.                 (setq MyItem (nth Pos MyItem))          ; get subitem
  262.                
  263.                 (if (eq (type MyItem) 'STR)
  264.                         (setq MyItem (strcase MyItem))          ; if a string, make uppercase
  265.                 )      
  266.                
  267.                 (if (not (member MyItem OutList))
  268.                         (setq OutList (cons MyItem OutList))    ; add to list, skip duplicates
  269.                 )
  270.           )
  271.         )
  272.        
  273.         (setq CNT (1+ CNT))
  274. ) ; close repeat
  275.  
  276.  
  277. (if (eq RetCode 1)
  278.         (setq OutList (vl-sort OutList '<))     ; ascending sort, replaced with vl-sort KJM Jan 2002
  279. )
  280.  
  281. OutList
  282. )
  283.  
  284.  
  285. (defun Replace1 (MyLIST POS ITEM / K CNT NEWLIST)
  286. ; Replace one item in a list with a new item
  287. ; KJM - 1990?
  288. ; Input:
  289. ;       MyList - a list
  290. ;       Pos - (integer) list index of item to be replaced (starting at 0)
  291. ;       Item - new item to replace existing (nth POS MYLIST).  May be a list
  292. ; Returns:
  293. ;       list with item replaced
  294.  
  295.         (setq K 1)
  296.         (setq CNT 0)
  297.         (setq NEWLIST nil)
  298.         (while K
  299.                 (if (= POS CNT)
  300.                   (progn
  301.                         (setq NEWLIST (cons ITEM NEWLIST))
  302.                         (setq K nil)
  303.                   )
  304.                   (setq NEWLIST (cons (nth CNT MyLIST) NEWLIST))
  305.                 )
  306.                 (setq CNT (1+ CNT))
  307.         )      
  308.         (repeat (- (length MyLIST) CNT)
  309.                 (setq NEWLIST (cons (nth CNT MyLIST) NEWLIST))
  310.                 (setq CNT (1+ CNT))
  311.         )
  312.         (setq NEWLIST (reverse NEWLIST))
  313.         NEWLIST
  314. )
  315.  
  316. (defun GetOption (DataType DataPrompt Default OptionList /
  317.                 Data DataOut K K1 Cnt Item Slen
  318.                 )
  319. ; Get Option, keeps trying until a valid member of OptionList is returned                      
  320. ; KJM 1990?                    
  321. ; Input:
  322. ;       DataType - (string, typ 1 char) desired type of value
  323. ;               where   "I" = integer
  324. ;                       "R" = Real
  325. ;                       "S" = String
  326. ;                       "P" = Point (or vector)
  327. ;       DataPrompt - (string) text prompt
  328. ;       Default - (integer or real) default value
  329. ;       OptionList - (list) list of valid values for response
  330. ; Returns
  331. ;       value of type specified by 'DataType' and member of list 'OptionList'
  332. ; Uses custom functions:
  333. ;       none!
  334.  
  335.                        
  336. (setq DataType (strcase (substr DataType 1 1)))
  337.  
  338. (setq K 1)
  339.         (prompt (strcat "\n" DataPrompt " <"))
  340.         (princ Default)(princ)
  341.         (cond
  342.                 ((= DataType "I")       ; Integer
  343.                   (progn
  344.                         (setq Data (getint ">: "))
  345.                         (if (= Data nil) (setq Data Default))
  346.                   )
  347.                 )
  348.                 ((= DataType "R")       ; Real
  349.                   (progn
  350.                         (setq Data (getreal ">: "))
  351.                         (if (= Data nil) (setq Data Default))
  352.                   )
  353.                 )
  354.                 ((= DataType "S")       ; String (with spaces)
  355.                   (progn
  356.                         (setq Data (getstring 1 ">: "))
  357.                         (if (= Data "") (setq Data Default))
  358.                   )
  359.                 )
  360.                 ((= DataType "P")       ; Point
  361.                   (progn
  362.                         (setq Data (getpoint ">: "))
  363.                         (if (= Data nil) (setq Data Default))
  364.                   )
  365.                 )
  366.         )
  367.  
  368.         (if (= DataType "S")
  369.           (progn
  370.                 ; Verify string data
  371.                 (setq CNT 0)
  372.                 (setq K1 1)
  373.                 (while K1
  374.                         (setq Item (nth Cnt OptionList))
  375.                         (setq Slen (strlen Item))
  376.                         (if (= (strcase Item) (strcase (substr Data 1 Slen)))
  377.                                 (setq DataOut Item K1 nil K nil)
  378.                         ) ; close if
  379.  
  380.                         (setq CNT (1+ CNT))
  381.  
  382.                         (if (>= CNT (length OptionList))
  383.                                 (setq K1 nil)
  384.                         ) ; close if
  385.                 ) ; close while
  386.           )
  387.           (progn
  388.                 ; verify other data
  389.  
  390.                 (if (member Data OptionList)
  391.                         (setq K nil DataOut Data)
  392.                 ) ; close if
  393.           )
  394.         ) ; close if
  395.  
  396.         (if (/= K nil)
  397.           (progn
  398.                 (prompt "\n  Valid responses are: ")
  399.  
  400.                 (setq CNT 0)
  401.                 (repeat (length OptionList)
  402.                         (setq Item (nth CNT OptionList))
  403.  
  404.                         (if (= (type Item) 'STR)
  405.                                 (prompt Item)
  406.                         )
  407.                         (if (= (type Item) 'INT)
  408.                                 (prompt (itoa Item))
  409.                         )
  410.                         (if (= (type Item) 'REAL)
  411.                                 (prompt (rtos Item))
  412.                         )
  413.                         (if (= (type Item) 'LIST)
  414.                                 (princ Item)
  415.                         )
  416.                        
  417.                         (if (< (1+ CNT) (length OptionList))
  418.                                 (prompt " , ")
  419.                         )
  420.  
  421.                         (setq CNT (1+ CNT))
  422.                 ) ; close repeat
  423.           )
  424.         ) ; close if
  425.  
  426.  
  427. ) ; close while
  428.  
  429. DataOut ; return data
  430. )
  431.  

ronjonp

  • Needs a day job
  • Posts: 7437
Re: [challenge ] A34 hatch area total list
« Reply #2 on: March 15, 2022, 04:27:43 PM »
Perhaps this:
Code - Auto/Visual Lisp: [Select]
  1. (defun _foo (l / k n r)
  2.   (setq l (vl-sort l '(lambda (r j) (> (car r) (car j)))))
  3.   (while (setq k (car l))
  4.     (setq l (cdr l)
  5.           n (cadr k)
  6.           k (car k)
  7.     )
  8.     (while (= k (caar l)) (setq n (+ n (cadr (car l)))) (setq l (cdr l)))
  9.     (setq r (cons (list k n) r))
  10.   )
  11. )
  12. (_foo '(("ANSI31" 36.8678417158616)
  13.         ("ANSI31" 56.0686416358776)
  14.         ("ANSI31" 26.6)
  15.         ("BLOCKS" 36.8678417158616)
  16.         ("BLOCKS" 26.6)
  17.         ("BLOCKS" 36.2241153739494)
  18.         ("SOLID" 28.1248709943797)
  19.         ("SOLID" 36.8678417158616)
  20.         ("SOLID" 26.6)
  21.         ("SOLID" 23.24)
  22.        )
  23. )
  24. ;;(("ANSI31" 119.536) ("BLOCKS" 99.692) ("SOLID" 114.833))

Windows 11 x64 - AutoCAD /C3D 2022

Custom Build PC

BIGAL

  • Swamp Rat
  • Posts: 1037
  • 40 + years of using Autocad
Re: [challenge ] A34 hatch area total list
« Reply #3 on: March 15, 2022, 08:19:45 PM »
Thank you ronjonp, I will keep this one a handy routine as I say comes up all the time

Completed code

Code: [Select]
; area of hatches, use layiso to isolate hatch name could be by layer etc
: By AlanH Mar 2022

; Thanks to ronjonp for area answer
http://www.theswamp.org/index.php?action=post;topic=57439.0;last_msg=609227

(vl-load-com)

(defun areahat (l / k n r)
  (setq l (vl-sort l '(lambda (r j) (> (car r) (car j)))))
  (while (setq k (car l))
    (setq l (cdr l)
          n (cadr k)
          k (car k)
    )
    (while (= k (caar l)) (setq n (+ n (cadr (car l)))) (setq l (cdr l)))
    (setq r (cons (list k n) r))
  )
)


(defun c:Totareahat ( / ss lst x obj areah nameh)
(setq ss (ssget '((0 . "HATCH"))))
(if (= ss nil)
  (princ "\nno hatches selected")
  (progn
    (setq lst '())
    (repeat (setq x (sslength ss))
      (setq obj (vlax-ename->vla-object (ssname ss (setq x (- x 1)))))
      (setq areah (vlax-get obj 'area))
     (setq nameh (vlax-get obj 'PatternName)) ; change to layer if required
     (setq lst (cons (list nameh areah) lst))
    )
  )
)

(setq arealst (areahat lst))

(princ)
)


A man who never made a mistake never made anything

pBe

  • Bull Frog
  • Posts: 401
Re: [challenge ] A34 hatch area total list
« Reply #4 on: March 16, 2022, 05:55:39 AM »
No sorting.
Code - Auto/Visual Lisp: [Select]
  1. (defun _grouped ( lst / a b c d v)
  2.   (while (setq a (Car lst))
  3.     (setq b (Car a) c (cdr lst) v 0)
  4.     (cond
  5.       ((assoc b d)      )
  6.       ((foreach itm c
  7.         (if (and (eq b (car itm))(not (member (car itm) d)))
  8.         (setq v (+ v (cadr itm)))) v)
  9.        (setq d (cons (list b (+ v (cadr a))) d))
  10.        )
  11.       )
  12.     (setq lst c)      
  13.     ) d
  14.   )

pBe

  • Bull Frog
  • Posts: 401
Re: [challenge ] A34 hatch area total list
« Reply #5 on: March 16, 2022, 10:03:14 AM »
Code - Auto/Visual Lisp: [Select]
  1. (defun _grouped2 ( lst / a b c d v g)
  2.   (while (setq a (Car lst))
  3.     (setq b (Car a) c (cdr lst) v 0)
  4.     (cond
  5.       ((assoc b d)      )
  6.       ((foreach itm c
  7.          (cond
  8.            ((member (car itm) d)        )
  9.            ((/= b (car itm)) (Setq g (cons itm g)))    
  10.            ((setq v (+ v (cadr itm)))
  11.             )
  12.            )
  13.          )
  14.        )
  15.       )
  16.       (setq d (cons (list b (+ v (cadr a))) d))
  17.       (setq lst g g nil)
  18.       )
  19.   d
  20.   )

kirby

  • Newt
  • Posts: 110
Re: [challenge ] A34 hatch area total list
« Reply #6 on: March 16, 2022, 11:36:13 AM »
Aww snap, I really overthought that one.

pBe

  • Bull Frog
  • Posts: 401
Re: [challenge ] A34 hatch area total list
« Reply #7 on: March 16, 2022, 12:29:44 PM »
Aww snap, I really overthought that one.

You're just thorough. I liked it.
It's really cool :)


dexus

  • Newt
  • Posts: 75
Re: [challenge ] A34 hatch area total list
« Reply #8 on: March 17, 2022, 04:32:07 AM »
I've made this code recently for a project.
This one has the option to input a starting point as the second variable so you can continue counting the area from a previous function.
I used it as a "database" for different types of blocks.
Code - Auto/Visual Lisp: [Select]
  1. (defun mapAdd (i l / x)
  2.   (while i
  3.     (cond
  4.       ((setq x (assoc (caar i) l))
  5.         (setq l (subst (cons (car x) (+ (cdr x) (cdar i))) x l))
  6.       )
  7.       ((caar i)
  8.         (setq l (cons (cons (caar i) (+ (cdar i))) l))
  9.       )
  10.     )
  11.     (setq i (cdr i))
  12.   )
  13.   l
  14. )

One catch though, it only works with dotted pairs:
Code - Auto/Visual Lisp: [Select]
  1. Command: (mapadd
  2.   '(
  3.     ("ANSI31" . 36.8678417158616)
  4.     ("ANSI31" . 56.0686416358776)
  5.     ("ANSI31" . 26.6)
  6.     ("BLOCKS" . 36.8678417158616)
  7.     ("BLOCKS" . 26.6)
  8.     ("BLOCKS" . 36.2241153739494)
  9.     ("SOLID" . 28.1248709943797)
  10.     ("SOLID" . 36.8678417158616)
  11.     ("SOLID" . 26.6)
  12.     ("SOLID" . 23.24)
  13.   )
  14.   '(
  15.     ("BLOCKS" . 500.0)
  16.   )
  17. )
  18. (("SOLID" . 114.833) ("BLOCKS" . 599.692) ("ANSI31" . 119.536))


Edit:
In case its not possible to get the data in dotted pairs beforehand, this line should fix it:
Code - Auto/Visual Lisp: [Select]
  1. (setq i (mapcar '(lambda (x) (cons (car x) (cadr x))) i))
« Last Edit: March 17, 2022, 04:41:45 AM by dexus »