-
Notifications
You must be signed in to change notification settings - Fork 0
/
Lzw.lsp
259 lines (198 loc) · 9.5 KB
/
Lzw.lsp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
//
// Áèáëèîòåêà ñæàòèÿ
//
(defun lzw-pack (stri &optional (res nil) (dict nil) (ss "") (flag Nil))
;; stri - ñæèìàåìàÿ ñòðîêà
;; res - ðåçóëüòàò ñæàòèÿ (íàáîð 9-è áèòíûõ êîäîâ)
;; dict - ñëîâàðü
;; ss - íàêîïèòåëüíàÿ ïåðåìåííàÿ
;; flag - ïðèçíàê âûâîäà ïðîòîêîëà
(let ((font1 "<font face=Courier size=+1 color=Navy>")
(font2 "<font face=Courier size=+1 color=Red>")
(nl "<br>")
(blank " ")
(ff "</font>"))
(when (and flag (> (strlen stri) 0))
(filPutLine 'fout (strCat font1 "Ñèìâîë" blank ":" ff font2 (strLeft stri 1) blank ff nl))
(filPutLine 'fout (strCat font1 "Ñëîâàðü:" ff font2 (output dict) blank ff nl ))
(filPutLine 'fout (strCat font1 "Öåïî÷êà:" ff blank font2 ss ff nl nl)))
(cond ((= 0 (strlen stri)) (append res (list (getCode ss dict)))) ;; òåðìèíàëüíàÿ âåòâü ðåêóðñèè
;; âûâîä ïîñëåäíåãî êîäà
(t (let* ((k (strLeft stri 1)) ;; î÷åðåäíîé ñèìâîë ñòðîêè
(sk (strCat ss k))) ;; sk=ss+k
(cond ((= 1 (strlen sk)) (lzw-pack (strMid stri 2) res dict sk flag)) ;; îäíîñèìâ. ñòðîêà âñåãäà åñòü â ñëîâàðå
((assoc sk dict) (lzw-pack (strMid stri 2) res dict sk flag)) ;; ñòðîêà åñòü â ñëîâàðå
(t ;; ñòðîêè sk â ñëîâàðå íåò!
(lzw-pack (strMid stri 2) ;; èñõîäíàÿ ñòðîêà áåç 1-ãî ñèìâîëà
(append res (list (getCode ss dict))) ;; äîáàâèëè â res î÷åðåäíîé êîä
(putInDict sk dict) k flag)))))))) ;; äîáàâèëè â ñëîâàðü î÷åðåäíîé êîä
(defun getCode (code dict) ;; ôóíêöèÿ îïðåäåëåíèÿ 9 áèòíîãî êîäà
(if (= 1 (strLen code)) (strAsc code) (cadr (assoc code dict)))) ;; âûâîäèò íîìåð ýëëåìåíòà â 9 áèòíîì êîäå
(defun putInDict (code dict) ;; çàñóíóòü ýëåìåíò â ñïèñîê
(let ((k (+ 256 (length dict)))) ;; íîìåð ýëåìåíòà â ñïèñêå
(cons (list code k) dict))) ;; äîáàâèëè ýëåìåíò â ñïèñîê
;; ×èñëî -> ñïèñîê
(defun dec2bin (n &optional (r nil)) ;;ïåðåâåñòè äåñÿòè÷íóþ ñèñòåìó â äâîè÷íóþ
(if (= n 0) ;; óñëîâèå îñòàíàâëèâàþøèå ðåêóðñèþ
(if (null r) '(0) r) ;; åñëè âñå òî ïèøåì 0
(dec2bin (\ n 2) (cons (% n 2) r))))
(defun bin2dec (blist &optional (a 0))
(if (null blist) a (bin2dec (cdr blist) (+ (car blist) (* a 2)))))
;; Ïðåîáðàçîâàòü ñïèñîê 9-áèòíûõ â ñòðîêó
(defun conv (lst)
(let* ((tmp1 (apply 'append (mapcar 'dec2bin lst))) ;; ïðåîáðàçîâàíèå â ñïèñîê áèòîâ
(lt (length tmp1)) ;; äëèíà ñïèñêà
(d (% lt 8)) ;; îñò îò äåë íà 8
(tmp2 (append (iter (for _ from 1 to (- 8 d)) (collecting 0)) tmp1)) ;; äîïîëíåíèå íóëÿìè äî äëèíû, êðàòíîé 8
(l2 (/ (length tmp2) 8)) ;; ê-âî áàéòîâ ðåçóëüòàòà
(code 0)
(res "")) ;; ðåçóëüòàò
(iter (for i from 0 to (- l2 1)) ;; âûðåçàåì 8-êó áèòîâ è ïðåîáðàçóåì åå â ñèìâîë
(setq code (bin2dec (subseq tmp2 (* i 8) (* (+ i 1) 8))))
(setq res (strCat res (if (> code 31) (strChr code) ".") )))))
(defun start-pack ( &optional flag)
(let* ((stri (ask "Ââåäèòå ñòðîêó"))
(l1 (strLen stri))
(pstr (lzw-pack stri nil nil "" flag))
(l2 (length pstr)))
(printsline (strCat "Èñõîäíàÿ ñòðîêà : " stri))
(printsline (strCat "Äëèíà â áèòàõ : " (fix2str (* l1 8))))
(printsline (strCat "Ðåçóëüòàò ñæàòèÿ : " (output pstr)))
(printsline (strCat "Â êîäå ASCII : " (conv pstr)))
(printsline (strCat "Äëèíà â áèòàõ : " (fix2str (* l2 9))))
(printsline (strCat "Êîýôô. ñæàòèÿ : " (format (/ (* l1 8) (* l2 9.0)) "0.0"))) 'ok))
;; Ðàñïàêîâêà
;; Âõîä: ñïèñîê 9-áèòíûõ êîäîâ
;; Âûõîä - ñòðîêà
;; Äîáàâèòü â ñëîâàðü êîä
(defun add-in-dict (code dict)
(cons (list (+ 256 (length dict)) code) dict))
(defun get-from-dict (code dict)
(if (< code 256) (strChr code) (cadr (assoc code dict))))
(defun lzw-unpack (lst9 &optional flag)
(let ((font1 "<font face=Courier size=+1 color=Navy>")
(font2 "<font face=Courier size=+1 color=Red>")
(nl "<br>")
(blank " ")
(ff "</font>")
(cCode (car lst9))
(pCode (car lst9))
(dict nil)
(tmp1 nil)
(tmp2 nil)
(res ""))
(setq res (strCat res (strChr cCode)))
(iter (for cCode in (cdr lst9))
(setq tmp1 (get-from-dict cCode dict))
(setq tmp2 (get-from-dict pCode dict))
(when flag
(filPutLine 'fout (strCat font1 "Òåêóùèé êîä:" blank blank blank blank ff font2 (fix2str cCode) blank tmp1 ff nl))
(filPutLine 'fout (strCat font1 "Ïðåäûäóùèé êîä:" blank ff font2 (fix2str pCode) blank tmp2 ff nl))
(filPutLine 'fout (strCat font1 "Ñëîâàðü:" blank blank blank blank blank blank blank blank ff font2 (output dict) ff nl nl)))
(cond (tmp1
(setq res (strCat res tmp1)) ;; âûâîä cCode
(setq tmp1 (get-from-dict cCode dict))
(setq tmp2 (get-from-dict pCode dict))
(setq dict (add-in-dict (strCat tmp2 (strLeft tmp1 1)) dict)))
(t (setq res (strCat res (strCat tmp2 (strLeft tmp2 1))))
(setq dict (add-in-dict (strCat tmp2 (strLeft tmp2 1)) dict))))
(setq pCode cCode)) res ))
(defun start-unpack (&optional flag)
(let* ((bcodes (input (ask "Ââåäèòå áèòîâûé êîä:")))
(res (lzw-unpack bcodes flag)))
(printsline (strCat "Èñõîäíûé êîä: " (output bcodes)))
(printsline (strCat "Äëèíà â áèòàõ: " (fix2str (* 9 (length bcodes)))))
(printsline (strCat "Ðåçóëüòàò ðàñïàêîâêè: " res))
(printsline (strCat "Äëèíà â áèòàõ: " (fix2str (* 8 (strLen res))))) 'OK ))
;; "(48 49 256 48 55 258 260 49)"
;; 010107010701
;; asdd dfg hh hg ff f hgdg iouhi ug herigiuehg iued higludhgiulguh giudehgiuhgiruhg iu1
(defun ask-ync (txt)
(let ((answ nil))
(loop (setq answ (strUCase (ask txt)))
(cond ((member answ '("YES" "Y")) (return t))
((member answ '("NO" "N")) (return nil))
((member answ '("QUIT" "Q")) (return 0))))))
//
// Ïðîãðàììà îòîáðàæåíèÿ äèàëîãà _Dlg_
//
(defun main nil
(try (dlgDestroy '_Dlg_) except Nil)
(filCloseAll)
(dlgCreate '_Dlg_ 630 433 "LZW-àëãîðèòì" &H8000000F)
(dlgAddControl '_Dlg_ '_BUT_4 _BUTTON 5 64 200 86 '("Times New Roman" 20,25 1 0 0) "Ñæàòü")
(dlgPutPicture '_BUT_4 11)
(dlgAddControl '_Dlg_ '_BUT_5 _BUTTON 210 64 200 86 '("Times New Roman" 20,25 1 0 0) "Ðàçæàòü")
(dlgPutPicture '_BUT_5 8)
(dlgAddControl '_Dlg_ '_BUT_6 _BUTTON 415 64 200 86 '("Times New Roman" 20,25 1 0 0) "Çàêðûòü")
(dlgPutPicture '_BUT_6 36)
(dlgAddControl '_Dlg_ '_TXT_1 _TEXT 9 11 605 30 '("Times New Roman" 14 1 0 0) "Ââåñòè" 0 &H80000008 &H80000005)
(dlgAddControl '_Dlg_ '_LBL_1 _LABEL 16 172 542 203 '("Courier New" 16 1 0 0) "Äàííûå î ñæàòèè" 0 &H80000012 &H8000000F)
//
// Ïðîëîã çàãðóçêè äèàëîãà _Dlg_
//
;; Ñîçäàåì ãëîáàëüíûå ïåðåìåíûå
(prog nil
(setq *save* "")
(setq *flag* (ask-ync "Âûâîäèòü ïðîòîêîë ñæàòèÿ (yes/no)?"))
(when (eq *flag* 0) (return nil))
(when *flag*
(filOpen 'fout "lzw.html" _OUTPUT)
(filPutLine 'fout "<html>")
(filPutLine 'fout "<head> </head>")
(filPutLine 'fout "<body><b>")))
(when (not (eq *flag* 0))
//
// Îáðàáîò÷èê ñîáûòèÿ CLICK äëÿ êíîïêè _BUT_4
//
(defun _BUT_4_Click Nil
(when *flag* (filPutLine 'fout (strCat "<br><font face=Courier size=+2 color=red> Óïàêîâêà: </font> <br><br>")))
(let* ((stri (dlgGetText '_TXT_1))
(l1 (strLen stri))
(pstr (lzw-pack stri nil nil "" *flag*))
(l2 (length pstr))
(out (strCat "Èñõîäíàÿ ñòðîêà : " stri (strChr 10)
"Äëèíà â áèòàõ : " (fix2str (* l1 8)) (strChr 10)
"Ðåçóëüòàò ñæàòèÿ : " (output pstr)(strChr 10)
"Â êîäå ASCII : " (conv pstr) (strChr 10)
"Äëèíà â áèòàõ : " (fix2str (* l2 9)) (strChr 10)
"Êîýôô. ñæàòèÿ : " (format (/ (* l1 8) (* l2 9.0)) "0.0")))) (setq *save* (output pstr))
(dlgPutText '_LBL_1 out)))
//
// Íàçíà÷åíèå ïðîöåäóðû-ñîáûòèÿ _BUT_4_Click êîíòðîëó _BUT_4
//
(dlgSetEvent '_BUT_4 '_BUT_4_Click )
//
// Îáðàáîò÷èê ñîáûòèÿ CLICK äëÿ êíîïêè _BUT_5
//
(defun _BUT_5_Click Nil
(let* ((data *save*)
(unpk nil))
(cond ((= 0 (strLen data)) (say "Ðàñïàêîâûâàòü íå÷åãî!"))
(t (when *flag* (filPutLine 'fout (strCat "<br><br> <font face=Courier size=+2 color=red> Ðàñïàêîâêà: </font> <br><br>")))
(setq unpk (lzw-unpack (input data) *flag*))
(dlgPutText '_LBL_1 (strCat "Ðåçóëüòàò ðàñïàêîâêè: " unpk))))))
//
// Íàçíà÷åíèå ïðîöåäóðû-ñîáûòèÿ _BUT_5_Click êîíòðîëó _BUT_5
//
(dlgSetEvent '_BUT_5 '_BUT_5_Click )
//
// Îáðàáîò÷èê ñîáûòèÿ CLICK äëÿ ìåòêè _LBL_1
//
(defun _BUT_6_Click ()
(dlgHide '_DLG_)
(dlgDestroy '_DLG_)
(when *flag*
(filPutLine 'fout "</b></body></html>")
(filClose 'fout)
(sysShell (strCat (sysHome) "\lzw.html"))))
//
// Íàçíà÷åíèå ïðîöåäóðû-ñîáûòèÿ _LBL_1_Click êîíòðîëó _LBL_1
//
(dlgSetEvent '_BUT_6 '_BUT_6_Click )
//
// Îòîáðàæåíèå äèàëîãà _Dlg_
//
(dlgShow '_Dlg_)))
;; Çàïóñê ãëàâíîé ïðîöåäóðû
;;(main)