[讨论]文字裁切双位元函数

vken7az2p · 发表于 2007-10-12 20:32:00

[讨论]文字裁切双位元函数
或许已有高手编写过了,但因为没有找到过
所以编写了这支可以切断文字左边或右边的函数,
想请各位高手多多指导精简一下,
并看看是否还有其他要改进的地方.
谢谢~

(SETQ STR "一二三四五") ;字串
(SETQ STR_ST 3) ;字串起始值 1...
(SETQ STR_LH 3) ;字串切割位数 1...N / NIL
(SETQ DB_Byte T) ;双位元计算保留 T/NIL
(SETQ CP_LF T) ;反转左切 T/NIL
(JTHWA-TRIM-STR STR STR_ST STR_LH DB_Byte CP_LF)
exp1:
(SETQ STR "1234567890")
(JTHWA-TRIM-STR STR 3 1 t t)
_$ "3"
(JTHWA-TRIM-STR STR 3 2 n t)
_$ "23"
(JTHWA-TRIM-STR STR 3 1 n n)
_$ "3"
(JTHWA-TRIM-STR STR 3 2 n n)
_$ "34"
exp2:
(SETQ STR "一二三四五")
(JTHWA-TRIM-STR STR 3 2 n n)
_$ "二"
(JTHWA-TRIM-STR STR 3 3 n n)
_$ "二?
(JTHWA-TRIM-STR STR 3 3 t n)
_$ "二三"
(JTHWA-TRIM-STR STR 4 3 t n)
_$ "二三"
(JTHWA-TRIM-STR STR 4 4 t n)
_$ "二三四"
(JTHWA-TRIM-STR STR 4 4 n t)
_$ "一二"
(JTHWA-TRIM-STR STR 4 3 n t)
_$ "@二"
(JTHWA-TRIM-STR STR 5 2 t t)
_$ "二三"
(JTHWA-TRIM-STR STR 7 3 t t)
_$ "三四"
(DEFUN JTHWA-TRIM-STR (STR STR_ST STR_LH DB_Byte CP_LF / ANS I ST01
ST02 STAL STNNB STR_LH-BK STR_LH-FT STR_LH-K
STR_LH-ME STR_ST-BK STR_ST-FT STR_ST-ME
STR_STLH SUBNB-K TSTNB )
(SETQ STNNB NIL)
(SETQ STAL (tc:getstrwid STR))
(SETQ ST01 (CAR (tc:getstrwid STR)))
(SETQ ST02 (CDR (tc:getstrwid STR)))
(SETQ I -1)
(REPEAT ST01
(SETQ I (1+ I))
(SETQ TSTNB (strlen (NTH I ST02)))
(REPEAT TSTNB
(SETQ STNNB (CONS I STNNB))
)
)
(SETQ STNNB (reverse STNNB))
(IF CP_LF
;; ======================处理左切字串
(PROGN
(SETQ STR_STLH (strlen STR))
(SETQ SUBNB-K (1- STR_ST))
(SETQ STR_ST-FT (IF (minusp (1+ SUBNB-K))
NIL
(NTH (1+ SUBNB-K) STNNB)
)
)
(SETQ STR_ST-ME (IF (minusp (NTH SUBNB-K STNNB))
NIL
(NTH SUBNB-K STNNB)
)
)
(SETQ STR_ST-BK (IF (minusp (1- SUBNB-K))
NIL
(NTH (1- SUBNB-K) STNNB)
)
)
(COND
((OR
(= SUBNB-K 0)
(minusp STR_ST)
(< STR_ST STR_LH)
)
(PRINT "Runner Error")
(SETQ ANS "")
)
(T
(IF DB_Byte
(PROGN
(IF (= STR_LH NIL)
(SETQ STR_LH (1- STR_ST))
)
(COND
((= STR_ST-ME STR_ST-FT)
(SETQ STR_ST (1+ STR_ST))
(SETQ STR_LH (1+ STR_LH))
)
((= STR_ST-ME STR_ST-BK)
(SETQ STR_ST STR_ST)
)
)
(IF STR_LH
(PROGN
(SETQ STR_LH-K (- STR_ST STR_LH))
(SETQ STR_LH-FT (IF (minusp (1+ STR_LH-K))
NIL
(NTH (1+ STR_LH-K) STNNB)
)
)
(SETQ STR_LH-ME (IF (minusp (NTH STR_LH-K STNNB))
NIL
(NTH STR_LH-K STNNB)
)
)
(SETQ STR_LH-BK (IF (minusp (1- STR_LH-K))
NIL
(NTH (1- STR_LH-K) STNNB)
)
)
)
)
(IF STR_LH
(PROGN
(COND
((= STR_LH-ME STR_LH-FT)
(SETQ STR_LH STR_LH)
)
((= STR_LH-ME STR_LH-BK)
(SETQ STR_LH (1+ STR_LH))
)
)
(SETQ ANS (SUBSTR STR (1+ (- STR_ST STR_LH)) STR_LH))
)
(SETQ ANS (SUBSTR STR 1 STR_ST))
)
)
(PROGN
(IF STR_LH
(SETQ ANS (substr STR (SETQ STR_ST (- (1+ STR_ST)
STR_LH
)
)
(SETQ STR_LH STR_LH)
)
)
(SETQ ANS (substr STR 1 STR_ST))
)
)
)
)
)
)
;; ======================处理右切字串
(PROGN
(SETQ STR_STLH (strlen STR))
(SETQ SUBNB-K (1- STR_ST))
(SETQ STR_ST-FT (IF (minusp STR_ST)
NIL
(NTH STR_ST STNNB)
)
)
(SETQ STR_ST-ME (IF (minusp (NTH SUBNB-K STNNB))
NIL
(NTH SUBNB-K STNNB)
)
)
(SETQ STR_ST-BK (IF (minusp (1- SUBNB-K))
NIL
(NTH (1- SUBNB-K) STNNB)
)
)
(COND
((OR
(= SUBNB-K 0)
(minusp STR_ST)
(> SUBNB-K STR_STLH)
)
(PRINT "Runner Error")
(SETQ ANS "")
)
(T
(IF DB_Byte
(PROGN
(COND
((= STR_ST-ME STR_ST-FT)
(SETQ STR_ST STR_ST)
)
((= STR_ST-ME STR_ST-BK)
(SETQ STR_ST (1- STR_ST))
(SETQ STR_LH (IF (= STR_LH NIL)
(SETQ STR_LH NIL)
(1+ STR_LH)
)
)
)
)
(IF (= STR_LH NIL)
(SETQ STR_LH NIL)
(IF STR_LH
(PROGN
(SETQ STR_LH-K (- (+ STR_ST STR_LH) 2))
(SETQ STR_LH-FT (IF (minusp (1+ STR_LH-K))
NIL
(NTH (1+ STR_LH-K) STNNB)
)
)
(SETQ STR_LH-ME (IF (minusp (NTH STR_LH-K STNNB))
NIL
(NTH STR_LH-K STNNB)
)
)
(SETQ STR_LH-BK (IF (minusp (1- STR_LH-K))
NIL
(NTH (1- STR_LH-K) STNNB)
)
)
)
)
)
(IF STR_LH
(PROGN
(COND
((= STR_LH-ME STR_LH-FT)
(SETQ STR_LH (1+ STR_LH))
)
((= STR_LH-ME STR_LH-BK)
(SETQ STR_LH STR_LH)
)
)
(SETQ ANS (SUBSTR STR STR_ST STR_LH))
)
(SETQ ANS (SUBSTR STR STR_ST))
)
)
(PROGN
(IF STR_LH
(SETQ ANS (substr STR STR_ST STR_LH))
(SETQ ANS (substr STR STR_ST))
)
)
)
)
)
)
)
(PRINT ANS)
(prin1)
)
tc:getstrwid 函数
引用来源: http://bbs.mjtd.com/forum.php?mod=viewthread&tid=50326
BY xxsheng
(defun tc:getstrwid(str / m n a c)
(setq m 0)
(setq n 0)
(while (< m (strlen str))
(if (> (vl-string-elt str m) 128)
(progn
(setq n(1+ n))
(setq a (substr str (1+ m) 2))
(setq m(+ 2 m))
)
(progn
(setq n(1+ n))
(setq a (substr str (1+ m) 1))
(setq m(1+ m))
)
)
(setq c(cons a c))
)
(setq c(reverse c))
(cons n c)
)

