diff options
| author | Georg Brandl <georg@python.org> | 2013-05-20 09:04:29 +0200 |
|---|---|---|
| committer | Georg Brandl <georg@python.org> | 2013-05-20 09:04:29 +0200 |
| commit | 1ea0fa53d253eae501f0a48611dd01493240b34d (patch) | |
| tree | a651d2b86e17e87ea19e1ca424a359f93fa6f8fc | |
| parent | 1d27f185104f34835ed6e40d90995e4fab9ea7b0 (diff) | |
| download | pygments-1ea0fa53d253eae501f0a48611dd01493240b34d.tar.gz | |
add example file for F#.
| -rwxr-xr-x | tests/examplefiles/Deflate.fs | 578 |
1 files changed, 578 insertions, 0 deletions
diff --git a/tests/examplefiles/Deflate.fs b/tests/examplefiles/Deflate.fs new file mode 100755 index 00000000..7d3680ec --- /dev/null +++ b/tests/examplefiles/Deflate.fs @@ -0,0 +1,578 @@ +// public domain
+
+module Deflate
+
+open System
+open System.Collections.Generic
+open System.IO
+open System.Linq
+open Crc
+
+let maxbuf = 32768
+let maxlen = 258
+
+let getBit (b:byte) (bit:int) =
+ if b &&& (1uy <<< bit) = 0uy then 0 else 1
+
+type BitReader(sin:Stream) =
+ let mutable bit = 8
+ let mutable cur = 0uy
+
+ member x.Skip() =
+ bit <- 8
+
+ member x.ReadBit() =
+ if bit = 8 then
+ bit <- 0
+ let b = sin.ReadByte()
+ if b = -1 then
+ failwith "バッファを超過しました"
+ cur <- byte b
+ let ret = if cur &&& (1uy <<< bit) = 0uy then 0 else 1
+ bit <- bit + 1
+ ret
+
+ member x.ReadLE n =
+ let mutable ret = 0
+ for i = 0 to n - 1 do
+ if x.ReadBit() = 1 then ret <- ret ||| (1 <<< i)
+ ret
+
+ member x.ReadBE n =
+ let mutable ret = 0
+ for i = 0 to n - 1 do
+ ret <- (ret <<< 1) ||| x.ReadBit()
+ ret
+
+ member x.ReadBytes len =
+ if bit <> 8 then bit <- 8
+ let buf = Array.zeroCreate<byte> len
+ ignore <| sin.Read(buf, 0, len)
+ buf
+
+type WriteBuffer(sout:Stream) =
+ let mutable prev:byte[] = null
+ let mutable buf = Array.zeroCreate<byte> maxbuf
+ let mutable p = 0
+
+ let next newbuf =
+ prev <- buf
+ buf <- if newbuf then Array.zeroCreate<byte> maxbuf else null
+ p <- 0
+
+ member x.Close() =
+ next false
+ next false
+
+ interface IDisposable with
+ member x.Dispose() = x.Close()
+
+ member x.WriteByte (b:byte) =
+ buf.[p] <- b
+ sout.WriteByte b
+ p <- p + 1
+ if p = maxbuf then next true
+
+ member x.Write (src:byte[]) start len =
+ let maxlen = maxbuf - p
+ if len <= maxlen then
+ Array.Copy(src, start, buf, p, len)
+ sout.Write(src, start, len)
+ p <- p + len
+ if p = maxbuf then next true
+ else
+ x.Write src start maxlen
+ x.Write src (start + maxlen) (len - maxlen)
+
+ member x.Copy len dist =
+ if dist < 1 then
+ failwith <| sprintf "dist too small: %d < 1" dist
+ elif dist > maxbuf then
+ failwith <| sprintf "dist too big: %d > %d" dist maxbuf
+ let pp = p - dist
+ if pp < 0 then
+ if prev = null then
+ failwith <| sprintf "dist too big: %d > %d" dist p
+ let pp = pp + maxbuf
+ let maxlen = maxbuf - pp
+ if len <= maxlen then
+ x.Write prev pp len
+ else
+ x.Write prev pp maxlen
+ x.Copy (len - maxlen) dist
+ else
+ let maxlen = p - pp
+ if len <= maxlen then
+ x.Write buf pp len
+ else
+ if dist = 1 then
+ let b = buf.[pp]
+ for i = 1 to len do
+ x.WriteByte b
+ else
+ let buf' = buf
+ let mutable len' = len
+ while len' > 0 do
+ let len'' = Math.Min(len', maxlen)
+ x.Write buf' pp len''
+ len' <- len' - len''
+
+type Huffman(lens:int[]) =
+ let vals = Array.zeroCreate<int> lens.Length
+ let min = lens.Where(fun x -> x > 0).Min()
+ let max = lens.Max()
+ let counts = Array.zeroCreate<int> (max + 1)
+ let firsts = Array.zeroCreate<int> (max + 1)
+ let nexts = Array.zeroCreate<int> (max + 1)
+ let tables = Array.zeroCreate<int[]>(max + 1)
+
+ do
+ for len in lens do
+ if len > 0 then counts.[len] <- counts.[len] + 1
+ for i = 1 to max do
+ firsts.[i] <- (firsts.[i - 1] + counts.[i - 1]) <<< 1
+ Array.Copy(firsts, 0, nexts, 0, max + 1)
+ for i = 0 to vals.Length - 1 do
+ let len = lens.[i]
+ if len > 0 then
+ vals.[i] <- nexts.[len]
+ nexts.[len] <- nexts.[len] + 1
+
+ for i = 0 to vals.Length - 1 do
+ let len = lens.[i]
+ if len > 0 then
+ let start = firsts.[len]
+ if tables.[len] = null then
+ let count = nexts.[len] - start
+ tables.[len] <- Array.zeroCreate<int> count
+ tables.[len].[vals.[i] - start] <- i
+
+ member x.GetValue h =
+ let rec getv i =
+ if i > max then -1 else
+ if h < nexts.[i] then
+ tables.[i].[h - firsts.[i]]
+ else
+ getv (i + 1)
+ getv min
+
+ member x.Read(br:BitReader) =
+ let rec read h i =
+ if h < nexts.[i] then
+ tables.[i].[h - firsts.[i]]
+ else
+ read ((h <<< 1) ||| br.ReadBit()) (i + 1)
+ read (br.ReadBE min) min
+
+type [<AbstractClass>] HuffmanDecoder() =
+ abstract GetValue: unit->int
+ abstract GetDistance: unit->int
+
+type FixedHuffman(br:BitReader) =
+ inherit HuffmanDecoder()
+
+ override x.GetValue() =
+ let v = br.ReadBE 7
+ if v < 24 then v + 256 else
+ let v = (v <<< 1) ||| br.ReadBit()
+ if v < 192 then v - 48
+ elif v < 200 then v + 88
+ else ((v <<< 1) ||| br.ReadBit()) - 256
+
+ override x.GetDistance() = br.ReadBE 5
+
+type DynamicHuffman(br:BitReader) =
+ inherit HuffmanDecoder()
+
+ let lit, dist =
+ let hlit =
+ let hlit = (br.ReadLE 5) + 257
+ if hlit > 286 then failwith <| sprintf "hlit: %d > 286" hlit
+ hlit
+
+ let hdist =
+ let hdist = (br.ReadLE 5) + 1
+ if hdist > 32 then failwith <| sprintf "hdist: %d > 32" hdist
+ hdist
+
+ let hclen =
+ let hclen = (br.ReadLE 4) + 4
+ if hclen > 19 then failwith <| sprintf "hclen: %d > 19" hclen
+ hclen
+
+ let clen =
+ let hclens = Array.zeroCreate<int> 19
+ let order = [| 16; 17; 18; 0; 8; 7; 9; 6; 10; 5;
+ 11; 4; 12; 3; 13; 2; 14; 1; 15 |]
+ for i = 0 to hclen - 1 do
+ hclens.[order.[i]] <- br.ReadLE 3
+ new Huffman(hclens)
+
+ let ld = Array.zeroCreate<int>(hlit + hdist)
+ let mutable i = 0
+ while i < ld.Length do
+ let v = clen.Read(br)
+ if v < 16 then
+ ld.[i] <- v
+ i <- i + 1
+ else
+ let r, v =
+ match v with
+ | 16 -> (br.ReadLE 2) + 3, ld.[i - 1]
+ | 17 -> (br.ReadLE 3) + 3, 0
+ | 18 -> (br.ReadLE 7) + 11, 0
+ | _ -> failwith "不正な値です。"
+ for j = 0 to r - 1 do
+ ld.[i + j] <- v
+ i <- i + r
+
+ new Huffman(ld.[0 .. hlit - 1]),
+ new Huffman(ld.[hlit .. hlit + hdist - 1])
+
+ override x.GetValue() = lit.Read br
+ override x.GetDistance() = dist.Read br
+
+let getLitExLen v = if v < 265 || v = 285 then 0 else (v - 261) >>> 2
+let getDistExLen d = if d < 4 then 0 else (d - 2) >>> 1
+
+let litlens =
+ let litlens = Array.zeroCreate<int> 286
+ let mutable v = 3
+ for i = 257 to 284 do
+ litlens.[i] <- v
+ v <- v + (1 <<< (getLitExLen i))
+ litlens.[285] <- maxlen
+ litlens.[257..285]
+
+let distlens =
+ let distlens = Array.zeroCreate<int> 30
+ let mutable v = 1
+ for i = 0 to 29 do
+ distlens.[i] <- v
+ v <- v + (1 <<< (getDistExLen i))
+ distlens
+
+type Reader(sin:Stream) =
+ inherit Stream()
+
+ let br = new BitReader(sin)
+ let fh = new FixedHuffman(br)
+
+ let sout = new MemoryStream()
+ let dbuf = new WriteBuffer(sout)
+
+ let mutable cache:byte[] = null
+ let mutable canRead = true
+
+ let rec read (h:HuffmanDecoder) =
+ let v = h.GetValue()
+ if v > 285 then failwith <| sprintf "不正な値: %d" v
+ if v < 256 then
+ dbuf.WriteByte(byte v)
+ elif v > 256 then
+ let len =
+ if v < 265 then v - 254 else
+ litlens.[v - 257] + (br.ReadLE (getLitExLen v))
+ let dist =
+ let d = h.GetDistance()
+ if d > 29 then failwith <| sprintf "不正な距離: %d" d
+ if d < 4 then d + 1 else
+ distlens.[d] + (br.ReadLE (getDistExLen d))
+ dbuf.Copy len dist
+ if v <> 256 then read h
+
+ override x.CanRead = canRead
+ override x.CanWrite = false
+ override x.CanSeek = false
+ override x.Flush() = ()
+
+ override x.Close() =
+ dbuf.Close()
+ canRead <- false
+
+ override x.Read(buffer, offset, count) =
+ let offset =
+ if cache = null then 0 else
+ let clen = cache.Length
+ let len = Math.Min(clen, count)
+ Array.Copy(cache, 0, buffer, offset, len)
+ cache <- if len = clen then null
+ else cache.[len .. clen - 1]
+ len
+ let req = int64 <| count - offset
+ while canRead && sout.Length < req do
+ x.readBlock()
+ let len =
+ if sout.Length = 0L then 0 else
+ let data = sout.ToArray()
+ sout.SetLength(0L)
+ let dlen = data.Length
+ let len = Math.Min(int req, dlen)
+ Array.Copy(data, 0, buffer, offset, len)
+ if dlen > len then
+ cache <- data.[len..]
+ len
+ offset + len
+
+ override x.Position
+ with get() = raise <| new NotImplementedException()
+ and set(v) = raise <| new NotImplementedException()
+
+ override x.Length = raise <| new NotImplementedException()
+ override x.Seek(_, _) = raise <| new NotImplementedException()
+ override x.Write(_, _, _) = raise <| new NotImplementedException()
+ override x.SetLength(_) = raise <| new NotImplementedException()
+
+ member private x.readBlock() =
+ let bfinal = br.ReadBit()
+ match br.ReadLE 2 with
+ | 0 -> br.Skip()
+ let len = br.ReadLE 16
+ let nlen = br.ReadLE 16
+ if len + nlen <> 0x10000 then
+ failwith "不正な非圧縮長"
+ dbuf.Write (br.ReadBytes len) 0 len
+ | 1 -> read fh
+ | 2 -> read (new DynamicHuffman(br))
+ | _ -> failwith "不正なブロックタイプ"
+ if bfinal = 1 then
+ canRead <- false
+ x.Close()
+
+type BitWriter(sout:Stream) =
+ let mutable bit = 0
+ let mutable cur = 0uy
+
+ member x.Skip() =
+ if bit > 0 then
+ sout.WriteByte(cur)
+ bit <- 0
+ cur <- 0uy
+
+ interface IDisposable with
+ member x.Dispose() =
+ x.Skip()
+ sout.Flush()
+
+ member x.WriteBit(b:int) =
+ cur <- cur ||| ((byte b) <<< bit)
+ bit <- bit + 1
+ if bit = 8 then
+ sout.WriteByte(cur)
+ bit <- 0
+ cur <- 0uy
+
+ member x.WriteLE (len:int) (b:int) =
+ for i = 0 to len - 1 do
+ x.WriteBit <| if (b &&& (1 <<< i)) = 0 then 0 else 1
+
+ member x.WriteBE (len:int) (b:int) =
+ for i = len - 1 downto 0 do
+ x.WriteBit <| if (b &&& (1 <<< i)) = 0 then 0 else 1
+
+ member x.WriteBytes(data:byte[]) =
+ x.Skip()
+ sout.Write(data, 0, data.Length)
+
+type FixedHuffmanWriter(bw:BitWriter) =
+ member x.Write (b:int) =
+ if b < 144 then
+ bw.WriteBE 8 (b + 0b110000)
+ elif b < 256 then
+ bw.WriteBE 9 (b - 144 + 0b110010000)
+ elif b < 280 then
+ bw.WriteBE 7 (b - 256)
+ elif b < 288 then
+ bw.WriteBE 8 (b - 280 + 0b11000000)
+
+ member x.WriteLen (len:int) =
+ if len < 3 || len > maxlen then
+ failwith <| sprintf "不正な長さ: %d" len
+ let mutable ll = 285
+ while len < litlens.[ll - 257] do
+ ll <- ll - 1
+ x.Write ll
+ bw.WriteLE (getLitExLen ll) (len - litlens.[ll - 257])
+
+ member x.WriteDist (d:int) =
+ if d < 1 || d > maxbuf then
+ failwith <| sprintf "不正な距離: %d" d
+ let mutable dl = 29
+ while d < distlens.[dl] do
+ dl <- dl - 1
+ bw.WriteBE 5 dl
+ bw.WriteLE (getDistExLen dl) (d - distlens.[dl])
+
+let maxbuf2 = maxbuf * 2
+let buflen = maxbuf2 + maxlen
+
+let inline getHash (buf:byte[]) pos =
+ ((int buf.[pos]) <<< 4) ^^^ ((int buf.[pos + 1]) <<< 2) ^^^ (int buf.[pos + 2])
+
+let inline addHash (hash:List<int>[]) (buf:byte[]) pos =
+ if buf.[pos] <> buf.[pos + 1] then
+ hash.[getHash buf pos].Add pos
+
+let inline addHash2 (tables:int[,]) (counts:int[]) (buf:byte[]) pos =
+ if buf.[pos] <> buf.[pos + 1] then
+ let h = getHash buf pos
+ let c = counts.[h]
+ tables.[h, c &&& 15] <- pos
+ counts.[h] <- c + 1
+
+type Writer(t:int, sin:Stream) =
+ let mutable length = buflen
+ let buf = Array.zeroCreate<byte> buflen
+ let tables, counts =
+ if t = 2 then Array2D.zeroCreate<int> 4096 16, Array.create 4096 0 else null, null
+ let hash = if tables = null then [| for _ in 0..4095 -> new List<int>() |] else null
+ let mutable crc = ~~~0u
+
+ let read pos len =
+ let rlen = sin.Read(buf, pos, len)
+ if rlen < len then length <- pos + rlen
+ for i = pos to pos + rlen - 1 do
+ let b = int(crc ^^^ (uint32 buf.[i])) &&& 0xff
+ crc <- (crc >>> 8) ^^^ crc32_table.[b]
+ if hash <> null then
+ for list in hash do list.Clear()
+ else
+ Array.fill counts 0 counts.Length 0
+
+ do
+ read 0 buflen
+
+ let search (pos:int) =
+ let mutable maxp = -1
+ let mutable maxl = 2
+ let mlen = Math.Min(maxlen, length - pos)
+ let last = Math.Max(0, pos - maxbuf)
+ let h = getHash buf pos
+ if hash <> null then
+ let list = hash.[h]
+ let mutable i = list.Count - 1
+ while i >= 0 do
+ let p = list.[i]
+ if p < last then i <- 0 else
+ let mutable len = 0
+ while len < mlen && buf.[p + len] = buf.[pos + len] do
+ len <- len + 1
+ if len > maxl then
+ maxp <- p
+ maxl <- len
+ i <- i - 1
+ else
+ let c = counts.[h]
+ let p1, p2 = if c < 16 then 0, c - 1 else c + 1, c + 16
+ let mutable i = p2
+ while i >= p1 do
+ let p = tables.[h, i &&& 15]
+ if p < last then i <- 0 else
+ let mutable len = 0
+ while len < mlen && buf.[p + len] = buf.[pos + len] do
+ len <- len + 1
+ if len > maxl then
+ maxp <- p
+ maxl <- len
+ i <- i - 1
+ maxp, maxl
+
+ member x.Crc = ~~~crc
+
+ member x.Compress (sout:Stream) =
+ use bw = new BitWriter(sout)
+ bw.WriteBit 1
+ bw.WriteLE 2 1
+ let hw = new FixedHuffmanWriter(bw)
+ let mutable p = 0
+ match t with
+ | 2 ->
+ while p < length do
+ let b = buf.[p]
+ if p < length - 4 && b = buf.[p + 1] && b = buf.[p + 2] && b = buf.[p + 3] then
+ let mutable len = 4
+ let mlen = Math.Min(maxlen + 1, length - p)
+ while len < mlen && b = buf.[p + len] do
+ len <- len + 1
+ hw.Write(int b)
+ hw.WriteLen(len - 1)
+ hw.WriteDist 1
+ p <- p + len
+ else
+ let maxp, maxl = search p
+ if maxp < 0 then
+ hw.Write(int b)
+ addHash2 tables counts buf p
+ p <- p + 1
+ else
+ hw.WriteLen maxl
+ hw.WriteDist (p - maxp)
+ for i = p to p + maxl - 1 do
+ addHash2 tables counts buf i
+ p <- p + maxl
+ if p > maxbuf2 then
+ Array.Copy(buf, maxbuf, buf, 0, maxbuf + maxlen)
+ if length < buflen then length <- length - maxbuf else
+ read (maxbuf + maxlen) maxbuf
+ p <- p - maxbuf
+ for i = 0 to p - 1 do
+ addHash2 tables counts buf i
+ | 1 ->
+ while p < length do
+ let b = buf.[p]
+ if p < length - 4 && b = buf.[p + 1] && b = buf.[p + 2] && b = buf.[p + 3] then
+ let mutable len = 4
+ let mlen = Math.Min(maxlen + 1, length - p)
+ while len < mlen && b = buf.[p + len] do
+ len <- len + 1
+ hw.Write(int b)
+ hw.WriteLen(len - 1)
+ hw.WriteDist 1
+ p <- p + len
+ else
+ let maxp, maxl = search p
+ if maxp < 0 then
+ hw.Write(int b)
+ addHash hash buf p
+ p <- p + 1
+ else
+ hw.WriteLen maxl
+ hw.WriteDist (p - maxp)
+ for i = p to p + maxl - 1 do
+ addHash hash buf i
+ p <- p + maxl
+ if p > maxbuf2 then
+ Array.Copy(buf, maxbuf, buf, 0, maxbuf + maxlen)
+ if length < buflen then length <- length - maxbuf else
+ read (maxbuf + maxlen) maxbuf
+ p <- p - maxbuf
+ for i = 0 to p - 1 do
+ addHash hash buf i
+ | _ ->
+ while p < length do
+ let maxp, maxl = search p
+ if maxp < 0 then
+ hw.Write(int buf.[p])
+ hash.[getHash buf p].Add p
+ p <- p + 1
+ else
+ hw.WriteLen maxl
+ hw.WriteDist (p - maxp)
+ for i = p to p + maxl - 1 do
+ hash.[getHash buf i].Add i
+ p <- p + maxl
+ if p > maxbuf2 then
+ Array.Copy(buf, maxbuf, buf, 0, maxbuf + maxlen)
+ if length < buflen then length <- length - maxbuf else
+ read (maxbuf + maxlen) maxbuf
+ p <- p - maxbuf
+ for i = 0 to p - 1 do
+ hash.[getHash buf i].Add i
+ hw.Write 256
+
+let GetCompressBytes (sin:Stream) =
+ let now = DateTime.Now
+ let ms = new MemoryStream()
+ let w = new Writer(1, sin)
+ w.Compress ms
+ ms.ToArray(), w.Crc
|