forked from svn2github/freearc
-
Notifications
You must be signed in to change notification settings - Fork 1
/
Compression.hs
576 lines (492 loc) · 28.3 KB
/
Compression.hs
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
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
----------------------------------------------------------------------------------------------------
---- Óïàêîâêà, ðàñïàêîâêà è âû÷èñëåíèå CRC. ----
---- Òèïû äàííûõ CompressionMethod, Compressor, UserCompressor - îïèñàíèå ìåòîäà ñæàòèÿ. ----
---- Èíòåðôåéñ ñ íàïèñàííûìè íà Ñè ïðîöåäóðàìè, âûïîëíÿþùèìè âñþ ðåàëüíóþ ðàáîòó. ----
----------------------------------------------------------------------------------------------------
module Compression (module Compression, CompressionLib.decompressMem) where
import Control.Concurrent
import Control.Monad
import Data.Bits
import Data.Char
import Data.IORef
import Data.List
import Data.Maybe
import Data.Word
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Marshal.Pool
import Foreign.Ptr
import System.IO.Unsafe
import qualified CompressionLib
import Utils
import Errors
import Files
import qualified ByteStream
-- |Ìåòîä ñæàòèÿ èëè ïðåïðîöåññîð è åãî ïàðàìåòðû
type CompressionMethod = CompressionLib.Method
-- Ìåòîäû "ñæàòèÿ", ïîääåðæèâàåìûå íàïðÿìóþ, à íå ÷åðåç CompressionLib
aSTORING = "storing"
aFAKE_COMPRESSION = "fake"
aCRC_ONLY_COMPRESSION = "crc"
-- |Ôåéêîâûå (íåðàñïàêîâûâàåìûå) ìåòîäû ñæàòèÿ.
isFakeMethod = any_function [==aFAKE_COMPRESSION, ==aCRC_ONLY_COMPRESSION] . method_name
-- |LZP ìåòîä ñæàòèÿ.
isLZP_Method method = method_name method == "lzp"
-- |Tornado ìåòîä ñæàòèÿ.
isTornado_Method method = method_name method == "tor"
-- |DICT ìåòîä ñæàòèÿ.
isDICT_Method method = method_name method == "dict"
-- |TTA ìåòîä ñæàòèÿ.
isTTA_Method method = method_name method == "tta"
-- |MM ìåòîä ñæàòèÿ.
isMM_Method method = method_name method == "mm"
-- |JPG ìåòîä ñæàòèÿ.
isJPG_Method method = method_name method == "jpg"
-- |GRZip ìåòîä ñæàòèÿ.
isGRZIP_Method method = method_name method == "grzip"
-- |Î÷åíü áûñòðûé ìåòîä óïàêîâêè (>10 mb/s íà 1ÃÃö ïðîöåññîðå)
isVeryFastMethod = CompressionLib.compressionIs "VeryFast?"
-- |Áûñòðûé ìåòîä ðàñïàêîâêè
isFastDecMethod = not . any_function [=="ppmd", =="ppmm", =="pmm", isEXTERNAL_Method] . method_name
-- |Ìåòîä ñæàòèÿ, âûïîëíÿåìûé âíåøíåé ïðîãðàììîé
isEXTERNAL_Method = CompressionLib.compressionIs "external?"
-- |Ìåòîä øèôðîâàíèÿ.
isEncryption = CompressionLib.compressionIs "encryption?"
-- |Ïîñëåäîâàòåëüíîñòü àëãîðèòìîâ ñæàòèÿ, èñïîëüçóåìûõ äëÿ îáðàáîòêè äàííûõ
type Compressor = [CompressionMethod]
-- |Ìåòîä "storing" (-m0)
aNO_COMPRESSION = [aSTORING] :: Compressor
-- |Î÷åíü áûñòðîå ñæàòèå äëÿ óæå ñæàòûõ ôàéëîâ
aCOMPRESSED_METHOD = split_compressor "tor:8m:c3"
-- |Ýòî - ôåéêîâûé êîìïðåññîð, åñëè â í¸ì ðîâíî îäèí ìåòîä ñæàòèÿ è îí - ôåéêîâûé
isFakeCompressor (method:xs) = isFakeMethod method && null xs
-- |Ýòî - fake êîìïðåññîð, åñëè â í¸ì ðîâíî îäèí ìåòîä ñæàòèÿ è îí - "fake"
isReallyFakeCompressor (method:xs) = method_name method == aFAKE_COMPRESSION && null xs
-- |Ýòî - LZP êîìïðåññîð, åñëè â í¸ì ðîâíî îäèí ìåòîä ñæàòèÿ è îí - LZP
isLZP_Compressor (method:xs) = isLZP_Method method && null xs
-- |Ýòî - î÷åíü áûñòðûé óïàêîâùèê, åñëè â í¸ì ðîâíî îäèí, î÷åíü áûñòðûé ìåòîä ñæàòèÿ.
isVeryFastCompressor (method:xs) = isVeryFastMethod method && null xs
-- |Ýòî - áûñòðûé ðàñïàêîâùèê, åñëè îí âêëþ÷àåò òîëüêî áûñòðûå ìåòîäû ðàñïàêîâêè
isFastDecompressor = all isFastDecMethod
-- |Âûáîð êîìïðåññîðà â çàâèñèìîñòè îò òèïà îáðàáàòûâàåìûõ äàííûõ.
-- Ïåðâûé ýëåìåíò ñïèñêà áåçûìÿíåí è îïèñûâàåò êîìïðåññîð, èñïîëüçóåìûé
-- ïî óìîë÷àíèþ (äëÿ ôàéëîâ âñåõ ïðî÷èõ òèïîâ, íå îïèñàííûõ â ñïèñêå ÿâíî)
type UserCompressor = [(String,Compressor)] -- ñïèñîê àññîöèàöèé òèïà "$text->m3t, $exe->m3x, $compressed->m0"
getCompressors :: UserCompressor -> [Compressor]
getCompressors = map snd
getMainCompressor :: UserCompressor -> Compressor
getMainCompressor = snd.head
-- |Ýòî - ìåòîä Storing, åñëè â í¸ì òîëüêî îäèí êîìïðåññîð aNO_COMPRESSION äëÿ ôàéëîâ âñåõ òèïîâ
isStoring ((_,compressor):xs) = compressor==aNO_COMPRESSION && null xs
-- |Ýòî - fake compression, åñëè â í¸ì òîëüêî îäèí ôåéêîâûé êîìïðåññîð äëÿ ôàéëîâ âñåõ òèïîâ
isFakeCompression ((_,compressor):xs) = isFakeCompressor compressor && null xs
-- |Ýòî - LZP compression, åñëè â í¸ì òîëüêî îäèí LZP êîìïðåññîð äëÿ ôàéëîâ âñåõ òèïîâ
isLZP_Compression ((_,compressor):xs) = isLZP_Compressor compressor && null xs
-- |Ýòî î÷åíü áûñòðàÿ óïàêîâêà, åñëè â íåé èñïîëüçóþòñÿ òîëüêî î÷åíü áûñòðûå óïàêîâùèêè äëÿ ôàéëîâ âñåõ òèïîâ
isVeryFastCompression = all (isVeryFastCompressor.snd)
-- |Ýòî áûñòðàÿ ðàñïàêîâêà, åñëè â íåé èñïîëüçóþòñÿ òîëüêî áûñòðûå ðàñïàêîâùèêè äëÿ ôàéëîâ âñåõ òèïîâ
isFastDecompression = all (isFastDecompressor.snd)
-- |Íàéòè êîìïðåññîð, íàèáîëåå ïîäõîäÿùèé äëÿ äàííûõ òèïà `ftype`.
-- Åñëè êîìïðåññîð äëÿ ôàéëîâ ýòîãî òèïà íå îïèñàí â ñïèñêå - âîçâðàòèòü êîìïðåññîð
-- ïî óìîë÷àíèþ, çàïèñàííûé â ïåðâûé ýëåìåíò ñïèñêà
findCompressor ftype list = lookup ftype list `defaultVal` snd (head list)
-- |Äëÿ çàïèñè â îãëàâëåíèå àðõèâà èíôîðìàöèè îá èñïîëüçîâàííûõ àëãîðèòìàõ ñæàòèÿ.
instance ByteStream.BufferData Compressor where
write buf x = ByteStream.write buf (join_compressor x)
read buf = ByteStream.read buf >>== split_compressor
----------------------------------------------------------------------------------------------------
----- Îïåðàöèè íàä àëãîðèòìàìè ñæàòèÿ -----
----------------------------------------------------------------------------------------------------
class Compression a where
getCompressionMem :: a -> Integer
getDecompressionMem :: a -> Integer
getBlockSize :: a -> MemSize
getDictionary :: a -> MemSize
setDictionary :: MemSize -> a -> a
limitCompressionMem :: MemSize -> a -> a
limitDecompressionMem :: MemSize -> a -> a
limitDictionary :: MemSize -> a -> a
limitCompressionMemoryUsage :: MemSize -> a -> a
limitDecompressionMemoryUsage :: MemSize -> a -> a
-- |Ïðåâðàòèòü ôóíêöèþ èç CompressionLib, èçìåíÿþùóþ Method, â ôóíêöèþ, èçìåíÿþùóþ CompressionMethod
liftSetter action method | aSTORING == method = method
liftSetter action method | isFakeMethod method = method
liftSetter action method = action method
-- |Ïðåâðàòèòü ôóíêöèþ èç CompressionLib, îïðàøèâàþùóþ Method, â ôóíêöèþ, îïðàøèâàþùóþ CompressionMethod
liftGetter action method | aSTORING == method = 0
liftGetter action method | isFakeMethod method = 0
liftGetter action method = action method
instance Compression CompressionMethod where
getCompressionMem =i.liftGetter CompressionLib.getCompressionMem
getDecompressionMem =i.liftGetter CompressionLib.getDecompressionMem
getBlockSize = liftGetter CompressionLib.getBlockSize
getDictionary = liftGetter CompressionLib.getDictionary
setDictionary = liftSetter . CompressionLib.setDictionary
limitCompressionMem = liftSetter . CompressionLib.limitCompressionMem
limitDecompressionMem = liftSetter . CompressionLib.limitDecompressionMem
limitDictionary = liftSetter . CompressionLib.limitDictionary
limitCompressionMemoryUsage = limitCompressionMem
limitDecompressionMemoryUsage = const id
instance Compression Compressor where
getCompressionMem = calcMem getCompressionMem
getDecompressionMem = calcMem getDecompressionMem
getBlockSize = maximum . map getBlockSize
getDictionary = maximum . map getDictionary
setDictionary = mapLast . setDictionary
limitCompressionMem = map . limitCompressionMem
limitDecompressionMem = map . limitDecompressionMem
limitDictionary = compressionLimitDictionary
limitCompressionMemoryUsage = compressionLimitMemoryUsage
limitDecompressionMemoryUsage = genericLimitMemoryUsage getDecompressionMem
instance Compression UserCompressor where
-- Îïðåäåëèòü ìàêñèìàëüíîå ïîòðåáëåíèå ïàìÿòè / ðàçìåð áëîêà â çàäàííîì UserCompressor
getCompressionMem = maximum . map (getCompressionMem . snd)
getDecompressionMem = maximum . map (getDecompressionMem . snd)
getBlockSize = maximum . map (getBlockSize . snd)
getDictionary = maximum . map (getDictionary . snd)
-- Óñòàíîâèòü ñëîâàðü / Îãðàíè÷èòü èñïîëüçóåìóþ ïðè ñæàòèè/ðàñïàêîâêå ïàìÿòü
-- ñðàçó äëÿ âñåõ ìåòîäîâ, âõîäÿùèõ â UserCompressor
setDictionary = mapSnds . setDictionary
limitCompressionMem = mapSnds . limitCompressionMem
limitDecompressionMem = mapSnds . limitDecompressionMem
limitDictionary = mapSnds . limitDictionary
limitCompressionMemoryUsage = mapSnds . limitCompressionMemoryUsage
limitDecompressionMemoryUsage = mapSnds . limitDecompressionMemoryUsage
-- |Ìèíèìàëüíûé îáú¸ì ïàìÿòè, íåîáõîäèìûé äëÿ óïàêîâêè/ðàñïàêîâêè
compressorGetShrinkedCompressionMem = maximum . map (compressionGetShrinkedCompressionMem . snd)
compressorGetShrinkedDecompressionMem = maximum . map (compressionGetShrinkedDecompressionMem . snd)
compressionGetShrinkedCompressionMem = maximum . map getCompressionMem
compressionGetShrinkedDecompressionMem = maximum . map getDecompressionMem
-- |Îãðàíè÷èòü ñëîâàðè äëÿ öåïî÷êè àëãîðèòìîâ, ïðåêðàòèâ ýòî äåëàòü ïîñëå ïåðâîãî àëãîðèòìà,
-- êîòîðûé ìîæåò ñóùåñòâåííî ðàçäóòü äàííûå (òèïà precomp). Ñðåäè âíóòðåííèõ àëãîðèòìîâ
-- òàêèõ íåò, íî ìû äåðæèì ïîä ïîäîçðåíèåì âñå âíåøíèå :)
compressionLimitDictionary mem (x:xs) = new_x : (not(isEXTERNAL_Method new_x) &&& compressionLimitDictionary mem) xs
where new_x = limitDictionary mem x
compressionLimitDictionary mem [] = []
-- |Óìåíüøàåò ïîòðåáíîñòè â ïàìÿòè êàæäîãî àëãîðèòìà â öåïî÷êå äî mem
-- è çàòåì âñòàâëÿåò ìåæäó íèìè âûçîâû tempfile, åñëè íåîáõîäèìî
compressionLimitMemoryUsage mem = genericLimitMemoryUsage getCompressionMem mem . map (limitCompressionMem mem)
-- |Âñòàâëÿåò âûçîâû tempfile ìåæäó àëãîðèòìàìè ñæàòèÿ, ðàçáèâàÿ èõ íà "êëàñòåðà",
-- óìåùàþùèåñÿ â memory_limit+5% (ïðè ýòîì "ìàëåíüêèå" àëãîðèòìû íå äîëæíû íà÷èíàòü íîâûõ êëàñòåðîâ).
-- Ïðè ýòîì äëÿ dict/dict+lzp èñïîëüçóåòñÿ îñîáûé ó÷¸ò ïàìÿòè (blocksize*2 íà îáà, blocksize/2 íà âûõîäå),
-- à external compressors îáíóëÿþò ïîòðåáëåíèå ïàìÿòè
genericLimitMemoryUsage getMem memory_limit = go (0::Double) ""
where go _ _ [] = []
go mem prev (x:xs) | isEXTERNAL_Method x = x: go 0 x xs
| mem+newMem < memlimit*1.05 = x: go (mem+newMem) x xs
| otherwise = "tempfile":x: go newMem x xs
where newMem | mem==0 && isDICT_Method x = realToFrac (getBlockSize x) / 2
| isDICT_Method prev && isLZP_Method x = 0
| otherwise = realToFrac$ getMem x
memlimit = realToFrac memory_limit
-- |Ïîñ÷èòàòü ïîòðåáíîñòè â ïàìÿòè öåïî÷êè àëãîðèòìîâ ñæàòèÿ ñ ó÷¸òîì èõ ðàçáèåíèÿ.
-- íà êëàñòåðû ïî compressionIs "external?" è îñîáûì ó÷¸òîì dict/dict+lzp
calcMem getMem = maximum . map getMemSum . splitOn isEXTERNAL_Method
where getMemSum (x:y:xs) | isDICT_Method x && isLZP_Method y = max (i$ getMem x) (i(getBlockSize x `div` 2) + getMemSum xs)
getMemSum (x:xs) | isDICT_Method x = max (i$ getMem x) (i(getBlockSize x `div` 2) + getMemSum xs)
getMemSum (x:xs) = i(getMem x) + getMemSum xs
getMemSum [] = 0::Integer
-- |Óäàëÿåò âñå óïîìèíàíèÿ î "tempfile" èç çàïèñè àëãîðèòìà ñæàòèÿ.
compressionDeleteTempCompressors = filter (/="tempfile")
----------------------------------------------------------------------------------------------------
----- (De)compression of data stream -----
----------------------------------------------------------------------------------------------------
{-
compress method callback - óïàêîâàòü äàííûå
decompress method callback - ðàñïàêîâàòü äàííûå
method :: CompressionMethod - àëãîðèòì óïàêîâêè
callback "read" buf size - ïðî÷èòàòü âõîäíûå äàííûå â áóôåð `buf` äëèíîé `size`
Âîçâðàùàåò 0 - êîíåö äàííûõ
<0 - ïðåðâàòü (ðàñ)ïàêîâêó (îøèáêà èëè áîëüøå äàííûõ íå íóæíî)
>0 - êîë-âî ïðî÷èòàííûõ áàéò
callback "write" buf size - çàïèñàòü âûõîäíûå äàííûå
Âîçâðàùàåò <0 - ïðåðâàòü (ðàñ)ïàêîâêó (îøèáêà èëè áîëüøå äàííûõ íå íóæíî)
>=0 - âñ¸ îê
Ïðè âîçâðàùåíèè èç ýòîé ôóíêöèè äàííûå äîëæíû áûòü "èñïîëüçîâàíû", ïîòîìó ÷òî
(ðàñ)ïàêîâùèê ìîæåò íà÷àòü çàïèñü íîâûõ äàííûõ íà òî æå ìåñòî
Âõîäíûå è âûõîäíûå áóôåðà âûäåëÿþòñÿ è îñâîáîæäàþòñÿ (ðàñ)ïàêîâùèêîì
-}
-- |Ïðîöåäóðû óïàêîâêè äëÿ ðàçëè÷íûõ àëãîðèòìîâ ñæàòèÿ.
freearcCompress num method | aSTORING == method = copy_data
freearcCompress num method | isFakeMethod method = eat_data
freearcCompress num method = checkingCtrlBreak num (CompressionLib.compress method)
-- |Ïðîöåäóðû ðàñïàêîâêè äëÿ ðàçëè÷íûõ àëãîðèòìîâ ñæàòèÿ.
freearcDecompress num method | aSTORING == method = copy_data
freearcDecompress num method | isFakeMethod method = impossible_to_decompress -- ýòè òèïû ñæàòûõ äàííûõ íå ïîäëåæàò ðàñïàêîâêå
freearcDecompress num method = checkingCtrlBreak num (CompressionLib.decompress method)
-- |Ïîñêîëüêó Haskell'îâñêèé êîä, âûçûâàåìûé èç Ñè, íå ìîæåò ïîëó÷àòü
-- èñêëþ÷åíèé, äîáàâèì ê ïðîöåäóðàì ÷òåíèÿ/çàïèñè ÿâíûå ïðîâåðêè
checkingCtrlBreak num action callback = do
let checked_callback what buf size auxdata = do
operationTerminated' <- val operationTerminated
if operationTerminated'
then return CompressionLib.aFREEARC_ERRCODE_OPERATION_TERMINATED -- foreverM doNothing0
else callback what buf size
--
res <- checked_callback "read" nullPtr 0 undefined -- ýòîò âûçîâ ïîçâîëÿåò îòëîæèòü çàïóñê ñëåäóþùåãî â öåïî÷êå àëãîðèòìà óïàêîâêè/ðàñïàêîâêè äî ìîìåíòà, êîãäà ïðåäûäóùèé âîçâðàòèò õîòü êàêèå-íèáóäü äàííûå (à åñëè ýòî ïîáëî÷íûé àëãîðèòì - äî ìîìåíòà, êîãäà îí îáðàáîòàåò âåñü áëîê)
if res<0 then return res
else action (checked_callback)
-- |Êîïèðîâàíèå äàííûõ áåç ñæàòèÿ (-m0)
copy_data callback = do
allocaBytes aHUGE_BUFFER_SIZE $ \buf -> do -- èñïîëüçóåì `alloca`, ÷òîáû àâòîìàòè÷åñêè îñâîáîäèòü âûäåëåííûé áóôåð ïðè âûõîäå
let go ptr = do
len <- callback "read" ptr ((buf+:aHUGE_BUFFER_SIZE)-:ptr)
if (len>0)
then do let newptr = ptr+:len
if newptr < buf+:aHUGE_BUFFER_SIZE
then go newptr
else do result <- callback "write" buf (newptr-:buf)
if (result>=0)
then go buf
else return (result) -- Âîçâðàòèì îòðèöàòåëüíîå ÷èñëî, åñëè ïðîèçîøëà îøèáêà/áîëüøå äàííûõ íå íóæíî
else do if (len==0 && ptr>buf)
then do result <- callback "write" buf (ptr-:buf)
return (if result>0 then 0 else result)
else return len -- Âîçâðàòèì 0, åñëè äàííûå êîí÷èëèñü, è îòðèöàòåëüíîå ÷èñëî, åñëè ïðîèçîøëà îøèáêà/áîëüøå äàííûõ íå íóæíî
go buf -- âîçâðàòèòü ðåçóëüòàò
-- |×èòàåì âñ¸, íå ïèøåì íè÷åãî, à CRC ñ÷èòàåòñÿ â äðóãîì ìåñòå ;)
eat_data callback = do
allocaBytes aBUFFER_SIZE $ \buf -> do -- èñïîëüçóåì `alloca`, ÷òîáû àâòîìàòè÷åñêè îñâîáîäèòü âûäåëåííûé áóôåð ïðè âûõîäå
let go = do
len <- callback "read" buf aBUFFER_SIZE
if (len>0)
then go
else return len -- Âîçâðàòèì 0, åñëè äàííûå êîí÷èëèñü, è îòðèöàòåëüíîå ÷èñëî, åñëè ïðîèçîøëà îøèáêà/áîëüøå äàííûõ íå íóæíî
go -- âîçâðàòèòü ðåçóëüòàò
impossible_to_decompress callback = do
return CompressionLib.aFREEARC_ERRCODE_GENERAL -- ñðàçó âîçâðàòèòü îøèáêó, ïîñêîëüêó ýòîò àëãîðèòì (FAKE/CRC_ONLY) íå ïîäëåæèò ðàñïàêîâêå
{-# NOINLINE checkingCtrlBreak #-}
{-# NOINLINE copy_data #-}
{-# NOINLINE eat_data #-}
----------------------------------------------------------------------------------------------------
----- CRC calculation ------------------------------------------------------------------------------
----------------------------------------------------------------------------------------------------
-- |CRC ôàéëà
type CRC = CUInt
aINIT_CRC = 0xffffffff :: CRC
updateCRC addr len = c_UpdateCRC addr (i len)
finishCRC = xor aINIT_CRC
-- |Ïîñ÷èòàòü CRC äàííûõ â áóôåðå
calcCRC addr len = updateCRC addr len aINIT_CRC >>== finishCRC
-- |Ïîñ÷èòàòü CRC íå-unicode ñòðîêè (ñèìâîëû ñ êîäàìè 0..255)
crc32 str = unsafePerformIO$ withCStringLen str (uncurry calcCRC)
-- |Fast C routine for CRC-32 calculation
foreign import ccall safe "Environment.h UpdateCRC"
c_UpdateCRC :: Ptr CChar -> CUInt -> CRC -> IO CRC
-------------------------------------------------------------------------------------------------------------
-- Encode/decode compression method for parsing options/printing info about selected compression method -----
-------------------------------------------------------------------------------------------------------------
-- |Parse command-line option that represents compression method.
-- Äåêîäèðîâàòü çàïèñü ìåòîäà ñæàòèÿ â âèäå òåêñòîâîé ñòðîêè, ïðåâðàòèâ åãî â ñïèñîê àññîöèàöèé
-- "òèï ôàéëà -> ìåòîä ñæàòèÿ". Ïåðâûé ýëåìåíò ýòîãî ñïèñêà îïèñûâàåò ìåòîä ñæàòèÿ ïî óìîë÷àíèþ
decode_method configuredMethodSubsts str =
str -- "3/$obj=2b/$iso=ecm+3b"
.$ subst list -- "3b/3t/$obj=2b/$iso=ecm+3b"
.$ split_to_methods -- [("","exe+3b"), ("$obj","3b"), ("$text","3t"), ("$obj","2b"), ("$iso","ecm+3b")]
.$ keepOnlyLastOn fst -- [("","exe+3b"), ("$text","3t"), ("$obj","2b"), ("$iso","ecm+3b")]
.$ filter (not.null.snd) -- "-m$bmp=" îçíà÷àåò çàïðåòèòü èñïîëüçîâàíèå ñïåöèàëüíîãî àëãîðèòìà äëÿ ãðóïïû $bmp
.$ mapSnds (subst2 list) -- [("",["exe","lzma"]), ("$text",["ppmd"]), ("$obj",["lzma"]), ("$iso",["ecm","lzma"])]
where list = prepareSubsts (concatMap reorder [configuredMethodSubsts, builtinMethodSubsts]) -- ñíà÷àëà ïîëüçîâàòåëüñêèå çàìåíû, çàòåì âñòðîåííûå, ÷òîáû äàòü ïåðâûì ïðèîðèòåò
reorder list = a++b where (a,b) = partition (notElem '#') list -- âíóòðè ýòèõ ãðóïï: ñíà÷àëà ñòðî÷êè, íå ñîäåðæàùèå #, çàòåì ñ # (ñíà÷àëà êîíêðåòíûå, çàòåì îáùèå çàìåíû)
-- Çàìåíà ïî ñïèñêó äëÿ ìåòîäà ñæàòèÿ (îáîáù¸ííîãî îáîçíà÷åíèÿ äëÿ ôàéëîâ âñåõ òèïîâ)
subst list method = joinWith "/" (main_methods:group_methods++user_methods)
where -- Èç çàïèñè òèïà -m3/$obj=2b âûäåëÿåì äëÿ ðàñøèôðîâêè òîëüêî ïåðâóþ ÷àñòü, äî ñëåøà
main:user_methods = split '/' method
-- Ðàñøèôðîâêà îñíîâíûõ ìåòîäîâ ñæàòèÿ, òèïà 3x = 3xb/3xt
main_methods = case (lookup main list) of
Just x -> subst list x -- Ïðè óñïåõå ïîâòîðÿåì ðåêóðñèâíî
Nothing -> main -- Áîëüøå ïîäñòàíîâîê íåò
-- Íàéä¸ì â ñïèñêå ïîäñòàíîâîê äîïîëíèòåëüíûå ìåòîäû ñæàòèÿ äëÿ îòäåëüíûõ ãðóïï, òèïà 3x$iso = ecm+exe+3xb
group_methods = list .$ keepOnlyFirstOn fst -- óäàëèì ïîâòîðíûå îïðåäåëåíèÿ (íå î÷åíü ýôôåêòèâíî äåëàòü ýòî èìåííî çäåñü, çàòî ïî ìåñòó èñïîëüçîâàíèÿ)
.$ mapMaybe (startFrom main . join2 "=") -- îñòàâèì òîëüêî îïðåäåëåíèÿ, íà÷èíàþùèåñÿ ñ 3x, óäàëèâ ýòî 3x
.$ filter (("$"==).take 1) -- à èç íèõ - òîëüêî íà÷èíàþùèåñÿ ñ $
-- Çàìåíà ïî ñïèñêó äëÿ àëãîðèòìà ñæàòèÿ (ïîñë-òè êîìïðåññîðîâ äëÿ êîíêðåòíîãî òèïà ôàéëîâ)
subst2 list = concatMap f . split_compressor
where f method = let (head,params) = break (==':') method
in case (lookup head list) of
Just new_head -> subst2 list (new_head++params)
Nothing -> [decode_one_method method]
-- |Äåêîäèðîâàòü ÿâíî îïèñàííûé ìåòîä ñæàòèÿ.
decode_one_method method | isFakeMethod method = method
| otherwise = CompressionLib.canonizeCompressionMethod method
-- Ïðåâðàùàåò äëèííóþ ñòðîêó, îïèñûâàþùóþ ìåòîäû ñæàòèÿ äëÿ ðàçíûõ òèïîâ ôàéëîâ,
-- â ìàññèâ àññîöèàöèé (òèï ôàéëà, ìåòîä ñæàòèÿ)
split_to_methods method = case (split '/' method) of
[_] -> [("",method)] -- îäèí ìåòîä äëÿ ôàéëîâ âñåõ òèïîâ
x : xs@ (('$':_):_) -> ("",x) : map (split2 '=') xs -- m1/$type=m2...
b : t : xs -> [("","exe+"++b), ("$obj",b), ("$text",t)] ++ map (split2 '=') xs -- m1/m2/$type=m3...
-- Ïîäãîòîâèòü ñïèñîê çàìåí ê èñïîëüçîâàíèþ â lookup
prepareSubsts x = x
-- Óäàëèòü ïóñòûå ñòðîêè, ïðîáåëû è êîììåíòàðèè
.$ map (filter (not.isSpace) . fst . split2 ';') .$ filter (not.null)
-- Çàìåíèòü êàæäóþ ñòðîêó ñ ñèìâîëîì # íà 9 ñòðîê, ãäå # ïðîáåãàåò çíà÷åíèÿ îò 1 äî 9
.$ concatMap (\s -> if s `contains` '#' then map (\d->replace '#' d s) ['1'..'9'] else [s])
-- Ïðåîáðàçîâàòü ñïèñîê ñòðîê âèäà "a=b" â ñïèñîê äëÿ lookup
.$ map (split2 '=')
-- Âñòðîåííûå îïèñàíèÿ ìåòîäîâ ñæàòèÿ â ôîðìàòå, àíàëîãè÷íîì èñïîëüçóåìîìó â arc.ini
builtinMethodSubsts = [
";High-level method definitions"
, "x = 9 ;highest compression mode using only internal algorithms"
, "ax = 9p ;highest compression mode involving external compressors"
, "0 = storing"
, "1 = 1b / $exe=exe+1b"
, "1x = 1"
, "# = #rep+exe+#xb / $obj=#rep+#xb / $text=#t"
, "#x = #xb/#xt"
, ""
, ";Text files compression with slow decompression"
, "1t = 1b"
, "2t = grzip:m4:8m:32:h15"
, "3t = dict:p: 64m:85% + lzp: 64m: 24:h20 :92% + grzip:m3:8m:l"
, "4t = dict:p: 64m:80% + lzp: 64m: 65:d1m:s16:h20:90% + ppmd:8:96m"
, "5t = dict:p: 64m:80% + lzp: 80m:105:d1m:s32:h22:92% + ppmd:12:192m"
, "6t = dict:p:128m:80% + lzp:160m:145:d1m:s32:h23:92% + ppmd:16:384m"
, "7t = dict:p:128m:80% + lzp:320m:185:d1m:s32:h24:92% + ppmd:20:768m"
, "8t = dict:p:128m:80% + lzp:640m:225:d1m:s32:h25:92% + ppmd:24:1536m"
, "9t = dict:p:128m:80% + lzp:800m:235:d1m:s32:h26:92% + ppmd:25:2047m"
, ""
, ";Binary files compression with slow and/or memory-expensive decompression"
, "1b = 1xb"
, "#b = #rep+#bx"
, "2rep = rep: 96m"
, "3rep = rep: 96m"
, "4rep = rep: 96m"
, "5rep = rep: 128m"
, "6rep = rep: 256m"
, "7rep = rep: 512m"
, "8rep = rep:1024m"
, "9rep = rep:2047m"
, ""
, ";Text files compression with fast decompression"
, "1xt = 1xb"
, "2xt = 2xb"
, "3xt = dict: 64m:80% + tor:7:96m:h64m"
, "4xt = dict: 64m:75% + lzma: 96m:h64m:normal:mc16"
, "5xt = dict: 128m:75% + lzma: 16m:max"
, "6xt = dict: 128m:75% + lzma: 32m:max"
, "7xt = dict: 128m:75% + lzma: 64m:max"
, "8xt = dict: 128m:75% + lzma:128m:max"
, "9xt = dict: 128m:75% + lzma:255m:max"
, ""
, ";Binary files compression with fast decompression"
, "1xb = tor:3"
, "2xb = tor:96m:h64m"
, "3xb = delta + lzma: 96m:h64m:fast:mc8"
, "4xb = delta + lzma: 96m:h64m:normal:mc16"
, "5xb = delta + lzma: 16m:max"
, "6xb = delta + lzma: 32m:max"
, "7xb = delta + lzma: 64m:max"
, "8xb = delta + lzma:128m:max"
, "9xb = delta + lzma:255m:max"
, ""
, ";Synonyms"
, "bcj = exe"
, "#xb = #bx"
, "#xt = #tx"
, "x# = #x" -- ïðèíèìàåì îïöèè òèïà "-mx7" äëÿ ìèìèêðèè ïîä 7-zip
, ""
, ";Compression modes involving external PPMONSTR.EXE"
, "#p = #pb/#pt"
, "5pt = dict:p: 64m:80% + lzp: 64m:32:h22:85% + pmm: 8:160m:r0"
, "6pt = dict:p: 64m:80% + lzp: 64m:64:h22:85% + pmm:16:384m:r1"
, "7pt = dict:p:128m:80% + lzp:128m:64:h23:85% + pmm:20:768m:r1"
, "8pt = dict:p:128m:80% + lzp:128m:64:h23:85% + pmm:24:1536m:r1"
, "9pt = dict:p:128m:80% + lzp:128m:64:h23:85% + pmm:25:2047m:r1"
, "#pt = #t"
, "#pb = #b"
, ""
, "#q = #qb/#qt"
, "5qt = dict:p:64m:80% + lzp:64m:64:d1m:24:h22:85% + pmm:10:160m:r1"
, "5qb = rep: 128m + delta + pmm:16:160m:r1"
, "6qb = rep: 256m + delta + pmm:20:384m:r1"
, "7qb = rep: 512m + delta + pmm:22:768m:r1"
, "8qb = rep:1024m + delta + pmm:24:1536m:r1"
, "9qb = rep:2047m + delta + pmm:25:2047m:r1"
, "#qt = #pt"
, "#qb = #pb"
, ""
, ";Sound wave files are best compressed with TTA algorithm"
, "wav = tta ;best compression"
, "wavfast = tta:m1 ;faster compression and decompression"
, "1$wav = wavfast"
, "2$wav = wavfast"
, "#$wav = wav"
, "#x$wav = wavfast"
, "#p$wav = wav"
, "#r$wav = #$wav"
, ""
, ";Bitmap graphic files are best compressed with GRZip algorithm"
, "bmp = mm + grzip:m1:l:a ;best compression"
, "bmpfast = mm + grzip:m4:l:a ;faster compression"
, "bmpfastest = mm:d1 + tor:3 ;fastest one"
, "1$bmp = bmpfastest"
, "2$bmp = bmpfastest"
, "3$bmp = bmpfast"
, "#$bmp = bmp"
, "1x$bmp = bmpfastest"
, "2x$bmp = bmpfastest"
, "#x$bmp = mm+#xb"
, "#p$bmp = bmp"
, "#r$bmp = #$bmp"
, ""
, ";Quick & dirty compression for data already compressed"
, "4$compressed = rep:96m + tor:c3"
, "3$compressed = rep:96m + tor:3"
, "2$compressed = rep:96m + tor:3"
, "4x$compressed = tor:8m:c3"
, "3x$compressed = rep:8m + tor:3"
, "2x$compressed = rep:8m + tor:3"
]
-- |Ìóëüòèìåäèéíûé òèï ôàéëîâ?
isMMType x = x `elem` words "$wav $bmp"
-- |Â íåêîòîðîì ñìûñëå îáðàòíàÿ îïåðàöèÿ - óãàäûâàíèå òèïà ôàéëà ïî åãî êîìïðåññîðó
typeByCompressor c = case (map method_name c) of
xs | xs `contains` "tta" -> "$wav"
| xs `contains` "mm" -> "$bmp"
| xs `contains` "grzip" -> "$text"
| xs `contains` "ppmd" -> "$text"
| xs `contains` "pmm" -> "$text"
| xs `contains` "dict" -> "$text"
| xs == aNO_COMPRESSION -> "$compressed"
| xs == ["rep","tor"] -> "$compressed"
| xs `contains` "ecm" -> "$iso"
| xs `contains` "precomp" -> "$precomp"
| xs == ["precomp","rep"] -> "$jpgsolid"
| xs `contains` "jpg" -> "$jpg"
| xs `contains` "exe" -> "$binary"
| xs `contains` "lzma" -> "$obj"
| xs `contains` "tor" -> "$obj"
| otherwise -> "default"
-- |Ñïèñîê âñåõ òèïîâ ôàéëîâ, îáíàðóæèâàåìûõ ïîäîáíûì îáðàçîì
typesByCompressor = words "$wav $bmp $text $compressed $iso $precomp $jpgsolid $jpg $obj $binary $exe"
-- |Human-readable description of compression method
encode_method uc = joinWith ", " (map encode_one_method uc)
encode_one_method (group,compressor) = between group " => " (join_compressor compressor)
join_compressor = joinWith "+"
-- |Opposite to join_compressor (used to read compression method from archive file)
split_compressor = split '+'
-- |Îáðàáîòàòü àëãîðèòìû â êîìïðåññîðå èìïåðàòèâíîé îïåðàöèåé process
process_algorithms process compressor = do
return (split_compressor compressor)
>>= mapM process
>>== join_compressor
-- |Ðàçáèòü ìåòîä ñæàòèÿ íà çàãîëîâîê è îòäåëüíûå ïàðàìåòðû
split_method = split ':'
-- |Èìÿ ìåòîäà ñæàòèÿ.
method_name = head . split_method
-- |Ñòðîêà, èíôîðìèðóþùàÿ ïîëüçîâàòåëÿ îá èñïîëüçóåìîì îáú¸ìå ïàìÿòè
showMem 0 = "0b"
showMem mem = showM [(gb,"gb"),(mb,"mb"),(kb,"kb"),(b,"b"),error"showMem"] mem
showMemory 0 = "0 bytes"
showMemory mem = showM [(gb," gbytes"),(mb," mbytes"),(kb," kbytes"),(b," bytes"),error"showMemory"] mem
showM xs@( (val,str) : ~(nextval,_) : _) mem =
if mem `mod` val==0 || mem `div` nextval>=4096
then show((mem+val`div` 2) `div` val)++str
else showM (tail xs) mem
-- |Îêðóãëèòü îáú¸ì ïàìÿòè ââåðõ òàê, ÷òîáû îí ïðèîáð¸ë ÷èòàáåëüíîñòü
roundMemUp mem | mem>=4096*kb = mem `roundUp` mb
| otherwise = mem `roundUp` kb
{-# NOINLINE builtinMethodSubsts #-}
{-# NOINLINE decode_method #-}
{-# NOINLINE showMem #-}