(SETQ STR "一二三四五") ;字串
(SETQ STR_ST 3)  ;字串起始值 1...
(SETQ STR_LH 3)  ;字串切割位数 1...N / NIL
(SETQ DB_Byte T) ;双位元计算保留 T/NIL
(SETQ CP_LF T)   ;反转左切 T/NIL
(JTHWA-TRIM-STR STR STR_ST STR_LH DB_Byte CP_LF)
exp1:
(SETQ STR "1234567890")
(JTHWA-TRIM-STR STR 3 1 t t)
_$ "3"
(JTHWA-TRIM-STR STR 3 2 n t)
_$ "23"
(JTHWA-TRIM-STR STR 3 1 n n)
_$ "3"
(JTHWA-TRIM-STR STR 3 2 n n)
_$ "34"
exp2:
(SETQ STR "一二三四五")
(JTHWA-TRIM-STR STR 3 2 n n)
_$ "二"
(JTHWA-TRIM-STR STR 3 3 n n)
_$ "二?
(JTHWA-TRIM-STR STR 3 3 t n)
_$ "二三"
(JTHWA-TRIM-STR STR 4 3 t n)
_$ "二三"
(JTHWA-TRIM-STR STR 4 4 t n)
_$ "二三四" 
(JTHWA-TRIM-STR STR 4 4 n t)
_$ "一二" 
(JTHWA-TRIM-STR STR 4 3 n t)
_$ "@二" 
(JTHWA-TRIM-STR STR 5 2 t t)
_$ "二三"  
(JTHWA-TRIM-STR STR 7 3 t t)
_$ "三四"

