[LISP程序]：lsp文件转换为HTM（按照语法着色）

carrot1983 · 发表于 2007-6-4 12:55:54

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

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

×

终于在版主栏上看到zm184。激动的话就不多说了。。。
先说这个lsp2htm。我觉得好神奇啊。。。
lsp感觉比其它语言更容易入门。。。
但是如果要深入进去，没有像楼主这种勇于探索的精神很难体会到它的强大。。。
惭愧啊。。。学习学习。。。

它山之石 · 发表于 2007-6-28 14:23:21

<HTML>
<HEAD><TITLE>F:\test\LISP文件转换为HTML文件.lsp</TITLE></HEAD>
<BODY >
<CENTER><H1>LISP文件转换为HTML文件.lsp</H1></CENTER>
<SCRIPT LANGUAGE="JavaScript">document.write("最后修改时间: " + document.lastModified)
</SCRIPT>
<HR SIZE=5>
<pre>
 1.;;; ==================================
 2.;;; |　 LISP文件转换成HTML文件程序 |
 3.;;; | UPDATE:2007-06-26 |
 4.;;; | <a href="http://www.xdcad.net/forum/showthread.php?s=&threadid=633350&perpage=15&display=&pagenumber=2">[晓东论坛]</a> |
 5.;;; | <a href="http://www.tstmr.com/tmr/dispbbs.asp?boardid=7&id=550&star=1#550">[同是土木人论坛]</a> |
 6.;;; | <a href="http://StoneDWG.ys168.com">[它山之石图形工作室]</a> |
 7.;;; ==================================
 8.
 9.;|
 10.1、此程序仅作为一种应用上的参考，更多功能请自
 11.　行定制或关注作者发布的应用程序。
 12.2、程序主框架来自于晓东论坛，原作者为snoopychen，
 13.　参考了zml84的一小部分代码（html文件头部）。
 14.3、原程序未对行内注释进行处理，增加此功能。
 15.4、有特殊前缀的自定义函数颜色设定为特殊着色，
 16.　主要用来与内部函数进行区分。
 17.5、增加链接跳转功能，文件中的外部链接会指向特定的网页，
 18.　内部链接会指向子函数的定义处。
 19.6、增加了行号，方便阅读。缩进好象变得有问题，待查。
 20.7、原程序需手工输入目录，修改为对话框选择的方式。
 21.8、原程序为将整个目录（含子目录）下的LISP文件全部转换，
 22.　增加了只转换一个文件的命令。
 23.9、对原程序增加了部分简单的注释说明，不一定正确。
 24.10、增加了个显示程序正在运行的小把戏，纯属好玩而已。
 25.11、将LISP转换为HTML方便网络发布及程序的管理。
 26.　　目前还有些想法没有实现，慢慢研究。
 27.|;
 28.
 29.
 30.;;;命令一，仅转换选择的一个LSP文件
 31.(defun <a name="c:LISP2HTML">c:LISP2HTML</a> (/ file)
 32. (setq file (getfiled "Select Lisp File" (getvar "dwgprefix") "lsp" 0))
 33. (<a href="#GL_lsp->html">GL_lsp->html</a> file)
 34. (princ
 35. (strcat "\n*** LISP文件转换为HTML文件软件 V070628 ***")
 36. ) ;_ 结束princ
 37. (princ (strcat "\n <a href="http://StoneDWG.ys168.com">[它山之石图形工作室]</a>"))
 38. (princ)
 39.) ;_ 结束defun
 40.
 41.;;;命令二，转换选择的目录下（包括子目录）的所有LSP文件
 42.(defun <a name="c:LISPS2HTML">c:LISPS2HTML</a> (/ direc directree x y direcfile)
 43. (setq direc (<a href="#GL_GetDir">GL_GetDir</a>))
 44. (setq directree (<a href="#GL_GetSubFolders">GL_GetSubFolders</a> direc))
 45. (foreach x directree
 46. (setq direcfile (<a href="#GL_GetOnlyFiles">GL_GetOnlyFiles</a> x))
 47. (foreach y direcfile
 48. (if (= (vl-filename-extension y) ".lsp")
 49. (<a href="#GL_lsp->html">GL_lsp->html</a> y)
 50. ) ;_ 结束if
 51. ) ;_ 结束foreach
 52. ) ;_ 结束foreach
 53. (princ
 54. (strcat "\n*** LISP文件转换为HTML文件软件 V070628 ***")
 55. ) ;_ 结束princ
 56. (princ (strcat "\n <a href="http://StoneDWG.ys168.com">[它山之石图形工作室]</a>"))
 57. (princ)
 58.) ;_ 结束defun
 59.
 60.
 61.;;;子函数，定义程序进度条的显示
 62.(defun <a name="GL_Spinner">GL_Spinner</a> (/)
 63. (if (not #spin)
 64. (setq #spin "-")
 65. ) ;_ 结束if
 66. (cond
 67. ((equal #spin "-") (setq #spin "\\"))
 68. ((equal #spin "\\") (setq #spin "|"))
 69. ((equal #spin "|") (setq #spin "/"))
 70. (T (setq #spin "-"))
 71. ) ;_ 结束cond
 72. (princ (strcat (chr 8) #spin))
 73. (princ)
 74.) ;_ 结束defun
 75.
 76.
 77.;;子函数
 78.;;利用WSH得到目录，返回如："E;\\TEST"
 79.(defun <a name="GL_GetDir">GL_GetDir</a> (/ catchit msg path rtn shfolder winshell)
 80. (if (null MSG)
 81. (setq MSG "请选择文件夹（LISP－＞HTML）")
 82. ) ;_ 结束if
 83. (if (setq winshell (vlax-create-object "Shell.Application"))
 84. (progn
 85. (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1)
 86. catchit (vl-catch-all-apply
 87. '(lambda ()
 88. (setq shFolder (vlax-get-property shFolder 'self))
 89. (setq path (vlax-get-property shFolder 'path))
 90. ) ;_ 结束lambda
 91. ) ;_ 结束vl-catch-all-apply
 92. ) ;_ 结束setq
 93. (vlax-release-object shFolder)
 94. (vlax-release-object winshell)
 95. (if (vl-catch-all-error-p catchit)
 96. (setq rtn nil)
 97. (setq rtn path)
 98. ) ;_ 结束if
 99. ) ;_ 结束progn
 100. ) ;_ 结束if
 101. rtn
 102.) ;_ 结束defun
 103.
 104.;;子函数
 105.(defun <a name="GL_html-format">GL_html-format</a> (str)
 106. (vl-string-subst
 107. "&lt;"
 108. "<"
 109. (vl-string-subst "&amp;" "&" str)
 110. ) ;_ 结束vl-string-subst
 111.) ;_ 结束defun
 112.
 113.;;主函数
 114.(defun <a name="GL_lsp->html">GL_lsp->html</a> (file / No Noo rf
 115. wf t1 str char i
 116. f argument strtest hnzhsh-s hnzhsh-e
 117. strr str_stonedwg str_tstmr
 118. str_xd word
 119. )
 120. (princ (strcat "\n" file))
 121. (princ "\n正在转换成HTML文件，请稍等... ")
 122. ;;打开准备读写的文件
 123. (setq rf (open file "r")
 124. wf (open (strcat (vl-filename-directory file)
 125. "/"
 126. (vl-filename-base file)
 127. ".html"
 128. ) ;_ 结束strcat
 129. "w"
 130. ) ;_ 结束open
 131. ) ;_ 结束setq
 132.
 133. ;;★1写入htm文件头部
 134. ;;20070620修改时间没定义　需要处理
 135. ;;20070621跟下面字符的大小写有关，已经解决
 136. (write-line
 137. (STRCAT
 138. "<HTML>\n<HEAD><TITLE>"
 139. FILE
 140. "</TITLE></HEAD>\n<BODY >"
 141. "\n<CENTER><H1>"
 142. (VL-FILENAME-BASE FILE)
 143. (VL-FILENAME-EXTENSION FILE)
 144. "</H1></CENTER>"
 145. "\n<SCRIPT LANGUAGE=\"JavaScript\">document.write"
 146. "(\"最后修改时间: \" + document.lastModified)"
 147. "\n</SCRIPT>"
 148. "\n<HR SIZE=5>"
 149. ) ;_ 结束strcat
 150. wf
 151. ) ;_ 结束write-line
 152.
 153. ;;★2设置默认字体等
 154. (write-line
 155. "<pre>"
 156. wf
 157. ) ;_ 结束write-line
 158. ;;以下设置自动加链接的网址
 159. ;;此情况下str_xd颜色为蓝色，有误。后面两个变量颜色正确，待查。
 160. (setq str_xd
 161. "<a href=\"http://www.xdcad.net\"><a href="http://www.xdcad.net">[晓东论坛]</a></a>"
 162. str_tstmr
 163. "<a href=\"http://www.tstmr.com\"><a href="http://www.tstmr.com">[同是土木人论坛]</a></a>"
 164. str_stonedwg
 165. "<a href=\"http://StoneDWG.ys168.com\"><a href="http://StoneDWG.ys168.com">[它山之石图形工作室]</a></a>"
 166. ) ;_ 结束setq
 167. ;;初始化行号
 168. (setq No 1)
 169. ;;以下逐行处理
 170. (while (setq t1 (read-line rf))
 171. (setq str ""
 172. i 1
 173. ) ;_ 结束setq
 174. (while (<= i (strlen t1))
 175. (setq word "")
 176. ;;以下得到一个单词
 177. (while (not (member (setq char (substr t1 i 1))
 178. '("" " " ";" "(" ")" "\"")
 179. ) ;_ 结束member
 180. ) ;_ 结束not
 181. (<a href="#GL_Spinner">GL_Spinner</a>)
 182. (setq word (strcat word char)
 183. i (1+ i)
 184. ) ;_ 结束setq
 185. ) ;_ 结束while
 186. ;;如果为空行
 187. (if (= word "")
 188. (setq word char
 189. i (+ i (strlen char))
 190. ) ;_ 结束setq
 191. ) ;_ 结束if
 192.
 193. (if (or strtest (= word ";"))
 194. ;;如果是注释
 195. ;;20070620实际上需要处理行间注释
 196. (progn
 197. ;;20070621解决行间注释不在一行内的情况
 198. (if strtest
 199. (if (setq hnzhsh-e (vl-string-search "|;" t1))
 200. (setq strr (substr t1 1 (+ 2 hnzhsh-e))
 201. i (+ hnzhsh-e 3)
 202. strtest nil
 203. ) ;_ 结束setq
 204. (setq strr t1
 205. i (1+ (strlen t1))
 206. ) ;_ 结束setq
 207. ) ;_ 结束if
 208.
 209. ;;20070621解决行间注释在一行内的情况
 210. (if (setq hnzhsh-s (vl-string-search ";|" t1))
 211. (if (setq hnzhsh-e (vl-string-search "|;" t1))
 212. (setq strr (substr t1
 213. (+ hnzhsh-s 1)
 214. (+ 2 (- hnzhsh-e hnzhsh-s))
 215. ) ;_ 结束substr
 216. i (+ hnzhsh-e 3)
 217. ) ;_ 结束setq
 218. (setq strr (substr t1 (+ hnzhsh-s 1))
 219. i (1+ (strlen t1))
 220. strtest T
 221. ) ;_ 结束setq
 222. ) ;_ 结束if
 223. (setq strr (substr t1 (1- i))
 224. i (1+ (strlen t1))
 225. ) ;_ 结束setq
 226. ) ;_ 结束if
 227. ) ;_ 结束if
 228. (setq str
 229. (strcat
 230. str
 231. ""
 232. (<a href="#GL_html-format">GL_html-format</a> strr)
 233. ""
 234. ) ;_ 结束strcat
 235. ) ;_ 结束setq
 236. ) ;_ 结束progn
 237. ;;如果不是注释
 238. (cond
 239.
 240. ;;★★如果是括号
 241. ((member word '("(" ")"))
 242. (setq str (strcat str "")
 243. i (1- i)
 244. ) ;_ 结束setq
 245. ;;继续处理括号
 246. (while (member (setq char (substr t1 i 1))
 247. '("(" ")")
 248. ) ;_ 结束member
 249. (setq str (strcat str char)
 250. i (1+ i)
 251. ) ;_ 结束setq
 252. ) ;_ 结束while
 253. (setq str (strcat str "")
 254. f (= (substr t1 (1- i) 1) "(")
 255. ) ;_ 结束setq
 256. )
 257. ;;★★如果是引号（字符串）
 258. ((= word "\"")
 259. (setq str (strcat str "" word))
 260. (while (and
 261. (/= (setq char (substr t1 i 1))
 262. ""
 263. ) ;_ 结束/=
 264. (or
 265. (/= char "\"")
 266. (and
 267. (> i 1)
 268. (= (substr t1 (1- i) 1) "\\")
 269. (or
 270. (= i 2)
 271. (/= (substr t1 (- i 2) 1) "\\")
 272. ) ;_ 结束or
 273. ) ;_ 结束and
 274. ) ;_ 结束or
 275. ) ;_ 结束and
 276. (setq str (strcat str (<a href="#GL_html-format">GL_html-format</a> char))
 277. i (1+ i)
 278. ) ;_ 结束setq
 279. ) ;_ 结束while
 280. (setq str (strcat str char "")
 281. i (1+ i)
 282. ) ;_ 结束setq
 283. )
 284. ;;★★
 285. ((= word "'")
 286. (setq str (strcat str "'"))
 287. )
 288. ;;★★
 289. ((= word "/")
 290. (setq str (strcat str "/")
 291. argument nil
 292. f nil
 293. ) ;_ 结束setq
 294. )
 295. ;;★★
 296. ((= word ".")
 297. (setq str (strcat str word))
 298. )
 299. ;;★★如果是整数
 300. ((numberp (read word))
 301. (setq str (strcat str "" word "")
 302. f nil
 303. ) ;_ 结束setq
 304. )
 305. ;;★★如果是左括号之后的字符串
 306. (f
 307. (if argument
 308. ;;★★★如果之前的字符串是"DEFUN"(全局变量)，则为黑色
 309. (setq str (strcat str (<a href="#GL_html-format">GL_html-format</a> word))
 310. argument nil
 311. f nil
 312. ) ;_ 结束setq
 313. ;;★★★如果之前的字符串不是"DEFUN"(函数名)，则为蓝色
 314. (setq str (if (wcmatch (strcase word) "GL_*,GL-*")
 315. ;;20070626自定义函数为青色并增加链接跳转到定义处之功能
 316. ;;因为原程序为读一行处理完接着写入，不方便对全文统一处理加链接
 317. ;;只能先针对有特定前缀的自定义函数进行链接
 318. ;;另外如何在函数定义处增加链接回跳到上页链接处有待研究
 319. ;;<a href="#top">可跳转到顶部
 320. (strcat str
 321. "<a href=\"#"
 322. word
 323. "\">"
 324. ""
 325. (<a href="#GL_html-format">GL_html-format</a> word)
 326. ""
 327. "</a>"
 328. ) ;_ 结束strcat
 329. (strcat str
 330. ""
 331. (<a href="#GL_html-format">GL_html-format</a> word)
 332. ""
 333. ) ;_ 结束strcat
 334. ) ;_ 结束if
 335. argument (= (strcase word) "DEFUN")
 336. f nil
 337. ) ;_ 结束setq
 338. ) ;_ 结束if
 339. )
 340. ;;★★
 341. (T
 342. (if (and argument (/= word " "))
 343. ;;★★★20070626 如果之前的字符串是"DEFUN"，则增加标签，为链接作准备
 344. (setq str (strcat str
 345. "<a name=\""
 346. word
 347. "\">"
 348. (<a href="#GL_html-format">GL_html-format</a> word)
 349. "</a>"
 350. ) ;_ 结束strcat
 351. ) ;_ 结束setq
 352. (setq str (strcat str (<a href="#GL_html-format">GL_html-format</a> word)))
 353. ) ;_ 结束if
 354. ) ;_ 结束T
 355. ) ;_ 结束cond
 356. ) ;_ 结束if
 357. ) ;_ 结束while
 358.
 359. ;;此处可以用表来批量处理
 360. ;;也可以将论坛网址、程序作者的主页或博客等写在一个文件里
 361. ;;或者将收集的程序原下载网址自动转换为链接
 362. ;;以下仅为参考
 363. (if (vl-string-search "<a href="http://www.xdcad.net">[晓东论坛]</a>" str)
 364. (setq str (vl-string-subst str_xd "<a href="http://www.xdcad.net">[晓东论坛]</a>" str))
 365. ) ;_ 结束if
 366. (if (vl-string-search "<a href="http://www.tstmr.com">[同是土木人论坛]</a>" str)
 367. (setq str (vl-string-subst str_tstmr "<a href="http://www.tstmr.com">[同是土木人论坛]</a>" str))
 368. ) ;_ 结束if
 369. (if (vl-string-search "<a href="http://StoneDWG.ys168.com">[它山之石图形工作室]</a>" str)
 370. (setq
 371. str (vl-string-subst str_stonedwg "<a href="http://StoneDWG.ys168.com">[它山之石图形工作室]</a>" str)
 372. ) ;_ 结束setq
 373. ) ;_ 结束if
 374.
 375. ;;20070626　添加行号
 376. ;;方便阅读，但不方便复制粘贴为LISP文件
 377. (setq Noo (rtos No 2 0)
 378. Noo (cond
 379. ((= 1 (strlen Noo))
 380. (strcat " " Noo)
 381. )
 382. ((= 2 (strlen Noo))
 383. (strcat " " Noo)
 384. )
 385. ((= 3 (strlen Noo))
 386. (strcat " " Noo)
 387. )
 388. ) ;_ 结束cond
 389. ) ;_ 结束setq
 390. ;;如果是10的倍数行为红色，其它为绿色
 391. (setq Noo (strcat (if (= (substr Noo (strlen Noo)) "0")
 392. ""
 393. ""
 394. ) ;_ 结束if
 395. Noo
 396. ""
 397. ) ;_ 结束strcat
 398. ) ;_ 结束setq
 399. ;;添加行号后，缩进好象变得有问题，暂未有解决方法
 400. (setq str (strcat Noo "." str))
 401. (setq No (1+ No))
 402. (write-line str wf)
 403. ) ;_ 结束while
 404.
 405. ;;★3写入htm文件尾部
 406. (write-line "</pre></body></html>" wf)
 407. (close rf)
 408. (close wf)
 409. (princ)
 410.) ;_ 结束defun
 411.
 412.
 413.;;子函数，只得到一个目录下的所有文件
 414.(defun <a name="GL_GetOnlyFiles">GL_GetOnlyFiles</a> (path / lst res)
 415. (setq lst (vl-directory-files path))
 416. (setq lst (mapcar
 417. '(lambda (x)
 418. (strcat path "\\" x)
 419. ) ;_ 结束lambda
 420. lst
 421. ) ;_ 结束mapcar
 422. ) ;_ 结束setq
 423. (foreach x lst
 424. (if (not (vl-file-directory-p x))
 425. (setq res (append
 426. res
 427. (list x)
 428. ) ;_ 结束append
 429. ) ;_ 结束setq
 430. ) ;_ 结束if
 431. ) ;_ 结束foreach
 432. res
 433.) ;_ 结束defun
 434.
 435.;;子函数，得到一个目录下的所有子目录
 436.;;返回一个列表，如：("E:\\TEST1" "E:\\TEST1\\TEST2")
 437.(defun <a name="GL_GetSubFolders ">GL_GetSubFolders </a>(Path / Folders GL_GetSubFolders@Dirs)
 438. (defun <a name="GL_GetSubFolders@Dirs">GL_GetSubFolders@Dirs</a> (Path / Dir Dirs)
 439. (and
 440. (= (type Path) 'STR)
 441. (if (wcmatch Path ",*/,*\\")
 442. (setq Dir Path)
 443. (setq Dir (strcat Path "\\"))
 444. ) ;_ 结束if
 445. (setq Dirs (vl-directory-files Dir "*.*" -1))
 446. (setq Folders (cons Path Folders))
 447. (setq Dirs (vl-remove-if
 448. '(lambda (x)
 449. (vl-position x '("." ".."))
 450. ) ;_ 结束lambda
 451. Dirs
 452. ) ;_ 结束vl-remove-if
 453. ) ;_ 结束setq
 454. (mapcar
 455. 'GL_GetSubFolders@Dirs
 456. (mapcar
 457. '(lambda (x)
 458. (strcat Dir x)
 459. ) ;_ 结束lambda
 460. Dirs
 461. ) ;_ 结束mapcar
 462. ) ;_ 结束mapcar
 463. ) ;_ 结束and
 464. ) ;_ 结束defun
 465. (<a href="#GL_GetSubFolders@Dirs">GL_GetSubFolders@Dirs</a> Path)
 466. (reverse Folders)
 467.) ;_ 结束defun
</pre></body></html>

carrot1983 · 发表于 2007-6-28 14:46:22

行号一起出现，使用不方便！

它山之石 · 发表于 2007-6-28 17:12:59

自己修改　把加行号的注释掉就OK了
这里无法下载附件
请到俺那里去下

它山之石图形工作室

zml84 · 发表于 2007-7-5 14:21:24

最初由它山之石发布
[B]
不过在晓东或明经发代码的话
这个倒不如[PHP]之类的方便了
[/B]

使用[lisp] [/lisp]也可以实现按语法着色,见:
http://acad.net.cn/viewthread.php?tid=80&extra=page%3D1

它山之石 · 发表于 2007-7-5 17:31:43

尚在测试阶段。。。

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

[LISP程序]：lsp文件转换为HTM（按照语法着色）

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

相关帖子