发几个表格型数据的函数

77077 · 发表于 2014-9-29 22:21:25

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

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

×

本帖最后由 77077 于 2014-9-29 22:46 编辑

;获取表格型list的最大行列数
;(TableList-RowColNum '(("SDS" "DDDSS6" "SS" "")("FDS" "DFDSFSDA9")("SDS" "DDDS5" "SS")))
;=>(3 4)
(defun TableList-RowColNum(lst)
(list (length lst)
(apply 'max (mapcar 'length lst))
)
)
;用符号补齐表格型list各子表长度
;lst-表格型list Len-补齐后长度 str-用于补齐的符号
;(TableList-FixLen '(("SDS" "DDDSS6" "SS" "")("FDS" "DFDSFSDA9")("SDS" "DDDS5" "SS")) 6 "-")
;=>(("SDS" "DDDSS6" "SS" "" "-" "-") ("FDS" "DFDSFSDA9" "-" "-" "-" "-") ("SDS" "DDDS5" "SS" "-" "-" "-"))
(defun TableList-FixLen (lst Len str)
(mapcar 'reverse
(mapcar
'(lambda(x)
(progn
(setq x (reverse x))
(repeat (- len (length x))
(setq x (cons str x))
)
)
)
lst
)
)
)
;表格型list行列互转
;命令: (TableList-CR '(("SDS" "DDDSS6" "SS" "" "-" "-") ("FDS" "DFDSFSDA9" "-" "-" "-" "-") ("SDS" "DDDS5" "SS" "-" "-" "-")))
;=>(("SDS" "FDS" "SDS") ("DDDSS6" "DFDSFSDA9" "DDDS5") ("SS" "-" "SS") ("" "-" "-") ("-" "-" "-") ("-" "-" "-"))
(defun TableList-CR (lst / l)
(repeat (apply 'max (mapcar 'length lst))
(setq l (cons (mapcar 'car lst) l)
lst (mapcar 'cdr lst)
)
)
(reverse l)
)
;表格型list中各子项转化为字符串
;命令: (TableList-StrLst '((0.5 0.8 0.6 0.3)(1.5 1.6 1.8)(2.2 2.5 2.8)))
;=>(("0.5" "0.8" "0.6" "0.3") ("1.5" "1.6" "1.8") ("2.2" "2.5" "2.8"))
(defun TableList-StrLst(lst)
(mapcar
'(lambda(y)
(mapcar 'vl-princ-to-string y)
)
lst
)
)
;获取表格型list各子表中最长字符串长度
;命令: (TableList-MaxlenC '(("SDS" "DDDSS6" "SS" "")("FDS" "DFDSFSDA9" "SDFDS")("SDS" "DDDS5" "SS")))
;=>(6 9 5)
(defun TableList-MaxlenC(lst)
(mapcar
'(lambda(x)
(apply 'max (mapcar 'strlen x));单层表最大字符串长度
)
lst
)
)

;获取表格型list的最大行列数 
;(TableList-RowColNum '(("SDS" "DDDSS6" "SS" "")("FDS" "DFDSFSDA9")("SDS" "DDDS5" "SS"))) 
;=>(3 4) 
(defun TableList-RowColNum(lst) 
  (list (length lst) 
    (apply 'max (mapcar 'length lst)) 
  ) 
) 
;用符号补齐表格型list各子表长度 
;lst-表格型list   Len-补齐后长度 str-用于补齐的符号 
;(TableList-FixLen '(("SDS" "DDDSS6" "SS" "")("FDS" "DFDSFSDA9")("SDS" "DDDS5" "SS")) 6 "-") 
;=>(("SDS" "DDDSS6" "SS" "" "-" "-") ("FDS" "DFDSFSDA9" "-" "-" "-" "-") ("SDS" "DDDS5" "SS" "-" "-" "-")) 
(defun TableList-FixLen (lst Len str) 
(mapcar 'reverse 
  (mapcar 
          '(lambda(x) 
             (progn 
                     (setq x (reverse x)) 
               (repeat (- len (length x)) 
                       (setq x (cons str x)) 
                ) 
              ) 
          ) 
          lst 
  ) 
 ) 
) 
;表格型list行列互转 
;命令: (TableList-CR '(("SDS" "DDDSS6" "SS" "" "-" "-") ("FDS" "DFDSFSDA9" "-" "-" "-" "-") ("SDS" "DDDS5" "SS" "-" "-" "-"))) 
;=>(("SDS" "FDS" "SDS") ("DDDSS6" "DFDSFSDA9" "DDDS5") ("SS" "-" "SS") ("" "-" "-") ("-" "-" "-") ("-" "-" "-")) 
(defun TableList-CR (lst / l)        
        (repeat (apply 'max (mapcar 'length lst)) 
    (setq l (cons (mapcar 'car lst) l) 
         lst (mapcar 'cdr lst) 
         ) 
  ) 
  (reverse l) 
) 
;表格型list中各子项转化为字符串 
;命令: (TableList-StrLst '((0.5 0.8 0.6 0.3)(1.5 1.6 1.8)(2.2 2.5 2.8))) 
;=>(("0.5" "0.8" "0.6" "0.3") ("1.5" "1.6" "1.8") ("2.2" "2.5" "2.8")) 
(defun TableList-StrLst(lst) 
    (mapcar 
                 '(lambda(y) 
                     (mapcar 'vl-princ-to-string y) 
                  ) 
                lst 
          ) 
) 
;获取表格型list各子表中最长字符串长度 
;命令: (TableList-MaxlenC  '(("SDS" "DDDSS6" "SS" "")("FDS" "DFDSFSDA9" "SDFDS")("SDS" "DDDS5" "SS"))) 
;=>(6 9 5) 
(defun TableList-MaxlenC(lst) 
        (mapcar 
                '(lambda(x) 
              (apply 'max (mapcar 'strlen x));单层表最大字符串长度 
     ) 
           lst 
   ) 
)

77077 · 发表于 2014-9-29 22:47:53

求优化.......
代码本来是对齐了的,怎么粘贴上来就变形了呢,编辑器问题?

HLCAD · 发表于 2014-9-30 07:54:59

楼主的程序很实用，支持！

st788796 · 发表于 2014-9-30 08:16:22

本帖最后由 st788796 于 2014-9-30 08:18 编辑

77077 发表于 2014-9-29 22:47
求优化.......
代码本来是对齐了的,怎么粘贴上来就变形了呢,编辑器问题?

可以参考下 XD开源函数库中 XD::Table 部分函数

粘贴代码时把右上角的 "纯文本" 勾选上能够尽量保持格式

77077 · 发表于 2014-9-30 22:27:42

;利用表格型list制作CAD表格
;参数:
;lis --- 表格型list
;pt --- 表格左上角(点)
;zg ---- 字高(数值型)
;测试(TableLst2Table '((1 12 123 1234 12345 123456 1234567 12345678 123456780 1234567890)(1.0 0.0 0.0)(100.0 12345.0 "5551000" "1234")) (getpoint) 10)
(defun TableLst2Table (lis pt zg / emkLine emkText h len1 len2 i h1 w2 tab_h
len j w1 w2 wlst p0 p1 txt
)
(defun emkLine (p1 p2)
(entmake (list '(0 . "LINE") (cons 8 "DM_文字表格") (cons 10 p1)
(cons 11 p2)
)
)
)
(defun emkText (pt str h)
(entmake (list '(0 . "TEXT") (cons 1 str) (cons 8 "DM_文字表格")
(cons 10 pt) (cons 40 h) (cons 11 pt) (cons 72 1)
(cons 73 2)
)
)
)
(setq h (* zg 2) ; 表格高
len1 (length lis) ; 表格行数len1
len2 (apply
'max
(mapcar
'length
lis
)
) ; 表格列数len2
p0 (list (car pt) (- (cadr pt) (* 0.5 h)))
) ; 定义文字原点
(setq lis (mapcar
'(lambda (y)
(mapcar
'vl-princ-to-string
y
)
)
lis
)
) ; 将表中元素全部变为文本型
; 以下获取列宽表 wlst
(setq i 0
w2 0
wlst '()
)
(repeat len2
(foreach e lis
(setq txt (nth i e))
(if (not txt)
(setq txt "")
)
(setq w1 (* (+ (strlen txt) 1) zg)) ; 列宽=(文字长度+1)*zg
(if (> w1 w2)
(setq w2 w1)
)
)
(setq wlst (cons w2 wlst)
w2 0
i (1+ i)
)
)
(setq wlst (reverse wlst)) ; 按行顺序写出文字内容
(setq i 0
j 0
w1 0
w2 0
)
(foreach e lis
(setq h1 (- (cadr p0) (* i h))) ; 文字行的y坐标值
(foreach f e
(setq w1 (nth j wlst)
w2 (+ w2 w1)
)
(setq p1 (list (- (+ (car p0) w2) (* w1 0.5)) h1)) ; 文字插入点
(emkText P1 f zg)
(setq j (1+ j))
)
(setq i (1+ i)
j 0
w1 0
w2 0
)
) ; 开始绘制竖线
(setq tab_h (* len1 h)) ; 竖线长
(emkLine pt (polar pt (* pi 1.5) tab_h)) ; 绘制左侧第一根竖线
(setq len 0)
(foreach x wlst ; 绘制竖线
(setq len (+ x len)
p1 (polar pt 0 len)
)
(emkLine p1 (polar p1 (* Pi 1.5) tab_h))
) ; 开始绘制横线
(setq i 0
len 0
)
(setq len (apply
'+
wlst
)
) ; 横线长度
(repeat (1+ len1) ; 绘制横线
(setq p1 (polar pt (* Pi 1.5) (* i h))
i (1+ i)
)
(emkLine p1 (polar p1 0 len))
)
(princ)
)

;利用表格型list制作CAD表格 
;参数: 
;lis --- 表格型list 
;pt --- 表格左上角(点) 
;zg ---- 字高(数值型) 
;测试(TableLst2Table '((1 12 123 1234 12345 123456 1234567 12345678 123456780 1234567890)(1.0 0.0 0.0)(100.0 12345.0 "5551000" "1234")) (getpoint) 10) 
(defun TableLst2Table (lis pt zg / emkLine emkText h len1 len2 i h1 w2 tab_h 
                           len j w1 w2 wlst p0 p1 txt 
                      ) 
  (defun emkLine (p1 p2) 
    (entmake (list '(0 . "LINE") (cons 8 "DM_文字表格") (cons 10 p1) 
                   (cons 11 p2) 
             ) 
    ) 
  ) 
  (defun emkText (pt str h) 
    (entmake (list '(0 . "TEXT") (cons 1 str) (cons 8 "DM_文字表格") 
                   (cons 10 pt) (cons 40 h) (cons 11 pt) (cons 72 1) 
                   (cons 73 2) 
             ) 
    ) 
  ) 
  (setq h (* zg 2)                       ; 表格高 
        len1 (length lis)               ; 表格行数len1 
        len2 (apply 
               'max 
               (mapcar 
                 'length 
                 lis 
               ) 
             )                               ; 表格列数len2 
        p0 (list (car pt) (- (cadr pt) (* 0.5 h))) 
  )                                       ; 定义文字原点 
  (setq lis (mapcar 
              '(lambda (y) 
                 (mapcar 
                   'vl-princ-to-string 
                   y 
                 ) 
               ) 
              lis 
            ) 
  )                                       ; 将表中元素全部变为文本型 
                                       ; 以下获取列宽表 wlst 
  (setq i 0 
        w2 0 
        wlst '() 
  ) 
  (repeat len2 
    (foreach e lis 
      (setq txt (nth i e)) 
      (if (not txt) 
        (setq txt "") 
      ) 
      (setq w1 (* (+ (strlen txt) 1) zg)) ; 列宽=(文字长度+1)*zg 
      (if (> w1 w2) 
        (setq w2 w1) 
      ) 
    ) 
    (setq wlst (cons w2 wlst) 
          w2 0 
          i (1+ i) 
    ) 
  ) 
  (setq wlst (reverse wlst))               ; 按行顺序写出文字内容 
  (setq i 0 
        j 0 
        w1 0 
        w2 0 
  ) 
  (foreach e lis 
    (setq h1 (- (cadr p0) (* i h)))    ; 文字行的y坐标值 
    (foreach f e 
      (setq w1 (nth j wlst) 
            w2 (+ w2 w1) 
      ) 
      (setq p1 (list (- (+ (car p0) w2) (* w1 0.5)) h1)) ; 文字插入点 
      (emkText P1 f zg) 
      (setq j (1+ j)) 
    ) 
    (setq i (1+ i) 
          j 0 
          w1 0 
          w2 0 
    ) 
  )                                       ; 开始绘制竖线 
  (setq tab_h (* len1 h))               ; 竖线长 
  (emkLine pt (polar pt (* pi 1.5) tab_h)) ; 绘制左侧第一根竖线 
  (setq len 0) 
  (foreach x wlst                       ; 绘制竖线 
    (setq len (+ x len) 
          p1 (polar pt 0 len) 
    ) 
    (emkLine p1 (polar p1 (* Pi 1.5) tab_h)) 
  )                                       ; 开始绘制横线 
  (setq i 0 
        len 0 
  ) 
  (setq len (apply 
              '+ 
              wlst 
            ) 
  )                                       ; 横线长度 
  (repeat (1+ len1)                       ; 绘制横线 
    (setq p1 (polar pt (* Pi 1.5) (* i h)) 
          i (1+ i) 
    ) 
    (emkLine p1 (polar p1 0 len)) 
  ) 
  (princ) 
)

XDSoft · 发表于 2014-9-30 23:31:45

77077 发表于 2014-9-30 22:27

帮你编辑了，用LISPLINK编辑美化代码贴上来就很漂亮了。

77077 · 发表于 2014-10-9 18:15:09

本帖最后由 77077 于 2014-10-9 19:35 编辑

;;; 测试命令:
;;; (tablist:group '(("a" 1 1) ("b" 1 1) ("c" 1 1) ("b" 2 1) ("b" 3 1) ("a" 2 2) ("a" 3 3) ("b" 4 2) ("c" 2 2) ("c" 3 1)) 1)
;;; ==>((("a" 1 1) ("a" 2 2) ("a" 3 3)) (("b" 1 1) ("b" 2 1) ("b" 3 1) ("b" 4 2)) (("c" 1 1) ("c" 2 2) ("c" 3 1)))
(defun tablist:group (lst fuzz / k l ll)
(setq k (caar lst)) ; 设定关键词
(while lst ; 循环取值
(setq l (vl-remove-if-not '(lambda (x)
(equal (car x) k fuzz)
) lst
) ; 以关键词查找出对应的元素表l
l (list l) ; 组合成一个小组
ll (append l ll) ; 小组添加到输出表
)
(setq lst (vl-remove-if '(lambda (x)
(equal (car x) k fuzz)
) lst
) ; 剔除后形成新表lst
k (caar lst) ; 设定新的关键词
)
) ; while循环结束
(reverse ll) ; 反串
)

;;; 测试命令: 
;;; (tablist:group '(("a" 1 1) ("b" 1 1) ("c" 1 1) ("b" 2 1) ("b" 3 1) ("a" 2 2) ("a" 3 3) ("b" 4 2) ("c" 2 2) ("c" 3 1)) 1) 
;;; ==>((("a" 1 1) ("a" 2 2) ("a" 3 3)) (("b" 1 1) ("b" 2 1) ("b" 3 1) ("b" 4 2)) (("c" 1 1) ("c" 2 2) ("c" 3 1))) 
(defun tablist:group (lst fuzz / k l ll) 
  (setq k (caar lst))                       ; 设定关键词 
  (while lst                                     ; 循环取值 
    (setq l (vl-remove-if-not '(lambda (x) 
                                 (equal (car x) k fuzz) 
                               ) lst 
            )                                           ; 以关键词查找出对应的元素表l 
          l (list l)                       ; 组合成一个小组 
          ll (append l ll)                             ; 小组添加到输出表 
    ) 
    (setq lst (vl-remove-if '(lambda (x) 
                               (equal (car x) k fuzz) 
                             ) lst 
              )                                     ; 剔除后形成新表lst 
          k (caar lst)                       ; 设定新的关键词 
    ) 
  )                                                 ; while循环结束 
  (reverse ll)                               ; 反串 
)

77077 · 发表于 2014-10-9 19:21:43

还是来个合并分组的吧~~~

;;; 测试命令:
;;; (tablist:group1 '(("a" 1 1) ("b" 1 1) ("c" 1 1) ("b" 2 1) ("b" 3 1) ("a" 2 2) ("a" 3 3) ("b" 4 2) ("c" 2 2) ("c" 3 1)) 1)
;;; ==>(("a" (1 1) (2 2) (3 3)) ("b" (1 1) (2 1) (3 1) (4 2)) ("c" (1 1) (2 2) (3 1)))
(defun tablist:group1 (lst fuzz / k l ll)
(setq k (caar lst)) ; 设定关键词
(while lst ; 循环
(setq l (vl-remove-if-not
'(lambda (x)
(equal (car x) k fuzz)
) lst
) ; 以关键词查找出对应的元素表l
l (mapcar
'cdr
l
) ; 分别剔除首项
l (list (cons k l)) ; 组合成一个小组
ll (append
l
ll
) ; 小组添加到输出表
)
(setq lst (vl-remove-if
'(lambda (x)
(equal (car x) k fuzz)
) lst
) ; 剔除后形成新表lst
k (caar lst) ; 设定新的关键词
)
) ; while循环结束
(reverse ll) ; 反串
)

;;; 测试命令: 
;;; (tablist:group1 '(("a" 1 1) ("b" 1 1) ("c" 1 1) ("b" 2 1) ("b" 3 1) ("a" 2 2) ("a" 3 3) ("b" 4 2) ("c" 2 2) ("c" 3 1)) 1) 
;;; ==>(("a" (1 1) (2 2) (3 3)) ("b" (1 1) (2 1) (3 1) (4 2)) ("c" (1 1) (2 2) (3 1))) 
(defun tablist:group1 (lst fuzz / k l ll) 
  (setq k (caar lst))                       ; 设定关键词 
  (while lst                               ; 循环 
    (setq l (vl-remove-if-not 
                            '(lambda (x) 
                                 (equal (car x) k fuzz) 
                               ) lst 
            )                               ; 以关键词查找出对应的元素表l 
          l (mapcar 
              'cdr 
              l 
            )                               ; 分别剔除首项 
          l (list (cons k l))               ; 组合成一个小组 
          ll (append 
               l 
               ll 
             )                               ; 小组添加到输出表 
    ) 
    (setq lst (vl-remove-if 
                            '(lambda (x) 
                               (equal (car x) k fuzz) 
                             ) lst 
              )                               ; 剔除后形成新表lst 
          k (caar lst)                       ; 设定新的关键词 
    ) 
  )                                       ; while循环结束 
  (reverse ll)                               ; 反串 
)

yhly555 · 发表于 2014-10-27 11:33:40

虽然看不懂，但还是支持一下

xvjiex · 发表于 2021-7-18 06:30:13

感谢分享发几个表格型数据的函数！

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

[每日一码] 发几个表格型数据的函数

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

点评