(DEFUN JTHWA-TRIM-STR (STR STR_ST STR_LH DB_Byte CP_LF / ANS I ST01
      ST02 STAL STNNB STR_LH-BK STR_LH-FT STR_LH-K
      STR_LH-ME STR_ST-BK STR_ST-FT STR_ST-ME
      STR_STLH SUBNB-K TSTNB )       
  (SETQ STNNB NIL)
  (SETQ STAL (tc:getstrwid STR))
  (SETQ ST01 (CAR (tc:getstrwid STR)))
  (SETQ ST02 (CDR (tc:getstrwid STR)))
  (SETQ I -1)
  (REPEAT ST01
    (SETQ I (1+ I))
    (SETQ TSTNB (strlen (NTH I ST02)))
    (REPEAT TSTNB
      (SETQ STNNB (CONS I STNNB))
    )
  )
  (SETQ STNNB (reverse STNNB))
  (IF CP_LF
    ;; ======================处理左切字串
    (PROGN
      (SETQ STR_STLH (strlen STR))
      (SETQ SUBNB-K (1- STR_ST))
      (SETQ STR_ST-FT (IF (minusp (1+ SUBNB-K))
   NIL
   (NTH (1+ SUBNB-K) STNNB)
        )
      )
      (SETQ STR_ST-ME (IF (minusp (NTH SUBNB-K STNNB))
   NIL
   (NTH SUBNB-K STNNB)
        )
      )
      (SETQ STR_ST-BK (IF (minusp (1- SUBNB-K))
   NIL
   (NTH (1- SUBNB-K) STNNB)
        )
      )
      (COND
 ((OR
    (= SUBNB-K 0)
    (minusp STR_ST)
    (< STR_ST STR_LH)
  )
   (PRINT "Runner Error")
   (SETQ ANS "")
 )
 (T
   (IF DB_Byte
     (PROGN
       (IF (= STR_LH NIL)
  (SETQ STR_LH (1- STR_ST))
       )
       (COND
  ((= STR_ST-ME STR_ST-FT)
    (SETQ STR_ST (1+ STR_ST))
    (SETQ STR_LH (1+ STR_LH))
  )
  ((= STR_ST-ME STR_ST-BK)
    (SETQ STR_ST STR_ST)
  )
       )
       (IF STR_LH
  (PROGN
    (SETQ STR_LH-K (- STR_ST STR_LH))
    (SETQ STR_LH-FT (IF (minusp (1+ STR_LH-K))
        NIL
        (NTH (1+ STR_LH-K) STNNB)
      )
    )
    (SETQ STR_LH-ME (IF (minusp (NTH STR_LH-K STNNB))
        NIL
        (NTH STR_LH-K STNNB)
      )
    )
    (SETQ STR_LH-BK (IF (minusp (1- STR_LH-K))
        NIL
        (NTH (1- STR_LH-K) STNNB)
      )
    )
  )
       )
       (IF STR_LH
  (PROGN
    (COND
      ((= STR_LH-ME STR_LH-FT)
        (SETQ STR_LH STR_LH)
      )
      ((= STR_LH-ME STR_LH-BK)
        (SETQ STR_LH (1+ STR_LH))
      )
    )
    (SETQ ANS (SUBSTR STR (1+ (- STR_ST STR_LH)) STR_LH))
  )
  (SETQ ANS (SUBSTR STR 1 STR_ST))
       )
     )
     (PROGN
       (IF STR_LH
  (SETQ ANS (substr STR (SETQ STR_ST (- (1+ STR_ST)
            STR_LH
         )
          )
      (SETQ STR_LH STR_LH)
     )
  )
  (SETQ ANS (substr STR 1 STR_ST))
       )
     )
   )
 )
      )
    )
    ;; ======================处理右切字串
    (PROGN
      (SETQ STR_STLH (strlen STR))
      (SETQ SUBNB-K (1- STR_ST))
      (SETQ STR_ST-FT (IF (minusp STR_ST)
   NIL
   (NTH STR_ST STNNB)
        )
      )
      (SETQ STR_ST-ME (IF (minusp (NTH SUBNB-K STNNB))
   NIL
   (NTH SUBNB-K STNNB)
        )
      )
      (SETQ STR_ST-BK (IF (minusp (1- SUBNB-K))
   NIL
   (NTH (1- SUBNB-K) STNNB)
        )
      )
      (COND
 ((OR
    (= SUBNB-K 0)
    (minusp STR_ST)
    (> SUBNB-K STR_STLH)
  )
   (PRINT "Runner Error")
   (SETQ ANS "")
 )
 (T
   (IF DB_Byte
     (PROGN
       (COND
  ((= STR_ST-ME STR_ST-FT)
    (SETQ STR_ST STR_ST)
  )
  ((= STR_ST-ME STR_ST-BK)
    (SETQ STR_ST (1- STR_ST))
    (SETQ STR_LH (IF (= STR_LH NIL)
     (SETQ STR_LH NIL)
     (1+ STR_LH)
          )
    )
  )
       )
       (IF (= STR_LH NIL)
  (SETQ STR_LH NIL)
  (IF STR_LH
    (PROGN
      (SETQ STR_LH-K (- (+ STR_ST STR_LH) 2))
      (SETQ STR_LH-FT (IF (minusp (1+ STR_LH-K))
          NIL
          (NTH (1+ STR_LH-K) STNNB)
        )
      )
      (SETQ STR_LH-ME (IF (minusp (NTH STR_LH-K STNNB))
          NIL
          (NTH STR_LH-K STNNB)
        )
      )
      (SETQ STR_LH-BK (IF (minusp (1- STR_LH-K))
          NIL
          (NTH (1- STR_LH-K) STNNB)
        )
      )
    )
  )
       )
       (IF STR_LH
  (PROGN
    (COND
      ((= STR_LH-ME STR_LH-FT)
        (SETQ STR_LH (1+ STR_LH))
      )
      ((= STR_LH-ME STR_LH-BK)
        (SETQ STR_LH STR_LH)
      )
    )
    (SETQ ANS (SUBSTR STR STR_ST STR_LH))
  )
  (SETQ ANS (SUBSTR STR STR_ST))
       )
     )
     (PROGN
       (IF STR_LH
  (SETQ ANS (substr STR STR_ST STR_LH))
  (SETQ ANS (substr STR STR_ST))
       )
     )
   )
 )
      )
    )
  )
  (PRINT ANS)
  (prin1)
)
tc:getstrwid 函数
引用来源: http://bbs.mjtd.com/forum.php?mod=viewthread&tid=50326
BY xxsheng
(defun tc:getstrwid(str / m n a c)
  (setq m 0)
  (setq n 0)
  (while (< m (strlen str))
    (if (> (vl-string-elt str m) 128)
      (progn
        (setq n(1+ n))
    (setq a (substr str (1+ m) 2))
    (setq m(+ 2 m))
      )
      (progn
    (setq n(1+ n))
    (setq a (substr str (1+ m) 1))
    (setq m(1+ m))
      )
    )
    (setq c(cons a c))
  )
  (setq c(reverse c))
  (cons n c)
)

meja · 发表于 2023-4-5 23:24:08

国外有类似功能源码，我自己改进了一些，用于统计管线工程量

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