(XD::List:GroupByIndex)按索引对表进行分组

eachy · 发表于 2013-10-14 15:13:08

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(defun XD::List:GroupByIndex (lst fuzz / ll ilst l index tf)
(or
(and
(listp (caar lst))
(setq ll (list (list (caar lst) (cdar lst)))
lst (cdr lst)
)
(while lst
(if (setq l
(mapcar
'cdr
(vl-remove-if-not
'(lambda (x) (equal (car x) (caar ll) fuzz))
lst
)
)
)
(setq ll (cons (append (car ll) l) (cdr ll))
lst (vl-remove-if
'(lambda (x) (equal (car x) (caar ll) fuzz))
lst
)
)
)
(setq ll (cons (list (caar lst) (cdar lst)) ll)
lst (cdr lst)
)
)
)
(and (setq index (caar lst))
(or (and (= (type index) 'INT)
(setq tf t
lst (mapcar
'(lambda (x) (cons (float (car x)) (cdr x)))
lst
)
lst (reverse lst)
)
)
(= (type index) 'REAL)
(= (type index) 'STR)
)
(setq
lst (vl-sort lst '(lambda (l1 l2) (< (car l1) (car l2))))
)
(mapcar '(lambda (x y / l)
(if (equal (caar ll) x fuzz)
(setq ll (cons (cons x
(cons y (cdar ll))
)
(cdr ll)
)
)
(setq ll (cons (cons x (list y)) ll))
)
)
(mapcar 'car lst)
(mapcar 'cdr lst)
)
(if tf
(setq ll (mapcar '(lambda (x) (cons (fix (car x)) (cdr x))) ll)
ll (reverse ll))
)
)
)
(mapcar '(lambda (x)
(cons (car x)
(mapcar '(lambda (a)
(if (= (length a) 1)
(car a)
a
)
)
(cdr x)
)
)
)
(vl-remove '(nil nil) ll)
)
)

(defun XD::List:GroupByIndex (lst fuzz / ll ilst l index tf) 
  (or 
    (and 
      (listp (caar lst)) 
      (setq ll        (list (list (caar lst) (cdar lst))) 
            lst        (cdr lst) 
      ) 
      (while lst 
        (if (setq l 
                   (mapcar 
                     'cdr 
                     (vl-remove-if-not 
                       '(lambda (x) (equal (car x) (caar ll) fuzz)) 
                       lst 
                     ) 
                   ) 
            ) 
          (setq        ll  (cons (append (car ll) l) (cdr ll)) 
                lst (vl-remove-if 
                      '(lambda (x) (equal (car x) (caar ll) fuzz)) 
                      lst 
                    ) 
          ) 
        ) 
        (setq ll  (cons (list (caar lst) (cdar lst)) ll) 
              lst (cdr lst) 
        ) 
      ) 
    ) 
    (and (setq index (caar lst)) 
         (or (and (= (type index) 'INT) 
                  (setq        tf  t 
                        lst (mapcar 
                              '(lambda (x) (cons (float (car x)) (cdr x))) 
                              lst 
                            ) 
                        lst (reverse lst) 
                  ) 
             ) 
             (= (type index) 'REAL) 
             (= (type index) 'STR) 
         ) 
         (setq 
           lst (vl-sort lst '(lambda (l1 l2) (< (car l1) (car l2)))) 
         ) 
         (mapcar '(lambda (x y / l) 
                    (if        (equal (caar ll) x fuzz) 
                      (setq ll (cons (cons x 
                                           (cons y (cdar ll)) 
                                     ) 
                                     (cdr ll) 
                               ) 
                      ) 
                      (setq ll (cons (cons x (list y)) ll)) 
                    ) 
                  ) 
                 (mapcar 'car lst) 
                 (mapcar 'cdr lst) 
         ) 
         (if tf 
           (setq ll (mapcar '(lambda (x) (cons (fix (car x)) (cdr x))) ll) 
                 ll (reverse ll)) 
         ) 
    ) 
  ) 
  (mapcar '(lambda (x) 
             (cons (car x) 
                   (mapcar '(lambda (a) 
                              (if (= (length a) 1) 
                                (car a) 
                                a 
                              ) 
                            ) 
                           (cdr x) 
                   ) 
             ) 
           ) 
          (vl-remove '(nil nil) ll) 
  ) 
)

eachy · 发表于 2013-10-14 15:15:11

应用示例一：

;;相同半径圆改相同颜色
(defun c:tt (/ ss ll i)
(if (setq ss (ssget '((0 . "circle"))))
(progn
(setq
ll (xd::list:groupbyindex
(mapcar '(lambda (x)
(list (xdrx_getpropertyvalue x "Radius") x)
)
(xdrx_pickset->ents ss)
)
1e-6
)
)
(setq i 0)
(foreach x (mapcar 'cdr ll)
(mapcar '(lambda (c)
(xdrx_setpropertyvalue
c
"Color"
i
)
)
x
)
(setq i (1+ i))
)
)
)
(princ)
)

eachy · 发表于 2013-10-14 15:15:33

应用示例二：

;;统计同层线长
(defun c:tt (/ ss lst lyrlst lens)
(if (setq ss (ssget '((0 . "*line,arc,circle,ellipse"))))
(progn
(setq lst (xd::list:groupbyindex
(mapcar '(lambda (x)
(list (car (xdrx_getpropertyvalue x "Layer")) x)
)
(xdrx_pickset->ents ss)
)
0
)
lyrlst (mapcar 'cdr lst)
lens (mapcar
'(lambda (x)
(apply
'+
(mapcar
'(lambda (c)
(xdrx_curve_getdistatparam
e
(xdrx_curve_getendparam e)
)
)
x
)
)
)
(mapcar 'cdr lst)
)
)
(mapcar '(lambda (l d)
(princ (strcat "\n" l " 层线总长度 = "))
(princ d)
)
lyrlst
lens
)
)
)
(princ)
)

;;统计同层线长 
(defun c:tt (/ ss lst lyrlst lens) 
  (if (setq ss (ssget '((0 . "*line,arc,circle,ellipse")))) 
    (progn 
      (setq lst       (xd::list:groupbyindex 
             (mapcar '(lambda (x) 
                (list (car (xdrx_getpropertyvalue x "Layer")) x) 
                  ) 
                 (xdrx_pickset->ents ss) 
             ) 
             0 
           ) 
        lyrlst (mapcar 'cdr lst) 
        lens   (mapcar 
             '(lambda (x) 
            (apply 
              '+ 
              (mapcar 
                '(lambda (c) 
                   (xdrx_curve_getdistatparam 
                 e 
                 (xdrx_curve_getendparam e) 
                   ) 
                 ) 
                x 
              ) 
            ) 
              ) 
             (mapcar 'cdr lst) 
           ) 
      ) 
      (mapcar '(lambda (l d) 
         (princ (strcat "\n" l " 层线总长度 = ")) 
         (princ d) 
           ) 
          lyrlst 
          lens 
      ) 
    ) 
  ) 
  (princ) 
)

eachy · 发表于 2013-10-14 15:20:41

应用示例三：

;;按图案名统计面积
(defun c:tt (/ ss lst names areas)
(if (setq ss (ssget '((0 . "Hatch"))))
(progn
(setq lst (xd::list:groupbyindex
(mapcar '(lambda (x)
(list (xdrx_getpropertyvalue x "PatternName") x)
)
(xdrx_pickset->ents ss)
)
0
)
names (mapcar 'car lst)
areas (mapcar
'(lambda (x)
(apply
'+
(mapcar
'(lambda (a) (xdrx_getpropertyvalue a "Area"))
x
)
)
)
(mapcar 'cdr lst)
)
)
(mapcar '(lambda (x y)
(princ (strcat "\n" x " 图案总面积 = "))
(princ y)
)
names
areas
)
)
)
(princ)
)

;;按图案名统计面积 
(defun c:tt (/ ss lst names areas) 
  (if (setq ss (ssget '((0 . "Hatch")))) 
    (progn 
      (setq lst          (xd::list:groupbyindex 
                    (mapcar '(lambda (x) 
                               (list (xdrx_getpropertyvalue x "PatternName") x) 
                             ) 
                            (xdrx_pickset->ents ss) 
                    ) 
                    0 
                  ) 
            names (mapcar 'car lst) 
            areas (mapcar 
                    '(lambda (x) 
                       (apply 
                         '+ 
                         (mapcar 
                           '(lambda (a) (xdrx_getpropertyvalue a "Area")) 
                           x 
                         ) 
                       ) 
                     ) 
                    (mapcar 'cdr lst) 
                  ) 
      ) 
      (mapcar '(lambda (x y) 
                 (princ (strcat "\n" x " 图案总面积 = ")) 
                 (princ y) 
               ) 
              names 
              areas 
      ) 
    ) 
  ) 
  (princ) 
)

st788796 · 发表于 2013-10-15 10:41:34

还有 Bug , 子表的第二个元素现在不能是表，如果是表的话只保留了 car ，需改进！

eachy · 发表于 2013-10-15 14:46:20

已更新
_$ (xd::list:groupbyindex '(("1" (2 2) (2 3)) ("2" (1 2)) ("1" (2 3)) ("4" 1) ("1" (8 9 3))) 0)
(("4" 1) ("2" (1 2)) ("1" (8 9 3) (2 3) (2 2) (2 3)))
_$

Free-Lancer · 发表于 2013-10-17 18:19:47

eachy 发表于 2013-10-15 14:46
已更新
_$ (xd::list:groupbyindex '(("1" (2 2) (2 3)) ("2" (1 2)) ("1" (2 3)) ("4" 1) ("1" (8 9 3))) ...

不能分("1" "2" "1" "2")形式表

eachy · 发表于 2013-10-17 21:15:40

1017 Update

eachy · 发表于 2013-10-18 15:16:12

再次更新，vl-sort 排序会忽略重复

■D_zZ · 发表于 2013-11-3 12:56:23

谢谢，收藏了。

sicky111 · 发表于 2013-11-5 21:53:58

学习了，谢谢。

eachy · 发表于 2013-11-7 20:06:46

1107更新

eachy · 发表于 2013-11-8 09:37:26

1108更新

eachy · 发表于 2013-11-8 14:35:36

再次修改 Bug, 少了一个 d

最终版，优化 INT 索引

守仁格竹GM · 发表于 2013-11-9 09:37:33

:lol 运行效率很高

账号		自动登录	找回密码
密码			立即注册

[表] (XD::List:GroupByIndex)按索引对表进行分组

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

点评

点评

点评