浮点数与16进制字符串互转

陈进佳

在部分二进制文件中，浮点数是需要转换换为16进制字符串来存储的。
由于在LISP中没有单精度浮点数和双精度浮点数转16进制字符串函数，前些天为此伤透脑筋，有偿悬赏也未有人帮忙解决。
在查阅算法以及论坛资料后，算是完美解决了这个难题。

其中引用了大神baitang36大神的的内部函数itoa，以及高飞鸟大神的激活内部函数的代码，在此拜谢！
程序源代码如下，由于不会使用上传代码工具，敬请谅解


;;=============================================================
;;; 程序加载后，就可以用tranf来激活一个系统隐藏的函数           
;;; 用法：(tranf "内部函数名")                                 
;;; 参数：函数名的字符串                                       
;;; 返回：T存在或者是可用的内部函数，nil不存在或则无效         
;;; 作者：highflybird                                          
;;; 例子：(tranf "get-logical-drives")                          
;;; 此程序得到网友baitang36和不死猫的大力帮助，特此致谢！      
;;; 另外借鉴了tryhi和其他网友的代码，在此一并感谢！            
;;;-------------------------------------------------------------
(defun HFB-LOAD-TRANF (/ f o l s b)
  (setq o (strcat (getenv "UserProfile") "\\Intern.fas"))
  (if (findfile o)
    (vl-file-delete o)
  )
  (setq        l '(70         65   83   52        45   70          73   76   69         13   49   13
            49         32   36   1        36   51          51   32   48         32   36   86
            58         76   80   80        0    105  110  116  101         114  110  0
            108         112  112  45        115  121  109  102  117         110  45   62
            97         108  0           0        57   3          0    22   36
           )
  )
  (setq b (vlax-make-safearray 17 (cons 0 (1- (length l)))))
  (vlax-safearray-fill b l)
  (setq s (vlax-create-object "ADODB.Stream"))
  (vlax-put s 'type 1)
  (vlax-invoke s 'open)
  (vlax-invoke-method s 'Write b)
  (vlax-invoke s 'saveToFile o 2)
  (vlax-invoke s 'close)
  (vlax-release-object s)
  (mapcar
    'set
    '(:lpp intern lpp-symfun->al)
    (mapcar 'eval (load o))
  )
  (vl-file-delete o)
  (defun tranf (s) (lpp-symfun->al (intern s :lpp)))
  (tranf 'al-add-subr-name)
  (mapcar
    'al-add-subr-name
    '(al-add-subr-name lpp-symfun->al intern tranf)
  )
  (if lpp-symfun->al
    (princ "\n已打开内部函数转普通函数大门.\n")
    (princ "\n激活内部函数转普通函数失败!\n")
  )
)
;激活保留函数功能的自定义函数
(or lpp-symfun->al (HFB-LOAD-TRANF))

;激活itoa进制转换函数(itoa [int] [进制 int])最多32进制
(tranf "itoa")

;字符串分段函数
;参数 str 类型sting
;参数 dimod 当dimod为int时,按int分割(string-Split "asfsgsb" 2)-> '( "as" "fs" gs" b")
;参数 dimod 当dimod为string时,按string 分割(string-Split "assfssgssb" "ss" )-> '( "a" "f" g" b")
(defun string-Split (str dimod / str dimod n nlst)
  (if (= (TYPE dimod) 'INT)
    (progn
      (setq n         1
            nlst nil
      )
      (while (<= n (strlen STR))
        (setq nlst (cons (substr str n dimod) nlst))
        (setq n (+ n dimod))
      )
      (reverse nlst)
    )
    (progn
      (while (setq n (vl-string-search dimod str))
        (setq nlst (cons (substr str 1 n) nlst)
              str  (substr str (+ 1 (strlen dimod) n))
        )
      )
      (reverse (cons str nlst))
    )
  )
)

;二进制字符串转整数
;(2str-to-int "1101")->13
(defun 2str-to-int(str / n int)
  (setq n (strlen str) int 0)
  (while (/= str "")
    (setq n (- n 1))
    (if (= "1" (substr str 1 1))
      (setq int (+ int (expt 2 n)))
      )
    (setq str (substr str 2))
    )
  int
  )
;32float2hex单精度浮点数转16进制字符串
;real 单精度浮点数(此处用小数表示)
;(32float2hex 117.1468)->"42EA4B29"
(defun 32float2hex (real / 16str 2str N laststr 2strlst 2strtointlst
                  16strlst)
  (if (equal real 0 0.00000000000001)
    (setq 16str "00000000")
    (progn
                                        ;判断符号位
      (if (> real 0)
        (setq 2str "0")
        (setq 2str "1")
      )
      (setq real (abs real))
      (SETQ N 127)
      (WHILE (< 2 REAL)
        (SETQ REAL (/ REAL 2.0))
        (SETQ N (1+ N))
      )
      (setq 2str (strcat 2str (itoa n 2))) ;增加阶码位
      (setq real (1- real))                ;取尾数部分
      (setq laststr "")                        ;尾数部分二进制初始值
      (repeat 23;尾数位数
        (setq real (* 2.0 real))
        (if (>= real 1)
          (progn (setq laststr (strcat laststr "1"))
                 (setq real (1- real))
          )
          (setq laststr (strcat laststr "0"))
        )
      )
      (setq 2str (strcat 2str laststr))        ;完整的32位二进制
      (setq 2strlst (string-Split 2str 4)) ;每四位分割成表
      (setq 2strtointlst (mapcar '2str-to-int 2strlst))
                                        ;每四位转换成十进制整数
      (setq 16strlst (mapcar '(lambda (X) (itoa x 16)) 2strtointlst))
                                        ;每个整数转换为16进制字符串
      (setq 16str (strcase(apply 'strcat 16strlst))) ;表中字符串按顺序合并
    )
  )
)
;64float2hex双精度浮点数转16进制字符串
;real 双精度浮点数(此处用小数表示)
;(64float2hex 117.1468)->"405D49652BD3C361"
(defun 64float2hex (real / 16str 2str N laststr 2strlst 2strtointlst
                  16strlst)
  (if (equal real 0 0.00000000000001)
    (setq 16str "0000000000000000")
    (progn
                                        ;判断符号位
      (if (> real 0)
        (setq 2str "0")
        (setq 2str "1")
      )
      (setq real (abs real))
      (SETQ N 1023)
      (WHILE (< 2 REAL)
        (SETQ REAL (/ REAL 2.0))
        (SETQ N (1+ N))
      )
      (setq 2str (strcat 2str (itoa n 2))) ;增加阶码位
      (setq real (1- real))                ;取尾数部分
      (setq laststr "")                        ;位数部分二进制初始值
      (repeat 52
        (setq real (* 2.0 real))
        (if (>= real 1)
          (progn (setq laststr (strcat laststr "1"))
                 (setq real (1- real))
          )
          (setq laststr (strcat laststr "0"))
        )
      )
      (setq 2str (strcat 2str laststr))        ;完整的64位二进制
      (setq 2strlst (string-Split 2str 4)) ;每四位分割成表
      (setq 2strtointlst (mapcar '2str-to-int 2strlst))
                                        ;每四位转换成十进制整数
      (setq 16strlst (mapcar '(lambda (X) (itoa x 16)) 2strtointlst))
                                        ;每个整数转换为16进制字符串
      (setq 16str (strcase(apply 'strcat 16strlst))) ;表中字符串按顺序合并
    )
  )
)

;长度为1的字符串16进制转10进制
(DEFUN 16TO10(str)
  (setq str(strcase str))
  (ascii "9")
  (if(> (ascii str) 57)
    (- (ascii str) 55)
    (read str)
    )
  )
;单字节字符串转10进制
(DEFUN byteto10(str)
  (setq str(strcase str))
  (if (< (strlen str) 2)(setq str (strcat "0" str)))
  (+ (* 16 (16TO10 (substr str 1 1))) (16TO10 (substr str 2 1)))
  )
;多字节字符串转10进制
(DEFUN bytesto10(str)
  (setq lst (mapcar 'byteto10 (string-Split str 2)))
  )
;单字符串前面补位0,n补位个数
(DEFUN add0str (str n)
  (setq str (strcase str))
  (while (< (strlen str) n)
    (setq str (strcat "0" str ))
  )
  str
)
;单字符串后面补位0,n补位个数
(DEFUN addstr0 (str n)
  (setq str (strcase str))
  (while (< (strlen str) n)
    (setq str (strcat  str "0"))
  )
  str
)
;两个常规字符代表一个字节，不足前面补0
(defun onebytes(str)
  (if (/= (strlen str) 2)(add0str str 2)str)
  )
;64hex2float 64位16进制字符串转双精度浮点数
;str 长度位16的字符串
;(64hex2float "405D49652BD3C361")->"117.1468"
(defun 64hex2float (str / 2lst 2str fhw zsw wsw zsm ws wswlst)
  (setq lst (mapcar '16TO10 (string-Split str 1)))
  (setq 2lst (mapcar '(lambda (X) (add0str (itoa x 2) 4)) lst))
  (setq 2str (apply 'strcat 2lst))
  (setq fhw (substr 2str 1 1))
  (setq zsw (substr 2str 2 11))
  (setq wsw (substr 2str 13 52))
  (setq zsm (- (2str-to-int zsw) 1023))
  (setq ws 0.000000000000001)
  (setq wswlst (reverse (string-split wsw 1)))
  (while wswlst
    (if        (= "1" (car wswlst))
      (setq ws (/ (1+ ws) 2.0))
      (setq ws (/ ws 2.0))
    )
    (if        (> ws 1)
      (setq ws (- ws 1))
    )
    (setq wswlst (cdr wswlst))
  )
  (if (= "1" fhw)
    (- 0 (* (+ 1 ws) (expt 2 zsm)))
    (* (+ 1 ws) (expt 2 zsm))
  )
)
;32hex2float 32位16进制字符串转双精度浮点数
;str 长度位8的字符串
;(32hex2float "42EA4B29")->"117.1468"
(defun 32hex2float (str / 2lst 2str fhw zsw wsw zsm ws wswlst)
  (setq lst (mapcar '16TO10 (string-Split str 1)))
  (setq 2lst (mapcar '(lambda (X) (add0str (itoa x 2) 4)) lst))
  (setq 2str (apply 'strcat 2lst))
  (setq fhw (substr 2str 1 1))
  (setq zsw (substr 2str 2 8))
  (setq wsw (substr 2str 10 23))
  (setq zsm (- (2str-to-int zsw) 127))
  (setq ws 0.0000001)
  (setq wswlst (reverse (string-split wsw 1)))
  (while wswlst
    (if        (= "1" (car wswlst))
      (setq ws (/ (1+ ws) 2.0))
      (setq ws (/ ws 2.0))
    )
    (if        (> ws 1)
      (setq ws (- ws 1))
    )
    (setq wswlst (cdr wswlst))
  )
  (if (= "1" fhw)
    (- 0 (* (+ 1 ws) (expt 2 zsm)))
    (* (+ 1 ws) (expt 2 zsm))
  )
)

MZ_li

2. ;;=============================================================
   
3. ;;; 程序加载后，就可以用tranf来激活一个系统隐藏的函数           
   
4. ;;; 用法：(tranf "内部函数名")                                 
   
5. ;;; 参数：函数名的字符串                                       
   
6. ;;; 返回：T存在或者是可用的内部函数，nil不存在或则无效         
   
7. ;;; 作者：highflybird                                          
   
8. ;;; 例子：(tranf "get-logical-drives")                          
   
9. ;;; 此程序得到网友baitang36和不死猫的大力帮助，特此致谢！      
   
10. ;;; 另外借鉴了tryhi和其他网友的代码，在此一并感谢！            
    
11. ;;;-------------------------------------------------------------
    
12. (defun HFB-LOAD-TRANF (/ f o l s b)
    
13.   (setq o (strcat (getenv "UserProfile") "\\Intern.fas"))
    
14.   (if (findfile o)
    
15.     (vl-file-delete o)
    
16.   )
    
17.   (setq        l '(70         65   83   52        45   70          73   76   69         13   49   13
    
18.             49         32   36   1        36   51          51   32   48         32   36   86
    
19.             58         76   80   80        0    105  110  116  101         114  110  0
    
20.             108         112  112  45        115  121  109  102  117         110  45   62
    
21.             97         108  0           0        57   3          0    22   36
    
22.            )
    
23.   )
    
24.   (setq b (vlax-make-safearray 17 (cons 0 (1- (length l)))))
    
25.   (vlax-safearray-fill b l)
    
26.   (setq s (vlax-create-object "ADODB.Stream"))
    
27.   (vlax-put s 'type 1)
    
28.   (vlax-invoke s 'open)
    
29.   (vlax-invoke-method s 'Write b)
    
30.   (vlax-invoke s 'saveToFile o 2)
    
31.   (vlax-invoke s 'close)
    
32.   (vlax-release-object s)
    
33.   (mapcar
    
34.     'set
    
35.     '(:lpp intern lpp-symfun->al)
    
36.     (mapcar 'eval (load o))
    
37.   )
    
38.   (vl-file-delete o)
    
39.   (defun tranf (s) (lpp-symfun->al (intern s :lpp)))
    
40.   (tranf 'al-add-subr-name)
    
41.   (mapcar
    
42.     'al-add-subr-name
    
43.     '(al-add-subr-name lpp-symfun->al intern tranf)
    
44.   )
    
45.   (if lpp-symfun->al
    
46.     (princ "\n已打开内部函数转普通函数大门.\n")
    
47.     (princ "\n激活内部函数转普通函数失败!\n")
    
48.   )
    
49. )
    
50. ;激活保留函数功能的自定义函数
    
51. (or lpp-symfun->al (HFB-LOAD-TRANF))
    
52. 
    
53. ;激活itoa进制转换函数(itoa [int] [进制 int])最多32进制
    
54. (tranf "itoa")
    
55. 
    
56. ;字符串分段函数
    
57. ;参数 str 类型sting
    
58. ;参数 dimod 当dimod为int时,按int分割(string-Split "asfsgsb" 2)-> '( "as" "fs" gs" b")
    
59. ;参数 dimod 当dimod为string时,按string 分割(string-Split "assfssgssb" "ss" )-> '( "a" "f" g" b")
    
60. (defun string-Split (str dimod / str dimod n nlst)
    
61.   (if (= (TYPE dimod) 'INT)
    
62.     (progn
    
63.       (setq n         1
    
64.             nlst nil
    
65.       )
    
66.       (while (<= n (strlen STR))
    
67.         (setq nlst (cons (substr str n dimod) nlst))
    
68.         (setq n (+ n dimod))
    
69.       )
    
70.       (reverse nlst)
    
71.     )
    
72.     (progn
    
73.       (while (setq n (vl-string-search dimod str))
    
74.         (setq nlst (cons (substr str 1 n) nlst)
    
75.               str  (substr str (+ 1 (strlen dimod) n))
    
76.         )
    
77.       )
    
78.       (reverse (cons str nlst))
    
79.     )
    
80.   )
    
81. )
    
82. 
    
83. ;二进制字符串转整数
    
84. ;(2str-to-int "1101")->13
    
85. (defun 2str-to-int(str / n int)
    
86.   (setq n (strlen str) int 0)
    
87.   (while (/= str "")
    
88.     (setq n (- n 1))
    
89.     (if (= "1" (substr str 1 1))
    
90.       (setq int (+ int (expt 2 n)))
    
91.       )
    
92.     (setq str (substr str 2))
    
93.     )
    
94.   int
    
95.   )
    
96. ;32float2hex单精度浮点数转16进制字符串
    
97. ;real 单精度浮点数(此处用小数表示)
    
98. ;(32float2hex 117.1468)->"42EA4B29"
    
99. (defun 32float2hex (real / 16str 2str N laststr 2strlst 2strtointlst
    
100.                   16strlst)
     
101.   (if (equal real 0 0.00000000000001)
     
102.     (setq 16str "00000000")
     
103.     (progn
     
104.                                         ;判断符号位
     
105.       (if (> real 0)
     
106.         (setq 2str "0")
     
107.         (setq 2str "1")
     
108.       )
     
109.       (setq real (abs real))
     
110.       (SETQ N 127)
     
111.       (WHILE (< 2 REAL)
     
112.         (SETQ REAL (/ REAL 2.0))
     
113.         (SETQ N (1+ N))
     
114.       )
     
115.       (setq 2str (strcat 2str (itoa n 2))) ;增加阶码位
     
116.       (setq real (1- real))                ;取尾数部分
     
117.       (setq laststr "")                        ;尾数部分二进制初始值
     
118.       (repeat 23;尾数位数
     
119.         (setq real (* 2.0 real))
     
120.         (if (>= real 1)
     
121.           (progn (setq laststr (strcat laststr "1"))
     
122.                  (setq real (1- real))
     
123.           )
     
124.           (setq laststr (strcat laststr "0"))
     
125.         )
     
126.       )
     
127.       (setq 2str (strcat 2str laststr))        ;完整的32位二进制
     
128.       (setq 2strlst (string-Split 2str 4)) ;每四位分割成表
     
129.       (setq 2strtointlst (mapcar '2str-to-int 2strlst))
     
130.                                         ;每四位转换成十进制整数
     
131.       (setq 16strlst (mapcar '(lambda (X) (itoa x 16)) 2strtointlst))
     
132.                                         ;每个整数转换为16进制字符串
     
133.       (setq 16str (strcase(apply 'strcat 16strlst))) ;表中字符串按顺序合并
     
134.     )
     
135.   )
     
136. )
     
137. ;64float2hex双精度浮点数转16进制字符串
     
138. ;real 双精度浮点数(此处用小数表示)
     
139. ;(64float2hex 117.1468)->"405D49652BD3C361"
     
140. (defun 64float2hex (real / 16str 2str N laststr 2strlst 2strtointlst
     
141.                   16strlst)
     
142.   (if (equal real 0 0.00000000000001)
     
143.     (setq 16str "0000000000000000")
     
144.     (progn
     
145.                                         ;判断符号位
     
146.       (if (> real 0)
     
147.         (setq 2str "0")
     
148.         (setq 2str "1")
     
149.       )
     
150.       (setq real (abs real))
     
151.       (SETQ N 1023)
     
152.       (WHILE (< 2 REAL)
     
153.         (SETQ REAL (/ REAL 2.0))
     
154.         (SETQ N (1+ N))
     
155.       )
     
156.       (setq 2str (strcat 2str (itoa n 2))) ;增加阶码位
     
157.       (setq real (1- real))                ;取尾数部分
     
158.       (setq laststr "")                        ;位数部分二进制初始值
     
159.       (repeat 52
     
160.         (setq real (* 2.0 real))
     
161.         (if (>= real 1)
     
162.           (progn (setq laststr (strcat laststr "1"))
     
163.                  (setq real (1- real))
     
164.           )
     
165.           (setq laststr (strcat laststr "0"))
     
166.         )
     
167.       )
     
168.       (setq 2str (strcat 2str laststr))        ;完整的64位二进制
     
169.       (setq 2strlst (string-Split 2str 4)) ;每四位分割成表
     
170.       (setq 2strtointlst (mapcar '2str-to-int 2strlst))
     
171.                                         ;每四位转换成十进制整数
     
172.       (setq 16strlst (mapcar '(lambda (X) (itoa x 16)) 2strtointlst))
     
173.                                         ;每个整数转换为16进制字符串
     
174.       (setq 16str (strcase(apply 'strcat 16strlst))) ;表中字符串按顺序合并
     
175.     )
     
176.   )
     
177. )
     
178. 
     
179. ;长度为1的字符串16进制转10进制
     
180. (DEFUN 16TO10(str)
     
181.   (setq str(strcase str))
     
182.   (ascii "9")
     
183.   (if(> (ascii str) 57)
     
184.     (- (ascii str) 55)
     
185.     (read str)
     
186.     )
     
187.   )
     
188. ;单字节字符串转10进制
     
189. (DEFUN byteto10(str)
     
190.   (setq str(strcase str))
     
191.   (if (< (strlen str) 2)(setq str (strcat "0" str)))
     
192.   (+ (* 16 (16TO10 (substr str 1 1))) (16TO10 (substr str 2 1)))
     
193.   )
     
194. ;多字节字符串转10进制
     
195. (DEFUN bytesto10(str)
     
196.   (setq lst (mapcar 'byteto10 (string-Split str 2)))
     
197.   )
     
198. ;单字符串前面补位0,n补位个数
     
199. (DEFUN add0str (str n)
     
200.   (setq str (strcase str))
     
201.   (while (< (strlen str) n)
     
202.     (setq str (strcat "0" str ))
     
203.   )
     
204.   str
     
205. )
     
206. ;单字符串后面补位0,n补位个数
     
207. (DEFUN addstr0 (str n)
     
208.   (setq str (strcase str))
     
209.   (while (< (strlen str) n)
     
210.     (setq str (strcat  str "0"))
     
211.   )
     
212.   str
     
213. )
     
214. ;两个常规字符代表一个字节，不足前面补0
     
215. (defun onebytes(str)
     
216.   (if (/= (strlen str) 2)(add0str str 2)str)
     
217.   )
     
218. ;64hex2float 64位16进制字符串转双精度浮点数
     
219. ;str 长度位16的字符串
     
220. ;(64hex2float "405D49652BD3C361")->"117.1468"
     
221. (defun 64hex2float (str / 2lst 2str fhw zsw wsw zsm ws wswlst)
     
222.   (setq lst (mapcar '16TO10 (string-Split str 1)))
     
223.   (setq 2lst (mapcar '(lambda (X) (add0str (itoa x 2) 4)) lst))
     
224.   (setq 2str (apply 'strcat 2lst))
     
225.   (setq fhw (substr 2str 1 1))
     
226.   (setq zsw (substr 2str 2 11))
     
227.   (setq wsw (substr 2str 13 52))
     
228.   (setq zsm (- (2str-to-int zsw) 1023))
     
229.   (setq ws 0.000000000000001)
     
230.   (setq wswlst (reverse (string-split wsw 1)))
     
231.   (while wswlst
     
232.     (if        (= "1" (car wswlst))
     
233.       (setq ws (/ (1+ ws) 2.0))
     
234.       (setq ws (/ ws 2.0))
     
235.     )
     
236.     (if        (> ws 1)
     
237.       (setq ws (- ws 1))
     
238.     )
     
239.     (setq wswlst (cdr wswlst))
     
240.   )
     
241.   (if (= "1" fhw)
     
242.     (- 0 (* (+ 1 ws) (expt 2 zsm)))
     
243.     (* (+ 1 ws) (expt 2 zsm))
     
244.   )
     
245. )
     
246. ;32hex2float 32位16进制字符串转双精度浮点数
     
247. ;str 长度位8的字符串
     
248. ;(32hex2float "42EA4B29")->"117.1468"
     
249. (defun 32hex2float (str / 2lst 2str fhw zsw wsw zsm ws wswlst)
     
250.   (setq lst (mapcar '16TO10 (string-Split str 1)))
     
251.   (setq 2lst (mapcar '(lambda (X) (add0str (itoa x 2) 4)) lst))
     
252.   (setq 2str (apply 'strcat 2lst))
     
253.   (setq fhw (substr 2str 1 1))
     
254.   (setq zsw (substr 2str 2 8))
     
255.   (setq wsw (substr 2str 10 23))
     
256.   (setq zsm (- (2str-to-int zsw) 127))
     
257.   (setq ws 0.0000001)
     
258.   (setq wswlst (reverse (string-split wsw 1)))
     
259.   (while wswlst
     
260.     (if        (= "1" (car wswlst))
     
261.       (setq ws (/ (1+ ws) 2.0))
     
262.       (setq ws (/ ws 2.0))
     
263.     )
     
264.     (if        (> ws 1)
     
265.       (setq ws (- ws 1))
     
266.     )
     
267.     (setq wswlst (cdr wswlst))
     
268.   )
     
269.   (if (= "1" fhw)
     
270.     (- 0 (* (+ 1 ws) (expt 2 zsm)))
     
271.     (* (+ 1 ws) (expt 2 zsm))
     
272.   )
     
273. )

;;=============================================================<br /> ;;; 程序加载后，就可以用tranf来激活一个系统隐藏的函数           <br /> ;;; 用法：(tranf "内部函数名")                                 <br /> ;;; 参数：函数名的字符串                                       <br /> ;;; 返回：T存在或者是可用的内部函数，nil不存在或则无效         <br /> ;;; 作者：highflybird                                          <br /> ;;; 例子：(tranf "get-logical-drives")                          <br /> ;;; 此程序得到网友baitang36和不死猫的大力帮助，特此致谢！      <br /> ;;; 另外借鉴了tryhi和其他网友的代码，在此一并感谢！            <br /> ;;;-------------------------------------------------------------<br /> (defun HFB-LOAD-TRANF (/ f o l s b)<br />   (setq o (strcat (getenv "UserProfile") "\\Intern.fas"))<br />   (if (findfile o)<br />     (vl-file-delete o)<br />   )<br />   (setq        l '(70         65   83   52        45   70          73   76   69         13   49   13<br />             49         32   36   1        36   51          51   32   48         32   36   86<br />             58         76   80   80        0    105  110  116  101         114  110  0<br />             108         112  112  45        115  121  109  102  117         110  45   62<br />             97         108  0           0        57   3          0    22   36<br />            )<br />   )<br />   (setq b (vlax-make-safearray 17 (cons 0 (1- (length l)))))<br />   (vlax-safearray-fill b l)<br />   (setq s (vlax-create-object "ADODB.Stream"))<br />   (vlax-put s 'type 1)<br />   (vlax-invoke s 'open)<br />   (vlax-invoke-method s 'Write b)<br />   (vlax-invoke s 'saveToFile o 2)<br />   (vlax-invoke s 'close)<br />   (vlax-release-object s)<br />   (mapcar<br />     'set<br />     '(:lpp intern lpp-symfun->al)<br />     (mapcar 'eval (load o))<br />   )<br />   (vl-file-delete o)<br />   (defun tranf (s) (lpp-symfun->al (intern s :lpp)))<br />   (tranf 'al-add-subr-name)<br />   (mapcar<br />     'al-add-subr-name<br />     '(al-add-subr-name lpp-symfun->al intern tranf)<br />   )<br />   (if lpp-symfun->al<br />     (princ "\n已打开内部函数转普通函数大门.\n")<br />     (princ "\n激活内部函数转普通函数失败!\n")<br />   )<br /> )<br /> ;激活保留函数功能的自定义函数<br /> (or lpp-symfun->al (HFB-LOAD-TRANF))<br /> <br /> ;激活itoa进制转换函数(itoa [int] [进制 int])最多32进制<br /> (tranf "itoa")<br /> <br /> ;字符串分段函数<br /> ;参数 str 类型sting<br /> ;参数 dimod 当dimod为int时,按int分割(string-Split "asfsgsb" 2)-> '( "as" "fs" gs" b")<br /> ;参数 dimod 当dimod为string时,按string 分割(string-Split "assfssgssb" "ss" )-> '( "a" "f" g" b")<br /> (defun string-Split (str dimod / str dimod n nlst)<br />   (if (= (TYPE dimod) 'INT)<br />     (progn<br />       (setq n         1<br />             nlst nil<br />       )<br />       (while (<= n (strlen STR))<br />         (setq nlst (cons (substr str n dimod) nlst))<br />         (setq n (+ n dimod))<br />       )<br />       (reverse nlst)<br />     )<br />     (progn<br />       (while (setq n (vl-string-search dimod str))<br />         (setq nlst (cons (substr str 1 n) nlst)<br />               str  (substr str (+ 1 (strlen dimod) n))<br />         )<br />       )<br />       (reverse (cons str nlst))<br />     )<br />   )<br /> )<br /> <br /> ;二进制字符串转整数<br /> ;(2str-to-int "1101")->13<br /> (defun 2str-to-int(str / n int)<br />   (setq n (strlen str) int 0)<br />   (while (/= str "")<br />     (setq n (- n 1))<br />     (if (= "1" (substr str 1 1))<br />       (setq int (+ int (expt 2 n)))<br />       )<br />     (setq str (substr str 2))<br />     )<br />   int<br />   )<br /> ;32float2hex单精度浮点数转16进制字符串<br /> ;real 单精度浮点数(此处用小数表示)<br /> ;(32float2hex 117.1468)->"42EA4B29"<br /> (defun 32float2hex (real / 16str 2str N laststr 2strlst 2strtointlst<br />                   16strlst)<br />   (if (equal real 0 0.00000000000001)<br />     (setq 16str "00000000")<br />     (progn<br />                                         ;判断符号位<br />       (if (> real 0)<br />         (setq 2str "0")<br />         (setq 2str "1")<br />       )<br />       (setq real (abs real))<br />       (SETQ N 127)<br />       (WHILE (< 2 REAL)<br />         (SETQ REAL (/ REAL 2.0))<br />         (SETQ N (1+ N))<br />       )<br />       (setq 2str (strcat 2str (itoa n 2))) ;增加阶码位<br />       (setq real (1- real))                ;取尾数部分<br />       (setq laststr "")                        ;尾数部分二进制初始值<br />       (repeat 23;尾数位数<br />         (setq real (* 2.0 real))<br />         (if (>= real 1)<br />           (progn (setq laststr (strcat laststr "1"))<br />                  (setq real (1- real))<br />           )<br />           (setq laststr (strcat laststr "0"))<br />         )<br />       )<br />       (setq 2str (strcat 2str laststr))        ;完整的32位二进制<br />       (setq 2strlst (string-Split 2str 4)) ;每四位分割成表<br />       (setq 2strtointlst (mapcar '2str-to-int 2strlst))<br />                                         ;每四位转换成十进制整数<br />       (setq 16strlst (mapcar '(lambda (X) (itoa x 16)) 2strtointlst))<br />                                         ;每个整数转换为16进制字符串<br />       (setq 16str (strcase(apply 'strcat 16strlst))) ;表中字符串按顺序合并<br />     )<br />   )<br /> )<br /> ;64float2hex双精度浮点数转16进制字符串<br /> ;real 双精度浮点数(此处用小数表示)<br /> ;(64float2hex 117.1468)->"405D49652BD3C361"<br /> (defun 64float2hex (real / 16str 2str N laststr 2strlst 2strtointlst<br />                   16strlst)<br />   (if (equal real 0 0.00000000000001)<br />     (setq 16str "0000000000000000")<br />     (progn<br />                                         ;判断符号位<br />       (if (> real 0)<br />         (setq 2str "0")<br />         (setq 2str "1")<br />       )<br />       (setq real (abs real))<br />       (SETQ N 1023)<br />       (WHILE (< 2 REAL)<br />         (SETQ REAL (/ REAL 2.0))<br />         (SETQ N (1+ N))<br />       )<br />       (setq 2str (strcat 2str (itoa n 2))) ;增加阶码位<br />       (setq real (1- real))                ;取尾数部分<br />       (setq laststr "")                        ;位数部分二进制初始值<br />       (repeat 52<br />         (setq real (* 2.0 real))<br />         (if (>= real 1)<br />           (progn (setq laststr (strcat laststr "1"))<br />                  (setq real (1- real))<br />           )<br />           (setq laststr (strcat laststr "0"))<br />         )<br />       )<br />       (setq 2str (strcat 2str laststr))        ;完整的64位二进制<br />       (setq 2strlst (string-Split 2str 4)) ;每四位分割成表<br />       (setq 2strtointlst (mapcar '2str-to-int 2strlst))<br />                                         ;每四位转换成十进制整数<br />       (setq 16strlst (mapcar '(lambda (X) (itoa x 16)) 2strtointlst))<br />                                         ;每个整数转换为16进制字符串<br />       (setq 16str (strcase(apply 'strcat 16strlst))) ;表中字符串按顺序合并<br />     )<br />   )<br /> )<br /> <br /> ;长度为1的字符串16进制转10进制<br /> (DEFUN 16TO10(str)<br />   (setq str(strcase str))<br />   (ascii "9")<br />   (if(> (ascii str) 57)<br />     (- (ascii str) 55)<br />     (read str)<br />     )<br />   )<br /> ;单字节字符串转10进制<br /> (DEFUN byteto10(str)<br />   (setq str(strcase str))<br />   (if (< (strlen str) 2)(setq str (strcat "0" str)))<br />   (+ (* 16 (16TO10 (substr str 1 1))) (16TO10 (substr str 2 1)))<br />   )<br /> ;多字节字符串转10进制<br /> (DEFUN bytesto10(str)<br />   (setq lst (mapcar 'byteto10 (string-Split str 2)))<br />   )<br /> ;单字符串前面补位0,n补位个数<br /> (DEFUN add0str (str n)<br />   (setq str (strcase str))<br />   (while (< (strlen str) n)<br />     (setq str (strcat "0" str ))<br />   )<br />   str<br /> )<br /> ;单字符串后面补位0,n补位个数<br /> (DEFUN addstr0 (str n)<br />   (setq str (strcase str))<br />   (while (< (strlen str) n)<br />     (setq str (strcat  str "0"))<br />   )<br />   str<br /> )<br /> ;两个常规字符代表一个字节，不足前面补0<br /> (defun onebytes(str)<br />   (if (/= (strlen str) 2)(add0str str 2)str)<br />   )<br /> ;64hex2float 64位16进制字符串转双精度浮点数<br /> ;str 长度位16的字符串<br /> ;(64hex2float "405D49652BD3C361")->"117.1468"<br /> (defun 64hex2float (str / 2lst 2str fhw zsw wsw zsm ws wswlst)<br />   (setq lst (mapcar '16TO10 (string-Split str 1)))<br />   (setq 2lst (mapcar '(lambda (X) (add0str (itoa x 2) 4)) lst))<br />   (setq 2str (apply 'strcat 2lst))<br />   (setq fhw (substr 2str 1 1))<br />   (setq zsw (substr 2str 2 11))<br />   (setq wsw (substr 2str 13 52))<br />   (setq zsm (- (2str-to-int zsw) 1023))<br />   (setq ws 0.000000000000001)<br />   (setq wswlst (reverse (string-split wsw 1)))<br />   (while wswlst<br />     (if        (= "1" (car wswlst))<br />       (setq ws (/ (1+ ws) 2.0))<br />       (setq ws (/ ws 2.0))<br />     )<br />     (if        (> ws 1)<br />       (setq ws (- ws 1))<br />     )<br />     (setq wswlst (cdr wswlst))<br />   )<br />   (if (= "1" fhw)<br />     (- 0 (* (+ 1 ws) (expt 2 zsm)))<br />     (* (+ 1 ws) (expt 2 zsm))<br />   )<br /> )<br /> ;32hex2float 32位16进制字符串转双精度浮点数<br /> ;str 长度位8的字符串<br /> ;(32hex2float "42EA4B29")->"117.1468"<br /> (defun 32hex2float (str / 2lst 2str fhw zsw wsw zsm ws wswlst)<br />   (setq lst (mapcar '16TO10 (string-Split str 1)))<br />   (setq 2lst (mapcar '(lambda (X) (add0str (itoa x 2) 4)) lst))<br />   (setq 2str (apply 'strcat 2lst))<br />   (setq fhw (substr 2str 1 1))<br />   (setq zsw (substr 2str 2 8))<br />   (setq wsw (substr 2str 10 23))<br />   (setq zsm (- (2str-to-int zsw) 127))<br />   (setq ws 0.0000001)<br />   (setq wswlst (reverse (string-split wsw 1)))<br />   (while wswlst<br />     (if        (= "1" (car wswlst))<br />       (setq ws (/ (1+ ws) 2.0))<br />       (setq ws (/ ws 2.0))<br />     )<br />     (if        (> ws 1)<br />       (setq ws (- ws 1))<br />     )<br />     (setq wswlst (cdr wswlst))<br />   )<br />   (if (= "1" fhw)<br />     (- 0 (* (+ 1 ws) (expt 2 zsm)))<br />     (* (+ 1 ws) (expt 2 zsm))<br />   )<br /> )

tryhi

这么好的函数居然没评论