···11-# ocaml-brotli
22-33-A pure OCaml implementation of the [Brotli](https://www.rfc-editor.org/rfc/rfc7932) compression format (RFC 7932).
44-55-This implementation is based on the algorithms and data structures from the reference [Google Brotli C library](https://github.com/google/brotli), rewritten in idiomatic OCaml without any C dependencies.
66-77-## Features
88-99-- Pure OCaml - no C bindings or external dependencies
1010-- Compression quality levels 0-11
1111-- Simple string-based API
1212-- Low-allocation buffer API
1313-- Streaming compression support
1414-- Optional [bytesrw](https://erratique.ch/software/bytesrw) integration for stream processing
1515-1616-## Installation
1717-1818-```
1919-opam install brotli
2020-```
2121-2222-## Usage
2323-2424-### Simple API
2525-2626-```ocaml
2727-(* Compress a string *)
2828-let compressed = Brotli.compress "Hello, World!"
2929-3030-(* Compress with higher quality (0-11, default is 1) *)
3131-let compressed = Brotli.compress ~quality:6 data
3232-3333-(* Decompress *)
3434-match Brotli.decompress compressed with
3535-| Ok decompressed -> print_endline decompressed
3636-| Error msg -> failwith msg
3737-3838-(* Or use the exception-raising variant *)
3939-let decompressed = Brotli.decompress_exn compressed
4040-```
4141-4242-### Low-allocation API
4343-4444-```ocaml
4545-let src = Bytes.of_string "data to compress"
4646-let dst = Bytes.create (Brotli.max_compressed_length (Bytes.length src))
4747-4848-let compressed_len =
4949- Brotli.compress_into
5050- ~src ~src_pos:0 ~src_len:(Bytes.length src)
5151- ~dst ~dst_pos:0 ()
5252-```
5353-5454-### With bytesrw (optional)
5555-5656-When the `bytesrw` package is installed, the `brotli.bytesrw` sublibrary provides streaming compression and decompression:
5757-5858-```ocaml
5959-open Bytesrw
6060-6161-(* Compress a byte reader *)
6262-let compressed_reader = Bytesrw_brotli.compress_reads ~quality:4 reader
6363-6464-(* Decompress a byte reader *)
6565-let decompressed_reader = Bytesrw_brotli.decompress_reads reader
6666-```
6767-6868-## Quality Levels
6969-7070-| Quality | Description |
7171-|---------|-------------|
7272-| 0 | Stored (uncompressed) blocks only |
7373-| 1 | Huffman-only compression (default) |
7474-| 2-3 | LZ77 with simple hash table matching |
7575-| 4 | Hash chains with dictionary matching |
7676-| 5-6 | Context mode selection |
7777-| 7-9 | Multiple literal Huffman trees |
7878-| 10-11 | Optimal parsing |
7979-8080-Higher quality levels produce smaller output but take longer to compress.
8181-8282-## References
8383-8484-- [RFC 7932 - Brotli Compressed Data Format](https://www.rfc-editor.org/rfc/rfc7932)
8585-- [Google Brotli C library](https://github.com/google/brotli) - the reference implementation this library is based on
8686-8787-## License
8888-8989-ISC
-35
ocaml-brotli/brotli.opam
···11-# This file is generated by dune, edit dune-project instead
22-opam-version: "2.0"
33-synopsis: "Pure OCaml implementation of Brotli compression"
44-description: """
55-A pure OCaml implementation of the Brotli compression format (RFC 7932).
66-When the optional bytesrw dependency is installed, the brotli.bytesrw
77-sublibrary provides streaming-style compression and decompression."""
88-maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
99-authors: ["Anil Madhavapeddy <anil@recoil.org>"]
1010-license: "ISC"
1111-homepage: "https://tangled.org/anil.recoil.org/ocaml-brotli"
1212-bug-reports: "https://tangled.org/anil.recoil.org/ocaml-brotli/issues"
1313-depends: [
1414- "dune" {>= "3.21"}
1515- "ocaml" {>= "5.2.0"}
1616- "alcotest" {with-test & >= "1.7.0"}
1717- "odoc" {with-doc}
1818-]
1919-depopts: ["bytesrw"]
2020-build: [
2121- ["dune" "subst"] {dev}
2222- [
2323- "dune"
2424- "build"
2525- "-p"
2626- name
2727- "-j"
2828- jobs
2929- "@install"
3030- "@runtest" {with-test}
3131- "@doc" {with-doc}
3232- ]
3333-]
3434-dev-repo: "git+https://tangled.org/anil.recoil.org/ocaml-brotli"
3535-x-maintenance-intent: ["(latest)"]
-184
ocaml-brotli/bytesrw/bytesrw_brotli.ml
···11-(*---------------------------------------------------------------------------
22- Copyright (c) 2024 The brotli programmers. All rights reserved.
33- SPDX-License-Identifier: ISC
44- ---------------------------------------------------------------------------*)
55-66-(* Bytesrw integration for Brotli compression (RFC 7932)
77-88- This implementation provides streaming compression and decompression
99- using the Brotli format. Both compression and decompression buffer
1010- the entire input to achieve optimal compression ratios. *)
1111-1212-open Bytesrw
1313-1414-(* Error handling *)
1515-1616-type Bytes.Stream.error += Error of string
1717-1818-let format_error =
1919- let case msg = Error msg in
2020- let message = function Error msg -> msg | _ -> assert false in
2121- Bytes.Stream.make_format_error ~format:"brotli" ~case ~message
2222-2323-let error = Bytes.Stream.error format_error
2424-let reader_error = Bytes.Reader.error format_error
2525-let writer_error = Bytes.Writer.error format_error
2626-2727-(* Library parameters *)
2828-2929-let default_slice_length = 65536 (* 64KB *)
3030-3131-type quality = int
3232-let default_quality = 1
3333-let no_compression = 0
3434-let best_speed = 1
3535-let best_compression = 11
3636-3737-(* Decompress reads - buffers entire input, decompresses, then emits slices *)
3838-3939-let decompress_reads () ?pos ?(slice_length = default_slice_length) r =
4040- (* Buffer all input first *)
4141- let input_buffer = Buffer.create slice_length in
4242- let rec read_all () =
4343- let slice = Bytes.Reader.read r in
4444- if Bytes.Slice.is_eod slice then ()
4545- else begin
4646- Bytes.Slice.add_to_buffer input_buffer slice;
4747- read_all ()
4848- end
4949- in
5050- read_all ();
5151-5252- (* Decompress using low-allocation API *)
5353- let input_len = Buffer.length input_buffer in
5454- let input = Bytes.unsafe_of_string (Buffer.contents input_buffer) in
5555- (* Start with 4x input size estimate, grow if needed *)
5656- let initial_size = max 256 (input_len * 4) in
5757- let output = ref (Bytes.create initial_size) in
5858- let rec try_decompress size =
5959- output := Bytes.create size;
6060- try
6161- Brotli.decompress_into ~src:input ~src_pos:0 ~src_len:input_len
6262- ~dst:!output ~dst_pos:0
6363- with
6464- | Brotli.Brotli_error Brotli.Output_overrun ->
6565- if size > 256 * 1024 * 1024 then
6666- reader_error r "Output too large"
6767- else
6868- try_decompress (size * 2)
6969- in
7070- let decompressed_len = try_decompress initial_size in
7171-7272- (* Create a reader from the decompressed data *)
7373- let output_pos = ref 0 in
7474-7575- let read () =
7676- if !output_pos >= decompressed_len then Bytes.Slice.eod
7777- else begin
7878- let len = min slice_length (decompressed_len - !output_pos) in
7979- let slice = Bytes.Slice.make !output ~first:!output_pos ~length:len in
8080- output_pos := !output_pos + len;
8181- slice
8282- end
8383- in
8484- Bytes.Reader.make ?pos ~slice_length read
8585-8686-(* Decompress writes - buffers input, decompresses on eod *)
8787-8888-let decompress_writes () ?pos ?(slice_length = default_slice_length) ~eod w =
8989- let input_buffer = Buffer.create slice_length in
9090-9191- let write = function
9292- | slice when Bytes.Slice.is_eod slice ->
9393- (* Decompress using low-allocation API *)
9494- let input_len = Buffer.length input_buffer in
9595- let input = Bytes.unsafe_of_string (Buffer.contents input_buffer) in
9696- let initial_size = max 256 (input_len * 4) in
9797- let output = ref (Bytes.create initial_size) in
9898- let rec try_decompress size =
9999- output := Bytes.create size;
100100- try
101101- Brotli.decompress_into ~src:input ~src_pos:0 ~src_len:input_len
102102- ~dst:!output ~dst_pos:0
103103- with
104104- | Brotli.Brotli_error Brotli.Output_overrun ->
105105- if size > 256 * 1024 * 1024 then
106106- writer_error w "Output too large"
107107- else
108108- try_decompress (size * 2)
109109- in
110110- let decompressed_len = try_decompress initial_size in
111111- Bytes.Writer.write_string w (Bytes.sub_string !output 0 decompressed_len);
112112- if eod then Bytes.Writer.write_eod w
113113- | slice ->
114114- Bytes.Slice.add_to_buffer input_buffer slice
115115- in
116116- Bytes.Writer.make ?pos ~slice_length write
117117-118118-(* Compress reads - buffers entire input, compresses, then emits slices *)
119119-120120-let compress_reads ?(quality = default_quality) ()
121121- ?pos ?(slice_length = default_slice_length) r
122122- =
123123- (* Buffer all input first - this allows better compression *)
124124- let input_buffer = Buffer.create slice_length in
125125- let rec read_all () =
126126- let slice = Bytes.Reader.read r in
127127- if Bytes.Slice.is_eod slice then ()
128128- else begin
129129- Bytes.Slice.add_to_buffer input_buffer slice;
130130- read_all ()
131131- end
132132- in
133133- read_all ();
134134-135135- (* Compress using low-allocation API *)
136136- let input_len = Buffer.length input_buffer in
137137- let input = Bytes.unsafe_of_string (Buffer.contents input_buffer) in
138138- let max_len = Brotli.max_compressed_length input_len in
139139- let compressed = Bytes.create max_len in
140140- let compressed_len =
141141- try Brotli.compress_into ~quality ~src:input ~src_pos:0 ~src_len:input_len
142142- ~dst:compressed ~dst_pos:0 ()
143143- with exn -> error (Printexc.to_string exn)
144144- in
145145-146146- (* Create a reader from the compressed data *)
147147- let output_pos = ref 0 in
148148-149149- let read () =
150150- if !output_pos >= compressed_len then Bytes.Slice.eod
151151- else begin
152152- let len = min slice_length (compressed_len - !output_pos) in
153153- let slice = Bytes.Slice.make compressed ~first:!output_pos ~length:len in
154154- output_pos := !output_pos + len;
155155- slice
156156- end
157157- in
158158- Bytes.Reader.make ?pos ~slice_length read
159159-160160-(* Compress writes - buffers input, compresses on eod *)
161161-162162-let compress_writes ?(quality = default_quality) ()
163163- ?pos ?(slice_length = default_slice_length) ~eod w
164164- =
165165- let input_buffer = Buffer.create slice_length in
166166-167167- let write = function
168168- | slice when Bytes.Slice.is_eod slice ->
169169- (* Compress using low-allocation API *)
170170- let input_len = Buffer.length input_buffer in
171171- let input = Bytes.unsafe_of_string (Buffer.contents input_buffer) in
172172- let max_len = Brotli.max_compressed_length input_len in
173173- let compressed = Bytes.create max_len in
174174- let compressed_len =
175175- try Brotli.compress_into ~quality ~src:input ~src_pos:0 ~src_len:input_len
176176- ~dst:compressed ~dst_pos:0 ()
177177- with exn -> writer_error w (Printexc.to_string exn)
178178- in
179179- Bytes.Writer.write_string w (Bytes.sub_string compressed 0 compressed_len);
180180- if eod then Bytes.Writer.write_eod w
181181- | slice ->
182182- Bytes.Slice.add_to_buffer input_buffer slice
183183- in
184184- Bytes.Writer.make ?pos ~slice_length write
-88
ocaml-brotli/bytesrw/bytesrw_brotli.mli
···11-(*---------------------------------------------------------------------------
22- Copyright (c) 2024 The brotli programmers. All rights reserved.
33- SPDX-License-Identifier: ISC
44- ---------------------------------------------------------------------------*)
55-66-(** Brotli streams (pure OCaml)
77-88- This module provides support for reading and writing
99- {{:https://www.rfc-editor.org/rfc/rfc7932}Brotli} compressed streams
1010- using a pure OCaml implementation.
1111-1212- {b Slice lengths.} The slice length of readers created by filters of
1313- this module defaults to {!default_slice_length}. The hinted slice length
1414- of writers created by filters of this module defaults to
1515- {!default_slice_length} and they write on their writers with slices
1616- that respect their desires.
1717-1818- {b Positions.} The positions of readers and writers created by filters
1919- of this module default to [0].
2020-2121- {b Buffering.} Unlike streaming compression formats, Brotli achieves
2222- better compression by seeing more context. This implementation buffers
2323- the entire input before compressing/decompressing to achieve optimal
2424- compression ratios. *)
2525-2626-open Bytesrw
2727-2828-(** {1:errors Errors} *)
2929-3030-type Bytes.Stream.error += Error of string (** *)
3131-(** The type for Brotli stream errors.
3232-3333- Except for the {{!lib}library parameters}, all functions of this
3434- module and resulting readers and writers may raise
3535- {!Bytesrw.Bytes.Stream.Error} with this error. *)
3636-3737-(** {1:decompress Decompress} *)
3838-3939-val decompress_reads : unit -> Bytes.Reader.filter
4040-(** [decompress_reads () r] filters the reads of [r] by decompressing
4141- a Brotli stream. The reader errors if the stream is malformed or
4242- truncated. *)
4343-4444-val decompress_writes : unit -> Bytes.Writer.filter
4545-(** [decompress_writes () w ~eod] filters writes on [w] by decompressing
4646- a Brotli stream until {!Bytesrw.Bytes.Slice.eod} is written. If [eod]
4747- is [false], the last {!Bytesrw.Bytes.Slice.eod} is not written on [w]
4848- and at this point [w] can be used again to perform other non-filtered
4949- writes. *)
5050-5151-(** {1:compress Compress} *)
5252-5353-type quality = int
5454-(** The type for compression quality levels.
5555-5656- An integer between [0] and [11]. See {!Brotli} for quality level
5757- descriptions. Defaults to {!default_quality}. *)
5858-5959-val compress_reads : ?quality:quality -> unit -> Bytes.Reader.filter
6060-(** [compress_reads ?quality () r] filters the reads of [r] by compressing
6161- them to a Brotli stream at quality [quality] (defaults to
6262- {!default_quality}). *)
6363-6464-val compress_writes : ?quality:quality -> unit -> Bytes.Writer.filter
6565-(** [compress_writes ?quality () w ~eod] filters writes on [w] by compressing
6666- them to a Brotli stream at quality [quality] (defaults to
6767- {!default_quality}) until {!Bytesrw.Bytes.Slice.eod} is written. If [eod]
6868- is [false], the latter is not written on [w] and at that point [w] can
6969- be used again to perform non-filtered writes. *)
7070-7171-(** {1:lib Library parameters} *)
7272-7373-val default_slice_length : int
7474-(** [default_slice_length] is [64KB]. *)
7575-7676-(** {2:quality_levels Quality levels} *)
7777-7878-val default_quality : quality
7979-(** [default_quality] is [1], fast compression. *)
8080-8181-val no_compression : quality
8282-(** [no_compression] is [0], stored blocks only. *)
8383-8484-val best_speed : quality
8585-(** [best_speed] is [1], Huffman-only compression. *)
8686-8787-val best_compression : quality
8888-(** [best_compression] is [11], optimal parsing with deep hash chains. *)
···11-(* Tests for bytesrw_brotli *)
22-33-open Bytesrw
44-55-let test_compress_reads_empty () =
66- let r = Bytes.Reader.of_string "" in
77- let cr = Bytesrw_brotli.compress_reads () r in
88- let result = Bytes.Reader.to_string cr in
99- (* Compressed empty input should still produce some output (header) *)
1010- Alcotest.(check bool) "non-empty output" true (String.length result > 0);
1111- (* Decompress to verify *)
1212- match Brotli.decompress result with
1313- | Ok s -> Alcotest.(check string) "roundtrip" "" s
1414- | Error e -> Alcotest.fail e
1515-1616-let test_compress_reads_simple () =
1717- let input = "Hello, World!" in
1818- let r = Bytes.Reader.of_string input in
1919- let cr = Bytesrw_brotli.compress_reads () r in
2020- let compressed = Bytes.Reader.to_string cr in
2121- match Brotli.decompress compressed with
2222- | Ok s -> Alcotest.(check string) "roundtrip" input s
2323- | Error e -> Alcotest.fail e
2424-2525-let test_decompress_reads_simple () =
2626- let input = "Hello, World!" in
2727- let compressed = Brotli.compress input in
2828- let r = Bytes.Reader.of_string compressed in
2929- let dr = Bytesrw_brotli.decompress_reads () r in
3030- let result = Bytes.Reader.to_string dr in
3131- Alcotest.(check string) "decompress" input result
3232-3333-let test_roundtrip_reads () =
3434- let input = String.make 1000 'X' ^ String.init 1000 (fun i -> Char.chr (i mod 256)) in
3535- let r = Bytes.Reader.of_string input in
3636- let cr = Bytesrw_brotli.compress_reads () r in
3737- let dr = Bytesrw_brotli.decompress_reads () cr in
3838- let result = Bytes.Reader.to_string dr in
3939- Alcotest.(check int) "length" (String.length input) (String.length result);
4040- Alcotest.(check string) "content" input result
4141-4242-let test_compress_writes_simple () =
4343- let input = "Hello, World!" in
4444- let b = Buffer.create 256 in
4545- let w = Bytes.Writer.of_buffer b in
4646- let cw = Bytesrw_brotli.compress_writes () ~eod:true w in
4747- Bytes.Writer.write_string cw input;
4848- Bytes.Writer.write_eod cw;
4949- let compressed = Buffer.contents b in
5050- match Brotli.decompress compressed with
5151- | Ok s -> Alcotest.(check string) "roundtrip" input s
5252- | Error e -> Alcotest.fail e
5353-5454-let test_decompress_writes_simple () =
5555- let input = "Hello, World!" in
5656- let compressed = Brotli.compress input in
5757- let b = Buffer.create 256 in
5858- let w = Bytes.Writer.of_buffer b in
5959- let dw = Bytesrw_brotli.decompress_writes () ~eod:true w in
6060- Bytes.Writer.write_string dw compressed;
6161- Bytes.Writer.write_eod dw;
6262- let result = Buffer.contents b in
6363- Alcotest.(check string) "decompress" input result
6464-6565-let test_roundtrip_writes () =
6666- let input = String.make 1000 'Y' ^ String.init 1000 (fun i -> Char.chr (i mod 256)) in
6767-6868- (* Compress *)
6969- let b1 = Buffer.create 256 in
7070- let w1 = Bytes.Writer.of_buffer b1 in
7171- let cw = Bytesrw_brotli.compress_writes () ~eod:true w1 in
7272- Bytes.Writer.write_string cw input;
7373- Bytes.Writer.write_eod cw;
7474- let compressed = Buffer.contents b1 in
7575-7676- (* Decompress *)
7777- let b2 = Buffer.create 256 in
7878- let w2 = Bytes.Writer.of_buffer b2 in
7979- let dw = Bytesrw_brotli.decompress_writes () ~eod:true w2 in
8080- Bytes.Writer.write_string dw compressed;
8181- Bytes.Writer.write_eod dw;
8282- let result = Buffer.contents b2 in
8383-8484- Alcotest.(check int) "length" (String.length input) (String.length result);
8585- Alcotest.(check string) "content" input result
8686-8787-let test_slice_length () =
8888- (* Test with different slice lengths *)
8989- let input = String.init 10000 (fun i -> Char.chr (i mod 256)) in
9090- let slice_lengths = [64; 256; 1024; 8192] in
9191- List.iter (fun slice_length ->
9292- let r = Bytes.Reader.of_string input in
9393- let cr = Bytesrw_brotli.compress_reads ~slice_length () r in
9494- let dr = Bytesrw_brotli.decompress_reads ~slice_length () cr in
9595- let result = Bytes.Reader.to_string dr in
9696- Alcotest.(check int) (Printf.sprintf "length@%d" slice_length)
9797- (String.length input) (String.length result);
9898- Alcotest.(check string) (Printf.sprintf "content@%d" slice_length) input result
9999- ) slice_lengths
100100-101101-let test_quality_levels () =
102102- (* Test different quality levels *)
103103- let input = String.init 1000 (fun i -> Char.chr (i mod 256)) in
104104- List.iter (fun quality ->
105105- let r = Bytes.Reader.of_string input in
106106- let cr = Bytesrw_brotli.compress_reads ~quality () r in
107107- let dr = Bytesrw_brotli.decompress_reads () cr in
108108- let result = Bytes.Reader.to_string dr in
109109- Alcotest.(check string) (Printf.sprintf "quality %d" quality) input result
110110- ) [1; 2; 3]
111111-112112-(* Brotli-C compatibility tests *)
113113-114114-let testdata_dir = "../../vendor/git/brotli-c/tests/testdata"
115115-116116-let read_file path =
117117- let ic = open_in_bin path in
118118- let n = in_channel_length ic in
119119- let s = really_input_string ic n in
120120- close_in ic;
121121- s
122122-123123-let file_exists path =
124124- try ignore (Unix.stat path); true
125125- with Unix.Unix_error _ -> false
126126-127127-let test_brotli_c_decompress () =
128128- (* Test decompressing official brotli-c test vectors *)
129129- let test_cases = [
130130- "empty";
131131- "10x10y";
132132- "64x";
133133- "backward65536";
134134- ] in
135135- List.iter (fun name ->
136136- let original_path = Filename.concat testdata_dir name in
137137- let compressed_path = Filename.concat testdata_dir (name ^ ".compressed") in
138138- if file_exists original_path && file_exists compressed_path then begin
139139- let original = read_file original_path in
140140- let compressed = read_file compressed_path in
141141- let r = Bytes.Reader.of_string compressed in
142142- let dr = Bytesrw_brotli.decompress_reads () r in
143143- let result = Bytes.Reader.to_string dr in
144144- Alcotest.(check int) (name ^ " length")
145145- (String.length original) (String.length result);
146146- Alcotest.(check string) (name ^ " content") original result
147147- end
148148- ) test_cases
149149-150150-let test_brotli_c_roundtrip () =
151151- (* Test that our compression produces valid output that brotli-c test files
152152- can be compared against *)
153153- let test_cases = [
154154- "10x10y";
155155- "64x";
156156- ] in
157157- List.iter (fun name ->
158158- let original_path = Filename.concat testdata_dir name in
159159- if file_exists original_path then begin
160160- let original = read_file original_path in
161161- (* Compress with our encoder *)
162162- let r = Bytes.Reader.of_string original in
163163- let cr = Bytesrw_brotli.compress_reads () r in
164164- let compressed = Bytes.Reader.to_string cr in
165165- (* Decompress with our decoder *)
166166- let dr = Bytesrw_brotli.decompress_reads ()
167167- (Bytes.Reader.of_string compressed) in
168168- let result = Bytes.Reader.to_string dr in
169169- Alcotest.(check string) (name ^ " roundtrip") original result
170170- end
171171- ) test_cases
172172-173173-let test_brotli_c_text_files () =
174174- (* Test with larger text files from brotli-c test suite *)
175175- let test_cases = [
176176- "alice29.txt";
177177- "asyoulik.txt";
178178- ] in
179179- List.iter (fun name ->
180180- let original_path = Filename.concat testdata_dir name in
181181- let compressed_path = Filename.concat testdata_dir (name ^ ".compressed") in
182182- if file_exists original_path && file_exists compressed_path then begin
183183- let original = read_file original_path in
184184- let compressed = read_file compressed_path in
185185- (* Test decompressing official brotli-c output *)
186186- let r = Bytes.Reader.of_string compressed in
187187- let dr = Bytesrw_brotli.decompress_reads () r in
188188- let result = Bytes.Reader.to_string dr in
189189- Alcotest.(check int) (name ^ " length")
190190- (String.length original) (String.length result);
191191- Alcotest.(check string) (name ^ " content") original result
192192- end
193193- ) test_cases
194194-195195-let () =
196196- Alcotest.run "bytesrw_brotli" [
197197- "compress_reads", [
198198- Alcotest.test_case "empty" `Quick test_compress_reads_empty;
199199- Alcotest.test_case "simple" `Quick test_compress_reads_simple;
200200- ];
201201- "decompress_reads", [
202202- Alcotest.test_case "simple" `Quick test_decompress_reads_simple;
203203- ];
204204- "roundtrip_reads", [
205205- Alcotest.test_case "large" `Quick test_roundtrip_reads;
206206- ];
207207- "compress_writes", [
208208- Alcotest.test_case "simple" `Quick test_compress_writes_simple;
209209- ];
210210- "decompress_writes", [
211211- Alcotest.test_case "simple" `Quick test_decompress_writes_simple;
212212- ];
213213- "roundtrip_writes", [
214214- Alcotest.test_case "large" `Quick test_roundtrip_writes;
215215- ];
216216- "parameters", [
217217- Alcotest.test_case "slice_length" `Quick test_slice_length;
218218- Alcotest.test_case "quality_levels" `Quick test_quality_levels;
219219- ];
220220- "brotli_c_compat", [
221221- Alcotest.test_case "decompress_test_vectors" `Quick test_brotli_c_decompress;
222222- Alcotest.test_case "roundtrip_test_vectors" `Quick test_brotli_c_roundtrip;
223223- Alcotest.test_case "text_files" `Quick test_brotli_c_text_files;
224224- ];
225225- ]
···11-(* Generate dictionary.ml from dictionary.bin *)
22-33-let dictionary_path = "data/dictionary.bin"
44-let output_path = "src/dictionary.ml"
55-66-let read_file path =
77- let ic = open_in_bin path in
88- let n = in_channel_length ic in
99- let data = really_input_string ic n in
1010- close_in ic;
1111- data
1212-1313-let escape_string s =
1414- let buf = Buffer.create (String.length s * 4) in
1515- String.iter (fun c ->
1616- let code = Char.code c in
1717- if code >= 32 && code < 127 && c <> '"' && c <> '\\' then
1818- Buffer.add_char buf c
1919- else
2020- Printf.bprintf buf "\\%03d" code
2121- ) s;
2222- Buffer.contents buf
2323-2424-let () =
2525- let dict_data = read_file dictionary_path in
2626- let oc = open_out output_path in
2727-2828- Printf.fprintf oc "(* Brotli static dictionary - auto-generated from dictionary.bin *)\n\n";
2929-3030- Printf.fprintf oc "(* Dictionary size: %d bytes *)\n" (String.length dict_data);
3131- Printf.fprintf oc "let data = \"%s\"\n\n" (escape_string dict_data);
3232-3333- Printf.fprintf oc "(* Word offsets by length (indices 0-24, only 4-24 are valid) *)\n";
3434- Printf.fprintf oc "let offset_by_length = [|\n";
3535- Printf.fprintf oc " 0; 0; 0; 0; 0; 4096; 9216; 21504; 35840; 44032;\n";
3636- Printf.fprintf oc " 53248; 63488; 74752; 87040; 93696; 100864; 104704; 106752; 108928; 113536;\n";
3737- Printf.fprintf oc " 115968; 118528; 119872; 121280; 122016\n";
3838- Printf.fprintf oc "|]\n\n";
3939-4040- Printf.fprintf oc "(* Log2 of word count per length *)\n";
4141- Printf.fprintf oc "let size_bits_by_length = [|\n";
4242- Printf.fprintf oc " 0; 0; 0; 0; 10; 10; 11; 11; 10; 10;\n";
4343- Printf.fprintf oc " 10; 10; 10; 9; 9; 8; 7; 7; 8; 7;\n";
4444- Printf.fprintf oc " 7; 6; 6; 5; 5\n";
4545- Printf.fprintf oc "|]\n\n";
4646-4747- Printf.fprintf oc "let min_word_length = 4\n";
4848- Printf.fprintf oc "let max_word_length = 24\n\n";
4949-5050- Printf.fprintf oc "(* Get a word from the dictionary *)\n";
5151- Printf.fprintf oc "let get_word ~length ~index =\n";
5252- Printf.fprintf oc " if length < min_word_length || length > max_word_length then\n";
5353- Printf.fprintf oc " invalid_arg \"Dictionary word length out of range\";\n";
5454- Printf.fprintf oc " let offset = offset_by_length.(length) + index * length in\n";
5555- Printf.fprintf oc " String.sub data offset length\n";
5656-5757- close_out oc;
5858- Printf.printf "Generated %s from %s (%d bytes)\n" output_path dictionary_path (String.length dict_data)
-112
ocaml-brotli/src/bit_reader.ml
···11-(* Variable-width bit reading with little-endian semantics for Brotli *)
22-33-type t = {
44- src : bytes;
55- src_len : int;
66- mutable byte_pos : int;
77- mutable bit_pos : int; (* 0-7: bits already read from current byte *)
88-}
99-1010-exception End_of_input
1111-1212-(* Bit masks for extracting n bits *)
1313-let[@inline always] bit_mask n =
1414- (1 lsl n) - 1
1515-1616-(* Get byte at position, returns 0 if past end (zero-padding) *)
1717-let[@inline always] get_byte t pos =
1818- if pos < t.src_len then
1919- Char.code (Bytes.unsafe_get t.src pos)
2020- else
2121- 0
2222-2323-let create ~src ~pos ~len =
2424- { src; src_len = pos + len; byte_pos = pos; bit_pos = 0 }
2525-2626-let create_from_string s =
2727- create ~src:(Bytes.unsafe_of_string s) ~pos:0 ~len:(String.length s)
2828-2929-let reset t =
3030- t.byte_pos <- 0;
3131- t.bit_pos <- 0
3232-3333-let position t =
3434- t.byte_pos * 8 + t.bit_pos
3535-3636-let bytes_remaining t =
3737- let total_bits = (t.src_len - t.byte_pos) * 8 - t.bit_pos in
3838- (total_bits + 7) / 8
3939-4040-let has_more t =
4141- t.byte_pos < t.src_len || t.bit_pos > 0
4242-4343-(* Read n bits (1-24) without advancing the position - optimized for common cases *)
4444-let[@inline] peek_bits t n_bits =
4545- if n_bits = 0 then 0
4646- else begin
4747- let bit_offset = t.bit_pos in
4848- let byte_pos = t.byte_pos in
4949- let bits_needed = n_bits + bit_offset in
5050- (* Optimized path for reading up to 24 bits (most common) *)
5151- if bits_needed <= 24 && byte_pos + 2 < t.src_len then begin
5252- (* Read 3 bytes at once *)
5353- let b0 = Char.code (Bytes.unsafe_get t.src byte_pos) in
5454- let b1 = Char.code (Bytes.unsafe_get t.src (byte_pos + 1)) in
5555- let b2 = Char.code (Bytes.unsafe_get t.src (byte_pos + 2)) in
5656- let combined = b0 lor (b1 lsl 8) lor (b2 lsl 16) in
5757- (combined lsr bit_offset) land bit_mask n_bits
5858- end
5959- else begin
6060- (* Fallback for edge cases and larger reads *)
6161- let result = ref 0 in
6262- let bytes_shift = ref 0 in
6363- let buf_pos = ref byte_pos in
6464- while !bytes_shift < bits_needed do
6565- result := !result lor (get_byte t !buf_pos lsl !bytes_shift);
6666- bytes_shift := !bytes_shift + 8;
6767- incr buf_pos
6868- done;
6969- (!result lsr bit_offset) land bit_mask n_bits
7070- end
7171- end
7272-7373-(* Advance by n bits without reading *)
7474-let skip_bits t n_bits =
7575- if n_bits > 0 then begin
7676- let next_in_bits = t.bit_pos + n_bits in
7777- t.bit_pos <- next_in_bits land 7;
7878- t.byte_pos <- t.byte_pos + (next_in_bits lsr 3)
7979- end
8080-8181-(* Read n bits (1-24) and advance position *)
8282-let[@inline] read_bits t n_bits =
8383- let value = peek_bits t n_bits in
8484- skip_bits t n_bits;
8585- value
8686-8787-(* Read a single bit *)
8888-let[@inline] read_bit t =
8989- read_bits t 1
9090-9191-(* Advance to next byte boundary *)
9292-let align_to_byte t =
9393- if t.bit_pos <> 0 then begin
9494- t.bit_pos <- 0;
9595- t.byte_pos <- t.byte_pos + 1
9696- end
9797-9898-(* Copy n bytes to destination buffer, first aligning to byte boundary *)
9999-let copy_bytes t ~dst ~dst_pos ~len =
100100- align_to_byte t;
101101- if len > 0 then begin
102102- let src_pos = t.byte_pos in
103103- if src_pos + len > t.src_len then
104104- raise End_of_input;
105105- Bytes.blit t.src src_pos dst dst_pos len;
106106- t.byte_pos <- src_pos + len
107107- end
108108-109109-(* Check if we have enough bits remaining *)
110110-let check_bits t n_bits =
111111- let total_bits = (t.src_len - t.byte_pos) * 8 - t.bit_pos in
112112- total_bits >= n_bits
-88
ocaml-brotli/src/bit_writer.ml
···11-(* Variable-width bit writing with little-endian semantics for Brotli *)
22-33-type t = {
44- dst : bytes;
55- dst_len : int;
66- mutable byte_pos : int;
77- mutable bit_pos : int; (* 0-7: bits already written to current byte *)
88- mutable current_byte : int; (* Accumulated bits for current byte *)
99-}
1010-1111-exception Buffer_overflow
1212-1313-let create ~dst ~pos ~len =
1414- { dst; dst_len = pos + len; byte_pos = pos; bit_pos = 0; current_byte = 0 }
1515-1616-let position t =
1717- t.byte_pos * 8 + t.bit_pos
1818-1919-let bytes_written t =
2020- if t.bit_pos = 0 then
2121- t.byte_pos
2222- else
2323- t.byte_pos + 1
2424-2525-(* Flush accumulated bits to output, return number of bytes written *)
2626-let flush t =
2727- if t.bit_pos > 0 then begin
2828- if t.byte_pos >= t.dst_len then raise Buffer_overflow;
2929- Bytes.unsafe_set t.dst t.byte_pos (Char.chr t.current_byte);
3030- t.byte_pos <- t.byte_pos + 1;
3131- t.bit_pos <- 0;
3232- t.current_byte <- 0
3333- end;
3434- t.byte_pos
3535-3636-(* Write n bits (1-24) *)
3737-let write_bits t n_bits value =
3838- if n_bits <= 0 then ()
3939- else begin
4040- (* Add bits to current accumulator *)
4141- t.current_byte <- t.current_byte lor ((value land ((1 lsl n_bits) - 1)) lsl t.bit_pos);
4242- t.bit_pos <- t.bit_pos + n_bits;
4343-4444- (* Flush complete bytes *)
4545- while t.bit_pos >= 8 do
4646- if t.byte_pos >= t.dst_len then raise Buffer_overflow;
4747- Bytes.unsafe_set t.dst t.byte_pos (Char.chr (t.current_byte land 0xFF));
4848- t.byte_pos <- t.byte_pos + 1;
4949- t.current_byte <- t.current_byte lsr 8;
5050- t.bit_pos <- t.bit_pos - 8
5151- done
5252- end
5353-5454-(* Write a single bit *)
5555-let[@inline] write_bit t value =
5656- write_bits t 1 value
5757-5858-(* Align to next byte boundary by padding with zeros *)
5959-let align_to_byte t =
6060- if t.bit_pos > 0 then begin
6161- if t.byte_pos >= t.dst_len then raise Buffer_overflow;
6262- Bytes.unsafe_set t.dst t.byte_pos (Char.chr t.current_byte);
6363- t.byte_pos <- t.byte_pos + 1;
6464- t.bit_pos <- 0;
6565- t.current_byte <- 0
6666- end
6767-6868-(* Copy raw bytes to output, first aligning to byte boundary *)
6969-let copy_bytes t ~src ~src_pos ~len =
7070- align_to_byte t;
7171- if len > 0 then begin
7272- if t.byte_pos + len > t.dst_len then raise Buffer_overflow;
7373- Bytes.blit src src_pos t.dst t.byte_pos len;
7474- t.byte_pos <- t.byte_pos + len
7575- end
7676-7777-(* Write a byte directly (for uncompressed blocks) *)
7878-let write_byte t value =
7979- write_bits t 8 value
8080-8181-(* Write a 16-bit little-endian value *)
8282-let write_u16 t value =
8383- write_bits t 16 value
8484-8585-(* Write a 32-bit little-endian value (in two parts to avoid overflow) *)
8686-let write_u32 t value =
8787- write_bits t 16 (value land 0xFFFF);
8888- write_bits t 16 ((value lsr 16) land 0xFFFF)
-501
ocaml-brotli/src/block_split.ml
···11-(* Block splitting and entropy analysis for Brotli compression *)
22-(* This module provides block splitting for improved compression at higher quality levels *)
33-44-(* Histogram for entropy calculation *)
55-type histogram = {
66- mutable data : int array;
77- mutable total : int;
88-}
99-1010-let create_histogram size = { data = Array.make size 0; total = 0 }
1111-1212-let add_sample hist symbol =
1313- hist.data.(symbol) <- hist.data.(symbol) + 1;
1414- hist.total <- hist.total + 1
1515-1616-let clear_histogram hist =
1717- Array.fill hist.data 0 (Array.length hist.data) 0;
1818- hist.total <- 0
1919-2020-(* Estimate bits needed to encode histogram using Shannon entropy *)
2121-let entropy_bits hist =
2222- if hist.total = 0 then 0.0
2323- else begin
2424- let total = float_of_int hist.total in
2525- let log2 = log 2.0 in
2626- let bits = ref 0.0 in
2727- for i = 0 to Array.length hist.data - 1 do
2828- let count = hist.data.(i) in
2929- if count > 0 then begin
3030- let p = float_of_int count /. total in
3131- bits := !bits -. (float_of_int count) *. (log p /. log2)
3232- end
3333- done;
3434- !bits
3535- end
3636-3737-(* Combined cost model: entropy + Huffman code overhead *)
3838-let histogram_cost hist =
3939- let base_cost = entropy_bits hist in
4040- (* Add overhead for code definition - roughly 5 bits per unique symbol *)
4141- let num_symbols = Array.fold_left (fun acc c -> if c > 0 then acc + 1 else acc) 0 hist.data in
4242- base_cost +. (float_of_int num_symbols *. 5.0)
4343-4444-(* Combine two histograms *)
4545-let combine_histograms h1 h2 =
4646- let result = create_histogram (Array.length h1.data) in
4747- for i = 0 to Array.length h1.data - 1 do
4848- result.data.(i) <- h1.data.(i) + h2.data.(i)
4949- done;
5050- result.total <- h1.total + h2.total;
5151- result
5252-5353-(* Bit cost increase when combining two histograms vs. separate encoding *)
5454-let split_cost_delta h1 h2 =
5555- let combined = combine_histograms h1 h2 in
5656- let combined_cost = histogram_cost combined in
5757- let separate_cost = histogram_cost h1 +. histogram_cost h2 in
5858- combined_cost -. separate_cost
5959-6060-(* Block split point *)
6161-type split_point = {
6262- position : int; (* Byte offset in input *)
6363- score : float; (* Score for this split point *)
6464-}
6565-6666-(* Minimum block size for splitting (smaller blocks aren't worth the overhead) *)
6767-let min_block_size = 1024
6868-6969-(* Maximum number of block types *)
7070-let max_block_types = 256
7171-7272-(* Maximum blocks per meta-block *)
7373-let max_blocks = 256
7474-7575-(* Analyze data and find potential split points based on entropy changes *)
7676-let find_split_points_simple src src_pos src_len =
7777- if src_len < min_block_size * 2 then
7878- []
7979- else begin
8080- let window_size = min 256 (src_len / 8) in
8181- let stride = max 64 (window_size / 2) in
8282- let points = ref [] in
8383-8484- let hist1 = create_histogram 256 in
8585- let hist2 = create_histogram 256 in
8686-8787- let pos = ref (src_pos + window_size) in
8888- while !pos < src_pos + src_len - window_size do
8989- (* Build histogram for window before position *)
9090- clear_histogram hist1;
9191- for i = !pos - window_size to !pos - 1 do
9292- add_sample hist1 (Char.code (Bytes.get src i))
9393- done;
9494-9595- (* Build histogram for window after position *)
9696- clear_histogram hist2;
9797- for i = !pos to min (!pos + window_size - 1) (src_pos + src_len - 1) do
9898- add_sample hist2 (Char.code (Bytes.get src i))
9999- done;
100100-101101- (* Calculate cost delta - higher = better split point *)
102102- let delta = split_cost_delta hist1 hist2 in
103103- if delta > 50.0 then (* Threshold for significant change *)
104104- points := { position = !pos; score = delta } :: !points;
105105-106106- pos := !pos + stride
107107- done;
108108-109109- (* Sort by score and filter to keep only best split points *)
110110- let sorted = List.sort (fun a b -> compare b.score a.score) !points in
111111-112112- (* Keep only non-overlapping splits that improve compression *)
113113- let rec filter_overlapping acc remaining =
114114- match remaining with
115115- | [] -> acc
116116- | p :: rest ->
117117- let dominated = List.exists (fun q ->
118118- abs (p.position - q.position) < min_block_size
119119- ) acc in
120120- if dominated then filter_overlapping acc rest
121121- else filter_overlapping (p :: acc) rest
122122- in
123123-124124- let filtered = filter_overlapping [] sorted in
125125-126126- (* Sort by position and limit to max_blocks - 1 splits *)
127127- let by_position = List.sort (fun a b -> compare a.position b.position) filtered in
128128- let limited =
129129- if List.length by_position >= max_blocks then
130130- let rec take n lst = if n = 0 then [] else match lst with
131131- | [] -> []
132132- | h :: t -> h :: take (n-1) t
133133- in
134134- take (max_blocks - 1) by_position
135135- else
136136- by_position
137137- in
138138-139139- List.map (fun p -> p.position) limited
140140- end
141141-142142-(* Fast log2 for bit cost calculation *)
143143-let[@inline always] fast_log2 v =
144144- if v <= 0 then 0.0
145145- else
146146- let rec log2_floor v acc = if v <= 1 then acc else log2_floor (v lsr 1) (acc + 1) in
147147- float_of_int (log2_floor v 0)
148148-149149-(* Bit cost for a symbol given a histogram - matches brotli-c BitCost *)
150150-let bit_cost count =
151151- if count = 0 then fast_log2 1 +. 2.0 (* Missing symbol penalty *)
152152- else fast_log2 count
153153-154154-(* Per-position DP block splitting matching brotli-c block_splitter_inc.h FN(FindBlocks)
155155- This tracks costs for multiple histograms simultaneously and finds optimal switch points *)
156156-let find_blocks_dp src src_pos src_len num_histograms =
157157- if src_len < min_block_size || num_histograms <= 1 then
158158- (* Trivial case: single block *)
159159- Array.make src_len 0
160160- else begin
161161- let block_id = Array.make src_len 0 in
162162-163163- (* Initialize histograms with random samples (matching brotli-c InitialEntropyCodes) *)
164164- let histograms = Array.init num_histograms (fun _ -> create_histogram 256) in
165165- let block_length = src_len / num_histograms in
166166- for i = 0 to num_histograms - 1 do
167167- let start_pos = i * block_length in
168168- let sample_len = min 64 block_length in
169169- for j = 0 to sample_len - 1 do
170170- if start_pos + j < src_len then begin
171171- let c = Char.code (Bytes.get src (src_pos + start_pos + j)) in
172172- add_sample histograms.(i) c
173173- end
174174- done
175175- done;
176176-177177- (* Compute insert costs for each symbol in each histogram *)
178178- let insert_cost = Array.make_matrix 256 num_histograms 0.0 in
179179- for h = 0 to num_histograms - 1 do
180180- let log2_total = if histograms.(h).total > 0 then
181181- fast_log2 histograms.(h).total
182182- else 0.0 in
183183- for sym = 0 to 255 do
184184- (* Cost = log2(total) - log2(count) = -log2(probability) *)
185185- insert_cost.(sym).(h) <- log2_total -. bit_cost histograms.(h).data.(sym)
186186- done
187187- done;
188188-189189- (* DP: cost.(h) = cost difference from minimum for reaching current position with histogram h *)
190190- let cost = Array.make num_histograms 0.0 in
191191- let switch_signal = Array.make_matrix src_len num_histograms false in
192192-193193- (* Block switch cost from brotli-c *)
194194- let base_block_switch_cost = 28.1 in (* From brotli-c *)
195195- let prologue_length = 2000 in
196196-197197- (* Main DP loop *)
198198- for byte_ix = 0 to src_len - 1 do
199199- let sym = Char.code (Bytes.get src (src_pos + byte_ix)) in
200200- let min_cost = ref infinity in
201201-202202- (* Update costs for each histogram *)
203203- for h = 0 to num_histograms - 1 do
204204- cost.(h) <- cost.(h) +. insert_cost.(sym).(h);
205205- if cost.(h) < !min_cost then begin
206206- min_cost := cost.(h);
207207- block_id.(byte_ix) <- h
208208- end
209209- done;
210210-211211- (* Normalize costs and mark switch signals *)
212212- let block_switch_cost =
213213- if byte_ix < prologue_length then
214214- base_block_switch_cost *. (0.77 +. 0.07 /. 2000.0 *. float_of_int byte_ix)
215215- else base_block_switch_cost
216216- in
217217-218218- for h = 0 to num_histograms - 1 do
219219- cost.(h) <- cost.(h) -. !min_cost;
220220- if cost.(h) >= block_switch_cost then begin
221221- cost.(h) <- block_switch_cost;
222222- switch_signal.(byte_ix).(h) <- true
223223- end
224224- done
225225- done;
226226-227227- (* Traceback: find block boundaries *)
228228- let cur_id = ref block_id.(src_len - 1) in
229229- for byte_ix = src_len - 2 downto 0 do
230230- if switch_signal.(byte_ix).(!cur_id) then
231231- cur_id := block_id.(byte_ix);
232232- block_id.(byte_ix) <- !cur_id
233233- done;
234234-235235- block_id
236236- end
237237-238238-(* More sophisticated splitting using dynamic programming *)
239239-let find_split_points_dp src src_pos src_len max_splits =
240240- if src_len < min_block_size * 2 then
241241- []
242242- else begin
243243- (* Build cumulative histograms for O(1) range queries *)
244244- let cum_hist = Array.make_matrix (src_len + 1) 256 0 in
245245- for i = 0 to src_len - 1 do
246246- let c = Char.code (Bytes.get src (src_pos + i)) in
247247- for j = 0 to 255 do
248248- cum_hist.(i + 1).(j) <- cum_hist.(i).(j)
249249- done;
250250- cum_hist.(i + 1).(c) <- cum_hist.(i + 1).(c) + 1
251251- done;
252252-253253- (* Get histogram for range [start, end) *)
254254- let get_range_histogram start_pos end_pos =
255255- let hist = create_histogram 256 in
256256- for j = 0 to 255 do
257257- hist.data.(j) <- cum_hist.(end_pos).(j) - cum_hist.(start_pos).(j)
258258- done;
259259- hist.total <- end_pos - start_pos;
260260- hist
261261- in
262262-263263- (* Compute entropy cost for a block *)
264264- let block_cost start_pos end_pos =
265265- if end_pos <= start_pos then 0.0
266266- else begin
267267- let hist = get_range_histogram start_pos end_pos in
268268- histogram_cost hist
269269- end
270270- in
271271-272272- (* DP: find optimal k splits *)
273273- let n = min (src_len / min_block_size) 32 in (* Candidate positions *)
274274- if n < 2 then []
275275- else begin
276276- let step = src_len / n in
277277- let positions = Array.init n (fun i -> min ((i + 1) * step) src_len) in
278278-279279- (* dp.(i).(k) = minimum cost to encode first positions.(i) bytes with k splits *)
280280- let max_k = min max_splits (n - 1) in
281281- let dp = Array.make_matrix n (max_k + 1) infinity in
282282- let parent = Array.make_matrix n (max_k + 1) (-1) in
283283-284284- (* Base case: no splits *)
285285- for i = 0 to n - 1 do
286286- dp.(i).(0) <- block_cost 0 positions.(i)
287287- done;
288288-289289- (* Fill DP table *)
290290- for k = 1 to max_k do
291291- for i = k to n - 1 do
292292- for j = k - 1 to i - 1 do
293293- let prev_cost = dp.(j).(k - 1) in
294294- let this_block = block_cost positions.(j) positions.(i) in
295295- let total = prev_cost +. this_block +. 32.0 in (* 32 bits overhead per block *)
296296- if total < dp.(i).(k) then begin
297297- dp.(i).(k) <- total;
298298- parent.(i).(k) <- j
299299- end
300300- done
301301- done
302302- done;
303303-304304- (* Find best number of splits for the full input *)
305305- let last_pos = n - 1 in
306306- let best_k = ref 0 in
307307- let best_cost = ref dp.(last_pos).(0) in
308308- for k = 1 to max_k do
309309- if dp.(last_pos).(k) < !best_cost then begin
310310- best_cost := dp.(last_pos).(k);
311311- best_k := k
312312- end
313313- done;
314314-315315- (* Backtrack to find split positions *)
316316- let splits = ref [] in
317317- let rec backtrack i k =
318318- if k > 0 then begin
319319- let j = parent.(i).(k) in
320320- if j >= 0 then begin
321321- splits := (src_pos + positions.(j)) :: !splits;
322322- backtrack j (k - 1)
323323- end
324324- end
325325- in
326326- backtrack last_pos !best_k;
327327-328328- !splits
329329- end
330330- end
331331-332332-(* High-level function: find optimal block split points *)
333333-let find_split_points ?(quality=5) src src_pos src_len =
334334- if quality < 5 || src_len < min_block_size then
335335- []
336336- else if quality >= 10 then
337337- (* Use DP-based splitting for highest quality *)
338338- find_split_points_dp src src_pos src_len (max_blocks - 1)
339339- else
340340- (* Use simpler entropy-based splitting *)
341341- find_split_points_simple src src_pos src_len
342342-343343-(* Context mode selection for a block *)
344344-345345-(* Score how well a context mode fits the data *)
346346-let score_context_mode mode src src_pos src_len =
347347- if src_len < 16 then 0.0
348348- else begin
349349- (* Create per-context histograms *)
350350- let num_contexts = 64 in
351351- let histograms = Array.init num_contexts (fun _ -> create_histogram 256) in
352352-353353- (* Populate histograms *)
354354- let prev1 = ref 0 in
355355- let prev2 = ref 0 in
356356- for i = 0 to src_len - 1 do
357357- let byte = Char.code (Bytes.get src (src_pos + i)) in
358358- let context_id = Context.get_context mode ~prev_byte1:!prev1 ~prev_byte2:!prev2 in
359359- add_sample histograms.(context_id) byte;
360360- prev2 := !prev1;
361361- prev1 := byte
362362- done;
363363-364364- (* Calculate total bits needed with this context mode *)
365365- let total_bits = Array.fold_left (fun acc h -> acc +. entropy_bits h) 0.0 histograms in
366366-367367- (* Lower is better, but return negative so higher score = better *)
368368- -. total_bits
369369- end
370370-371371-(* Choose the best context mode for a block *)
372372-let choose_context_mode src src_pos src_len =
373373- if src_len < 32 then
374374- Context.LSB6 (* Default for small blocks *)
375375- else begin
376376- let modes = [| Context.LSB6; Context.MSB6; Context.UTF8; Context.SIGNED |] in
377377- let best_mode = ref Context.LSB6 in
378378- let best_score = ref neg_infinity in
379379- Array.iter (fun mode ->
380380- let score = score_context_mode mode src src_pos src_len in
381381- if score > !best_score then begin
382382- best_score := score;
383383- best_mode := mode
384384- end
385385- ) modes;
386386- !best_mode
387387- end
388388-389389-(* Cluster histograms to reduce number of Huffman trees needed *)
390390-type cluster = {
391391- mutable members : int list;
392392- mutable histogram : histogram;
393393-}
394394-395395-(* Distance between two histograms (symmetric KL divergence approximation) *)
396396-let histogram_distance h1 h2 =
397397- if h1.total = 0 || h2.total = 0 then infinity
398398- else begin
399399- let t1 = float_of_int h1.total in
400400- let t2 = float_of_int h2.total in
401401- let dist = ref 0.0 in
402402- for i = 0 to Array.length h1.data - 1 do
403403- let c1 = float_of_int h1.data.(i) in
404404- let c2 = float_of_int h2.data.(i) in
405405- if c1 > 0.0 && c2 > 0.0 then begin
406406- let p1 = c1 /. t1 in
407407- let p2 = c2 /. t2 in
408408- let avg = (p1 +. p2) /. 2.0 in
409409- (* Jensen-Shannon divergence *)
410410- dist := !dist +. c1 *. (log (p1 /. avg)) +. c2 *. (log (p2 /. avg))
411411- end else if c1 > 0.0 || c2 > 0.0 then
412412- dist := !dist +. 10.0 (* Penalty for mismatched symbols *)
413413- done;
414414- !dist
415415- end
416416-417417-(* Cluster context histograms using greedy agglomerative clustering *)
418418-let cluster_histograms histograms max_clusters =
419419- let n = Array.length histograms in
420420- if n <= max_clusters then
421421- (* Each context maps to its own cluster *)
422422- Array.init n (fun i -> i)
423423- else begin
424424- (* Initialize: each histogram is its own cluster *)
425425- let clusters = Array.init n (fun i ->
426426- { members = [i]; histogram = histograms.(i) }
427427- ) in
428428- let active = Array.make n true in
429429- let num_active = ref n in
430430-431431- (* Merge until we have max_clusters *)
432432- while !num_active > max_clusters do
433433- (* Find the two closest clusters *)
434434- let best_i = ref (-1) in
435435- let best_j = ref (-1) in
436436- let best_dist = ref infinity in
437437-438438- for i = 0 to n - 1 do
439439- if active.(i) then
440440- for j = i + 1 to n - 1 do
441441- if active.(j) then begin
442442- let dist = histogram_distance clusters.(i).histogram clusters.(j).histogram in
443443- if dist < !best_dist then begin
444444- best_dist := dist;
445445- best_i := i;
446446- best_j := j
447447- end
448448- end
449449- done
450450- done;
451451-452452- (* Merge best_j into best_i *)
453453- if !best_i >= 0 && !best_j >= 0 then begin
454454- clusters.(!best_i).members <- clusters.(!best_j).members @ clusters.(!best_i).members;
455455- clusters.(!best_i).histogram <- combine_histograms
456456- clusters.(!best_i).histogram
457457- clusters.(!best_j).histogram;
458458- active.(!best_j) <- false;
459459- decr num_active
460460- end else
461461- num_active := 0 (* Shouldn't happen, but exit loop *)
462462- done;
463463-464464- (* Build context map: context_id -> cluster_id *)
465465- let context_map = Array.make n 0 in
466466- let cluster_id = ref 0 in
467467- for i = 0 to n - 1 do
468468- if active.(i) then begin
469469- List.iter (fun ctx -> context_map.(ctx) <- !cluster_id) clusters.(i).members;
470470- incr cluster_id
471471- end
472472- done;
473473-474474- context_map
475475- end
476476-477477-(* Build context map for literal encoding *)
478478-let build_literal_context_map mode src src_pos src_len max_trees =
479479- let num_contexts = 64 in
480480-481481- (* Build per-context histograms *)
482482- let histograms = Array.init num_contexts (fun _ -> create_histogram 256) in
483483-484484- let prev1 = ref 0 in
485485- let prev2 = ref 0 in
486486- for i = 0 to src_len - 1 do
487487- let byte = Char.code (Bytes.get src (src_pos + i)) in
488488- let context_id = Context.get_context mode ~prev_byte1:!prev1 ~prev_byte2:!prev2 in
489489- add_sample histograms.(context_id) byte;
490490- prev2 := !prev1;
491491- prev1 := byte
492492- done;
493493-494494- (* Cluster histograms *)
495495- let context_map = cluster_histograms histograms max_trees in
496496-497497- (* Count actual number of trees used *)
498498- let max_tree = Array.fold_left max 0 context_map in
499499- let num_trees = max_tree + 1 in
500500-501501- (context_map, histograms, num_trees)
-92
ocaml-brotli/src/brotli.ml
···11-(* Pure OCaml implementation of Brotli compression (RFC 7932) *)
22-33-(* Re-export error types from decoder *)
44-type error = Brotli_decode.error =
55- | Invalid_stream_header
66- | Invalid_meta_block_header
77- | Invalid_huffman_code
88- | Invalid_distance
99- | Invalid_backward_reference
1010- | Invalid_context_map
1111- | Truncated_input
1212- | Output_overrun
1313-1414-exception Brotli_error = Brotli_decode.Brotli_error
1515-1616-let error_to_string = Brotli_decode.error_to_string
1717-1818-(* Low-allocation API *)
1919-2020-let compress_into ?(quality=1) ~src ~src_pos ~src_len ~dst ~dst_pos () =
2121- Brotli_encode.compress_into ~quality ~src ~src_pos ~src_len ~dst ~dst_pos ()
2222-2323-let decompress_into ~src ~src_pos ~src_len ~dst ~dst_pos =
2424- Brotli_decode.decompress_into ~src ~src_pos ~src_len ~dst ~dst_pos
2525-2626-(* Utilities *)
2727-2828-let max_compressed_length = Brotli_encode.max_compressed_length
2929-3030-(* Simple string API *)
3131-3232-let compress ?(quality = 1) s =
3333- let src = Bytes.unsafe_of_string s in
3434- let src_len = String.length s in
3535- let max_len = max_compressed_length src_len in
3636- let dst = Bytes.create max_len in
3737- let len = Brotli_encode.compress_into ~quality ~src ~src_pos:0 ~src_len ~dst ~dst_pos:0 () in
3838- Bytes.sub_string dst 0 len
3939-4040-let decompress s =
4141- try
4242- let src = Bytes.unsafe_of_string s in
4343- let src_len = String.length s in
4444- (* Estimate decompressed size - start with 4x input size *)
4545- let initial_size = max 256 (src_len * 4) in
4646- let dst = ref (Bytes.create initial_size) in
4747- let rec try_decompress size =
4848- try
4949- dst := Bytes.create size;
5050- let len = decompress_into ~src ~src_pos:0 ~src_len ~dst:!dst ~dst_pos:0 in
5151- Ok (Bytes.sub_string !dst 0 len)
5252- with
5353- | Brotli_error Output_overrun ->
5454- (* Double buffer size and retry *)
5555- if size > 256 * 1024 * 1024 then
5656- Error "Output too large"
5757- else
5858- try_decompress (size * 2)
5959- in
6060- try_decompress initial_size
6161- with
6262- | Brotli_error e -> Error (error_to_string e)
6363- | Bit_reader.End_of_input -> Error "Truncated input"
6464-6565-let decompress_exn s =
6666- match decompress s with
6767- | Ok result -> result
6868- | Error msg -> failwith msg
6969-7070-(* Streaming compression API *)
7171-type streaming_encoder = Brotli_encode.streaming_encoder
7272-7373-let create_streaming_encoder = Brotli_encode.create_streaming_encoder
7474-let streaming_write = Brotli_encode.streaming_write
7575-let streaming_finish = Brotli_encode.streaming_finish
7676-let streaming_bytes_written = Brotli_encode.streaming_bytes_written
7777-7878-(* Constants *)
7979-let min_quality = 0
8080-let max_quality = 11
8181-let default_quality = 1
8282-let max_window_bits = 22
8383-8484-(* Debug module for testing *)
8585-module Debug = struct
8686- type command = Brotli_encode.command =
8787- | InsertCopy of { lit_start: int; lit_len: int; copy_len: int; distance: int; dist_code: int option }
8888- | Literals of { start: int; len: int }
8989-9090- let generate_commands src src_pos src_len =
9191- Brotli_encode.generate_commands src src_pos src_len
9292-end
-219
ocaml-brotli/src/brotli.mli
···11-(*---------------------------------------------------------------------------
22- Copyright (c) 2024 The brotli programmers. All rights reserved.
33- SPDX-License-Identifier: ISC
44- ---------------------------------------------------------------------------*)
55-66-(** Pure OCaml Brotli compression and decompression.
77-88- This module implements the {{:https://www.rfc-editor.org/rfc/rfc7932}Brotli}
99- compressed data format as specified in RFC 7932.
1010-1111- Brotli is a general-purpose lossless compression algorithm that uses
1212- LZ77 matching, Huffman coding, and 2nd order context modeling, with a
1313- pre-defined 122 KB static dictionary for improved text compression.
1414-1515- {2 Compression quality levels}
1616-1717- Quality levels control the trade-off between compression ratio and speed:
1818- {ul
1919- {- Quality [0]: Stored (uncompressed) blocks only.}
2020- {- Quality [1]: Huffman-only compression, no LZ77 matching.}
2121- {- Quality [2]-[3]: LZ77 with simple hash table matching.}
2222- {- Quality [4]: Hash chains (16 depth) with dictionary matching.}
2323- {- Quality [5]-[6]: Context mode selection for better literal coding.}
2424- {- Quality [7]-[9]: Multiple literal Huffman trees (2-4 trees).}
2525- {- Quality [10]-[11]: Optimal parsing with deep hash chains (512 depth).}}
2626-2727- {2 RFC 7932 specification mapping}
2828-2929- This implementation covers the following RFC 7932 sections:
3030- {ul
3131- {- {{:https://www.rfc-editor.org/rfc/rfc7932#section-3}Section 3}: Header
3232- (WBITS window size encoding)}
3333- {- {{:https://www.rfc-editor.org/rfc/rfc7932#section-4}Section 4}: Meta-block
3434- structure (MLEN, ISUNCOMPRESSED)}
3535- {- {{:https://www.rfc-editor.org/rfc/rfc7932#section-5}Section 5}: Prefix
3636- codes (simple and complex Huffman codes)}
3737- {- {{:https://www.rfc-editor.org/rfc/rfc7932#section-6}Section 6}: Context
3838- modeling (LSB6, MSB6, UTF8, SIGNED modes)}
3939- {- {{:https://www.rfc-editor.org/rfc/rfc7932#section-7}Section 7}: Block
4040- types and block counts}
4141- {- {{:https://www.rfc-editor.org/rfc/rfc7932#section-8}Section 8}: Distance
4242- codes (ring buffer with 16 short codes)}
4343- {- {{:https://www.rfc-editor.org/rfc/rfc7932#section-9}Section 9}: LZ77
4444- commands (insert-and-copy, literals)}
4545- {- {{:https://www.rfc-editor.org/rfc/rfc7932#appendix-A}Appendix A}: Static
4646- dictionary (122 KB, 121 transforms)}}
4747-*)
4848-4949-(** {1:errors Error handling} *)
5050-5151-type error =
5252- | Invalid_stream_header
5353- (** WBITS value in stream header is invalid
5454- ({{:https://www.rfc-editor.org/rfc/rfc7932#section-9.1}RFC 7932 Section 9.1}) *)
5555- | Invalid_meta_block_header
5656- (** Meta-block header is malformed
5757- ({{:https://www.rfc-editor.org/rfc/rfc7932#section-9.2}RFC 7932 Section 9.2}) *)
5858- | Invalid_huffman_code
5959- (** Prefix code definition is invalid
6060- ({{:https://www.rfc-editor.org/rfc/rfc7932#section-3.2}RFC 7932 Section 3.2}) *)
6161- | Invalid_distance
6262- (** Distance code or value is out of range
6363- ({{:https://www.rfc-editor.org/rfc/rfc7932#section-4}RFC 7932 Section 4}) *)
6464- | Invalid_backward_reference
6565- (** Backward reference points before start of output *)
6666- | Invalid_context_map
6767- (** Context map encoding is invalid
6868- ({{:https://www.rfc-editor.org/rfc/rfc7932#section-7.3}RFC 7932 Section 7.3}) *)
6969- | Truncated_input
7070- (** Input stream ended unexpectedly *)
7171- | Output_overrun
7272- (** Decompressed size exceeds output buffer *)
7373-(** The type for decompression errors. Error constructors reference the
7474- relevant RFC 7932 sections. *)
7575-7676-exception Brotli_error of error
7777-(** Exception raised on decompression errors. *)
7878-7979-val error_to_string : error -> string
8080-(** [error_to_string e] returns a human-readable description of error [e]. *)
8181-8282-(** {1:simple Simple API} *)
8383-8484-val compress : ?quality:int -> string -> string
8585-(** [compress ?quality s] compresses string [s] using Brotli.
8686-8787- @param quality Compression quality [0]-[11] (default: [1]).
8888- Higher values give better compression at the cost of speed.
8989- See {{!quality_levels}quality levels} for details. *)
9090-9191-val decompress : string -> (string, string) result
9292-(** [decompress s] decompresses a Brotli-compressed string.
9393-9494- Returns [Ok decompressed] on success or [Error message] on failure.
9595- The input must be a complete, valid Brotli stream. *)
9696-9797-val decompress_exn : string -> string
9898-(** [decompress_exn s] decompresses a Brotli-compressed string.
9999-100100- @raise Brotli_error on decompression failure. *)
101101-102102-(** {1:low_alloc Low-allocation API}
103103-104104- These functions avoid intermediate string allocations by operating
105105- directly on byte buffers. Use {!max_compressed_length} to size output
106106- buffers for compression. *)
107107-108108-val compress_into :
109109- ?quality:int ->
110110- src:bytes -> src_pos:int -> src_len:int ->
111111- dst:bytes -> dst_pos:int -> unit -> int
112112-(** [compress_into ?quality ~src ~src_pos ~src_len ~dst ~dst_pos ()]
113113- compresses [src_len] bytes from [src] starting at [src_pos] into [dst]
114114- starting at [dst_pos].
115115-116116- @return the number of bytes written to [dst].
117117-118118- The caller must ensure [dst] has at least [max_compressed_length src_len]
119119- bytes available starting at [dst_pos]. *)
120120-121121-val decompress_into :
122122- src:bytes -> src_pos:int -> src_len:int ->
123123- dst:bytes -> dst_pos:int -> int
124124-(** [decompress_into ~src ~src_pos ~src_len ~dst ~dst_pos] decompresses
125125- [src_len] bytes from [src] starting at [src_pos] into [dst] starting at
126126- [dst_pos].
127127-128128- @return the number of bytes written to [dst].
129129- @raise Brotli_error if the input is invalid or the output buffer is
130130- too small. *)
131131-132132-(** {1:utils Utilities} *)
133133-134134-val max_compressed_length : int -> int
135135-(** [max_compressed_length n] returns the maximum possible compressed size
136136- for an input of [n] bytes. Use this to allocate output buffers for
137137- {!compress_into}. *)
138138-139139-(** {1:streaming Streaming compression API}
140140-141141- The streaming API allows compressing data in chunks. Each chunk is
142142- encoded as a complete meta-block
143143- ({{:https://www.rfc-editor.org/rfc/rfc7932#section-9.2}RFC 7932 Section 9.2}}),
144144- which allows the decoder to process chunks independently.
145145-146146- {b Note}: For best compression, prefer the simple API with the complete
147147- input when possible. The streaming API trades compression ratio for
148148- the ability to process data incrementally. *)
149149-150150-type streaming_encoder
151151-(** Opaque type for streaming compression state. *)
152152-153153-val create_streaming_encoder :
154154- ?quality:int -> dst:bytes -> dst_pos:int -> unit -> streaming_encoder
155155-(** [create_streaming_encoder ?quality ~dst ~dst_pos ()] creates a new
156156- streaming encoder that writes to [dst] starting at [dst_pos].
157157-158158- @param quality Compression quality [0]-[11] (default: [1]). *)
159159-160160-val streaming_write :
161161- streaming_encoder ->
162162- src:bytes -> src_pos:int -> src_len:int -> is_last:bool -> int
163163-(** [streaming_write encoder ~src ~src_pos ~src_len ~is_last] compresses
164164- [src_len] bytes from [src] starting at [src_pos] and writes them to
165165- the encoder's output buffer.
166166-167167- @param is_last Set to [true] for the final chunk to emit the stream
168168- trailer (ISLAST=1 meta-block).
169169- @return the number of bytes written to the output buffer. *)
170170-171171-val streaming_finish : streaming_encoder -> int
172172-(** [streaming_finish encoder] finishes the stream if not already finished.
173173-174174- @return bytes written (0 if already finished). *)
175175-176176-val streaming_bytes_written : streaming_encoder -> int
177177-(** [streaming_bytes_written encoder] returns total bytes written so far. *)
178178-179179-(** {1:constants Constants}
180180-181181- These constants correspond to values defined in
182182- {{:https://www.rfc-editor.org/rfc/rfc7932}RFC 7932}. *)
183183-184184-val min_quality : int
185185-(** [min_quality] is [0], the minimum compression quality (stored blocks). *)
186186-187187-val max_quality : int
188188-(** [max_quality] is [11], the maximum compression quality. *)
189189-190190-val default_quality : int
191191-(** [default_quality] is [1], the default compression quality. *)
192192-193193-val max_window_bits : int
194194-(** [max_window_bits] is [22], the maximum window size (4 MB).
195195- See {{:https://www.rfc-editor.org/rfc/rfc7932#section-9.1}RFC 7932 Section 9.1}. *)
196196-197197-(** {1:internals Internals}
198198-199199- These functions are exposed for testing and debugging. They are not
200200- part of the stable API. *)
201201-202202-module Debug : sig
203203- (** Debug utilities for inspecting LZ77 commands. *)
204204-205205- type command =
206206- | InsertCopy of {
207207- lit_start: int; (** Start offset in source for literals *)
208208- lit_len: int; (** Number of literal bytes to insert *)
209209- copy_len: int; (** Number of bytes to copy from back-reference *)
210210- distance: int; (** Back-reference distance in bytes *)
211211- dist_code: int option; (** Short distance code [0]-[15] if used *)
212212- }
213213- | Literals of { start: int; len: int }
214214- (** LZ77 command representation.
215215- See {{:https://www.rfc-editor.org/rfc/rfc7932#section-5}RFC 7932 Section 5}. *)
216216-217217- val generate_commands : bytes -> int -> int -> command list
218218- (** [generate_commands src pos len] generates LZ77 commands for the input. *)
219219-end
-558
ocaml-brotli/src/brotli_decode.ml
···11-(* Brotli decompression implementation (RFC 7932) *)
22-33-type error =
44- | Invalid_stream_header
55- | Invalid_meta_block_header
66- | Invalid_huffman_code
77- | Invalid_distance
88- | Invalid_backward_reference
99- | Invalid_context_map
1010- | Truncated_input
1111- | Output_overrun
1212-1313-exception Brotli_error of error
1414-1515-let error_to_string = function
1616- | Invalid_stream_header -> "Invalid stream header"
1717- | Invalid_meta_block_header -> "Invalid meta-block header"
1818- | Invalid_huffman_code -> "Invalid Huffman code"
1919- | Invalid_distance -> "Invalid distance"
2020- | Invalid_backward_reference -> "Invalid backward reference"
2121- | Invalid_context_map -> "Invalid context map"
2222- | Truncated_input -> "Truncated input"
2323- | Output_overrun -> "Output buffer overrun"
2424-2525-(* Distance short code lookup tables *)
2626-let distance_short_code_index_offset = [| 3; 2; 1; 0; 3; 3; 3; 3; 3; 3; 2; 2; 2; 2; 2; 2 |]
2727-let distance_short_code_value_offset = [| 0; 0; 0; 0; -1; 1; -2; 2; -3; 3; -1; 1; -2; 2; -3; 3 |]
2828-2929-(* Static Huffman code for code length code lengths *)
3030-let code_length_huff = [|
3131- { Huffman.bits = 2; value = 0 }; { Huffman.bits = 2; value = 4 };
3232- { Huffman.bits = 2; value = 3 }; { Huffman.bits = 3; value = 2 };
3333- { Huffman.bits = 2; value = 0 }; { Huffman.bits = 2; value = 4 };
3434- { Huffman.bits = 2; value = 3 }; { Huffman.bits = 4; value = 1 };
3535- { Huffman.bits = 2; value = 0 }; { Huffman.bits = 2; value = 4 };
3636- { Huffman.bits = 2; value = 3 }; { Huffman.bits = 3; value = 2 };
3737- { Huffman.bits = 2; value = 0 }; { Huffman.bits = 2; value = 4 };
3838- { Huffman.bits = 2; value = 3 }; { Huffman.bits = 4; value = 5 };
3939-|]
4040-4141-(* Decode window bits from stream header *)
4242-let decode_window_bits br =
4343- if Bit_reader.read_bits br 1 = 0 then 16
4444- else begin
4545- let n = Bit_reader.read_bits br 3 in
4646- if n > 0 then 17 + n
4747- else begin
4848- let n = Bit_reader.read_bits br 3 in
4949- if n > 0 then 8 + n
5050- else 17
5151- end
5252- end
5353-5454-(* Decode a variable length uint8 (0-255) *)
5555-let decode_var_len_uint8 br =
5656- if Bit_reader.read_bits br 1 = 1 then begin
5757- let nbits = Bit_reader.read_bits br 3 in
5858- if nbits = 0 then 1
5959- else Bit_reader.read_bits br nbits + (1 lsl nbits)
6060- end
6161- else 0
6262-6363-(* Meta-block header *)
6464-type meta_block_header = {
6565- meta_block_length : int;
6666- input_end : bool;
6767- is_uncompressed : bool;
6868- is_metadata : bool;
6969-}
7070-7171-(* Decode meta-block length *)
7272-let decode_meta_block_length br =
7373- let input_end = Bit_reader.read_bits br 1 = 1 in
7474- if input_end && Bit_reader.read_bits br 1 = 1 then
7575- { meta_block_length = 0; input_end = true; is_uncompressed = false; is_metadata = false }
7676- else begin
7777- let size_nibbles = Bit_reader.read_bits br 2 + 4 in
7878- if size_nibbles = 7 then begin
7979- (* Metadata block *)
8080- if Bit_reader.read_bits br 1 <> 0 then
8181- raise (Brotli_error Invalid_meta_block_header);
8282- let size_bytes = Bit_reader.read_bits br 2 in
8383- if size_bytes = 0 then
8484- { meta_block_length = 0; input_end; is_uncompressed = false; is_metadata = true }
8585- else begin
8686- let length = ref 0 in
8787- for i = 0 to size_bytes - 1 do
8888- let next_byte = Bit_reader.read_bits br 8 in
8989- if i + 1 = size_bytes && size_bytes > 1 && next_byte = 0 then
9090- raise (Brotli_error Invalid_meta_block_header);
9191- length := !length lor (next_byte lsl (i * 8))
9292- done;
9393- { meta_block_length = !length + 1; input_end; is_uncompressed = false; is_metadata = true }
9494- end
9595- end
9696- else begin
9797- let length = ref 0 in
9898- for i = 0 to size_nibbles - 1 do
9999- let next_nibble = Bit_reader.read_bits br 4 in
100100- if i + 1 = size_nibbles && size_nibbles > 4 && next_nibble = 0 then
101101- raise (Brotli_error Invalid_meta_block_header);
102102- length := !length lor (next_nibble lsl (i * 4))
103103- done;
104104- let is_uncompressed =
105105- if not input_end then Bit_reader.read_bits br 1 = 1
106106- else false
107107- in
108108- { meta_block_length = !length + 1; input_end; is_uncompressed; is_metadata = false }
109109- end
110110- end
111111-112112-(* Read Huffman code lengths *)
113113-let read_huffman_code_lengths code_length_code_lengths num_symbols code_lengths br =
114114- let symbol = ref 0 in
115115- let prev_code_len = ref 8 in
116116- let repeat = ref 0 in
117117- let repeat_code_len = ref 0 in
118118- let space = ref 32768 in
119119-120120- (* Build table for code length codes *)
121121- let table = Huffman.build_table ~code_lengths:code_length_code_lengths
122122- ~alphabet_size:Constants.code_length_codes ~root_bits:5 in
123123-124124- while !symbol < num_symbols && !space > 0 do
125125- let code_len = Huffman.read_symbol table 5 br in
126126- if code_len < Constants.repeat_previous_code_length then begin
127127- repeat := 0;
128128- code_lengths.(!symbol) <- code_len;
129129- incr symbol;
130130- if code_len <> 0 then begin
131131- prev_code_len := code_len;
132132- space := !space - (0x8000 lsr code_len)
133133- end
134134- end
135135- else begin
136136- let extra_bits = code_len - 14 in
137137- let new_len = if code_len = Constants.repeat_previous_code_length then !prev_code_len else 0 in
138138- if !repeat_code_len <> new_len then begin
139139- repeat := 0;
140140- repeat_code_len := new_len
141141- end;
142142- let old_repeat = !repeat in
143143- if !repeat > 0 then
144144- repeat := (!repeat - 2) lsl extra_bits;
145145- repeat := !repeat + Bit_reader.read_bits br extra_bits + 3;
146146- let repeat_delta = !repeat - old_repeat in
147147- if !symbol + repeat_delta > num_symbols then
148148- raise (Brotli_error Invalid_huffman_code);
149149- for _ = 0 to repeat_delta - 1 do
150150- code_lengths.(!symbol) <- !repeat_code_len;
151151- incr symbol
152152- done;
153153- if !repeat_code_len <> 0 then
154154- space := !space - (repeat_delta lsl (15 - !repeat_code_len))
155155- end
156156- done;
157157-158158- if !space <> 0 then
159159- raise (Brotli_error Invalid_huffman_code);
160160-161161- for i = !symbol to num_symbols - 1 do
162162- code_lengths.(i) <- 0
163163- done
164164-165165-(* Read a Huffman code from the stream *)
166166-let read_huffman_code_with_bits alphabet_size root_bits br =
167167- let code_lengths = Array.make alphabet_size 0 in
168168- let simple_code_or_skip = Bit_reader.read_bits br 2 in
169169-170170- if simple_code_or_skip = 1 then begin
171171- (* Simple prefix code *)
172172- let max_bits = ref 0 in
173173- let max_bits_counter = ref (alphabet_size - 1) in
174174- while !max_bits_counter > 0 do
175175- max_bits_counter := !max_bits_counter lsr 1;
176176- incr max_bits
177177- done;
178178-179179- let symbols = Array.make 4 0 in
180180- let num_symbols = Bit_reader.read_bits br 2 + 1 in
181181-182182- for i = 0 to num_symbols - 1 do
183183- symbols.(i) <- Bit_reader.read_bits br !max_bits mod alphabet_size;
184184- code_lengths.(symbols.(i)) <- 2
185185- done;
186186- code_lengths.(symbols.(0)) <- 1;
187187-188188- if num_symbols = 2 then begin
189189- if symbols.(0) = symbols.(1) then
190190- raise (Brotli_error Invalid_huffman_code);
191191- code_lengths.(symbols.(1)) <- 1
192192- end
193193- else if num_symbols = 4 then begin
194194- if Bit_reader.read_bits br 1 = 1 then begin
195195- code_lengths.(symbols.(2)) <- 3;
196196- code_lengths.(symbols.(3)) <- 3
197197- end
198198- else
199199- code_lengths.(symbols.(0)) <- 2
200200- end;
201201-202202- Huffman.build_table ~code_lengths ~alphabet_size ~root_bits
203203- end
204204- else begin
205205- (* Complex prefix code *)
206206- let code_length_code_lengths = Array.make Constants.code_length_codes 0 in
207207- let space = ref 32 in
208208- let num_codes = ref 0 in
209209-210210- for i = simple_code_or_skip to Constants.code_length_codes - 1 do
211211- if !space > 0 then begin
212212- let code_len_idx = Constants.code_length_code_order.(i) in
213213- let p = Bit_reader.peek_bits br 4 in
214214- Bit_reader.skip_bits br code_length_huff.(p).bits;
215215- let v = code_length_huff.(p).value in
216216- code_length_code_lengths.(code_len_idx) <- v;
217217- if v <> 0 then begin
218218- space := !space - (32 lsr v);
219219- incr num_codes
220220- end
221221- end
222222- done;
223223-224224- if !num_codes <> 1 && !space <> 0 then
225225- raise (Brotli_error Invalid_huffman_code);
226226-227227- read_huffman_code_lengths code_length_code_lengths alphabet_size code_lengths br;
228228-229229- (* Debug output removed for cleaner test output *)
230230-231231- Huffman.build_table ~code_lengths ~alphabet_size ~root_bits
232232- end
233233-234234-let read_huffman_code alphabet_size br =
235235- read_huffman_code_with_bits alphabet_size Constants.huffman_max_table_bits br
236236-237237-(* Read block length *)
238238-let read_block_length table br =
239239- let code = Huffman.read_symbol table Constants.huffman_max_table_bits br in
240240- Prefix.decode_block_length br code
241241-242242-(* Translate distance short codes *)
243243-let translate_short_codes code dist_rb dist_rb_idx =
244244- if code < Constants.num_distance_short_codes then begin
245245- let index = (dist_rb_idx + distance_short_code_index_offset.(code)) land 3 in
246246- dist_rb.(index) + distance_short_code_value_offset.(code)
247247- end
248248- else
249249- code - Constants.num_distance_short_codes + 1
250250-251251-(* Inverse move-to-front transform *)
252252-let inverse_move_to_front_transform v v_len =
253253- let mtf = Array.init 256 (fun i -> i) in
254254- for i = 0 to v_len - 1 do
255255- let index = v.(i) in
256256- v.(i) <- mtf.(index);
257257- if index > 0 then begin
258258- let value = mtf.(index) in
259259- for j = index downto 1 do
260260- mtf.(j) <- mtf.(j - 1)
261261- done;
262262- mtf.(0) <- value
263263- end
264264- done
265265-266266-(* Decode context map *)
267267-let decode_context_map context_map_size br =
268268- let num_trees = decode_var_len_uint8 br + 1 in
269269- let context_map = Array.make context_map_size 0 in
270270-271271- if num_trees <= 1 then
272272- (num_trees, context_map)
273273- else begin
274274- let use_rle = Bit_reader.read_bits br 1 = 1 in
275275- let max_rle_prefix = if use_rle then Bit_reader.read_bits br 4 + 1 else 0 in
276276- let table = read_huffman_code (num_trees + max_rle_prefix) br in
277277-278278- let i = ref 0 in
279279- while !i < context_map_size do
280280- let code = Huffman.read_symbol table Constants.huffman_max_table_bits br in
281281- if code = 0 then begin
282282- context_map.(!i) <- 0;
283283- incr i
284284- end
285285- else if code <= max_rle_prefix then begin
286286- let reps = (1 lsl code) + Bit_reader.read_bits br code in
287287- for _ = 0 to reps - 1 do
288288- if !i >= context_map_size then
289289- raise (Brotli_error Invalid_context_map);
290290- context_map.(!i) <- 0;
291291- incr i
292292- done
293293- end
294294- else begin
295295- context_map.(!i) <- code - max_rle_prefix;
296296- incr i
297297- end
298298- done;
299299-300300- if Bit_reader.read_bits br 1 = 1 then
301301- inverse_move_to_front_transform context_map context_map_size;
302302-303303- (num_trees, context_map)
304304- end
305305-306306-(* Decode block type *)
307307-let decode_block_type max_block_type table block_type_rb block_type_rb_idx br =
308308- let type_code = Huffman.read_symbol table Constants.huffman_max_table_bits br in
309309- let block_type =
310310- if type_code = 0 then
311311- block_type_rb.((!block_type_rb_idx) land 1)
312312- else if type_code = 1 then
313313- block_type_rb.(((!block_type_rb_idx) - 1) land 1) + 1
314314- else
315315- type_code - 2
316316- in
317317- let block_type =
318318- if block_type >= max_block_type then block_type - max_block_type
319319- else block_type
320320- in
321321- block_type_rb.((!block_type_rb_idx) land 1) <- block_type;
322322- incr block_type_rb_idx;
323323- block_type
324324-325325-(* Main decompression function *)
326326-let decompress_into ~src ~src_pos ~src_len ~dst ~dst_pos =
327327- let br = Bit_reader.create ~src ~pos:src_pos ~len:src_len in
328328- let pos = ref dst_pos in
329329- let max_backward_distance = ref 0 in
330330-331331- (* Distance ring buffer *)
332332- let dist_rb = [| 16; 15; 11; 4 |] in
333333- let dist_rb_idx = ref 0 in
334334-335335- (* Decode window bits *)
336336- let window_bits = decode_window_bits br in
337337- max_backward_distance := (1 lsl window_bits) - Constants.window_gap;
338338-339339- let input_end = ref false in
340340-341341- while not !input_end do
342342- (* Decode meta-block header *)
343343- let header = decode_meta_block_length br in
344344- input_end := header.input_end;
345345-346346- if header.is_metadata then begin
347347- (* Skip metadata block *)
348348- Bit_reader.align_to_byte br;
349349- for _ = 1 to header.meta_block_length do
350350- ignore (Bit_reader.read_bits br 8)
351351- done
352352- end
353353- else if header.meta_block_length > 0 then begin
354354- if header.is_uncompressed then begin
355355- (* Uncompressed block *)
356356- Bit_reader.copy_bytes br ~dst ~dst_pos:!pos ~len:header.meta_block_length;
357357- pos := !pos + header.meta_block_length
358358- end
359359- else begin
360360- (* Compressed block *)
361361- let meta_block_remaining = ref header.meta_block_length in
362362-363363- (* Decode block type counts and trees *)
364364- let num_block_types = Array.make 3 1 in
365365- let block_type = Array.make 3 0 in
366366- let block_length = Array.make 3 (1 lsl 28) in
367367- let block_type_rb = [| [| 0; 1 |]; [| 0; 1 |]; [| 0; 1 |] |] in
368368- let block_type_rb_idx = [| ref 0; ref 0; ref 0 |] in
369369- let block_type_trees = Array.make 3 [||] in
370370- let block_len_trees = Array.make 3 [||] in
371371-372372- for i = 0 to 2 do
373373- num_block_types.(i) <- decode_var_len_uint8 br + 1;
374374- if num_block_types.(i) >= 2 then begin
375375- block_type_trees.(i) <- read_huffman_code (num_block_types.(i) + 2) br;
376376- block_len_trees.(i) <- read_huffman_code Constants.num_block_len_symbols br;
377377- block_length.(i) <- read_block_length block_len_trees.(i) br;
378378- block_type_rb_idx.(i) := 1
379379- end
380380- done;
381381-382382- (* Distance parameters *)
383383- let distance_postfix_bits = Bit_reader.read_bits br 2 in
384384- let num_direct_distance_codes =
385385- Constants.num_distance_short_codes + (Bit_reader.read_bits br 4 lsl distance_postfix_bits) in
386386- let distance_postfix_mask = (1 lsl distance_postfix_bits) - 1 in
387387- let num_distance_codes = num_direct_distance_codes + (48 lsl distance_postfix_bits) in
388388-389389- (* Context modes for literal blocks *)
390390- let context_modes = Array.make num_block_types.(0) 0 in
391391- for i = 0 to num_block_types.(0) - 1 do
392392- context_modes.(i) <- Bit_reader.read_bits br 2 lsl 1
393393- done;
394394-395395- (* Decode context maps *)
396396- let num_literal_trees, literal_context_map =
397397- decode_context_map (num_block_types.(0) lsl Constants.literal_context_bits) br in
398398- let num_dist_trees, dist_context_map =
399399- decode_context_map (num_block_types.(2) lsl Constants.distance_context_bits) br in
400400-401401- (* Decode Huffman tree groups *)
402402- let literal_trees = Array.init num_literal_trees (fun _ ->
403403- read_huffman_code Constants.num_literal_symbols br) in
404404- let command_trees = Array.init num_block_types.(1) (fun _ ->
405405- read_huffman_code_with_bits Constants.num_command_symbols
406406- Constants.huffman_max_command_table_bits br) in
407407- let distance_trees = Array.init num_dist_trees (fun _ ->
408408- read_huffman_code num_distance_codes br) in
409409-410410- (* Main decode loop *)
411411- let context_map_slice = ref 0 in
412412- let dist_context_map_slice = ref 0 in
413413- let context_mode = ref context_modes.(block_type.(0)) in
414414- let huff_tree_command = ref command_trees.(0) in
415415-416416- while !meta_block_remaining > 0 do
417417- (* Check/update command block *)
418418- if block_length.(1) = 0 then begin
419419- block_type.(1) <- decode_block_type num_block_types.(1)
420420- block_type_trees.(1) block_type_rb.(1) block_type_rb_idx.(1) br;
421421- block_length.(1) <- read_block_length block_len_trees.(1) br;
422422- huff_tree_command := command_trees.(block_type.(1))
423423- end;
424424- block_length.(1) <- block_length.(1) - 1;
425425-426426- (* Read command code *)
427427- let cmd_code = Huffman.read_symbol !huff_tree_command Constants.huffman_max_command_table_bits br in
428428- let range_idx = cmd_code lsr 6 in
429429- let distance_code = ref (if range_idx >= 2 then -1 else 0) in
430430- let range_idx = if range_idx >= 2 then range_idx - 2 else range_idx in
431431-432432- (* Decode insert and copy lengths *)
433433- let insert_code = Prefix.insert_range_lut.(range_idx) + ((cmd_code lsr 3) land 7) in
434434- let copy_code = Prefix.copy_range_lut.(range_idx) + (cmd_code land 7) in
435435- let insert_length = Prefix.decode_insert_length br insert_code in
436436- let copy_length = Prefix.decode_copy_length br copy_code in
437437-438438- (* Get context bytes *)
439439- let prev_byte1 = if !pos > dst_pos then Char.code (Bytes.get dst (!pos - 1)) else 0 in
440440- let prev_byte2 = if !pos > dst_pos + 1 then Char.code (Bytes.get dst (!pos - 2)) else 0 in
441441- let prev_byte1 = ref prev_byte1 in
442442- let prev_byte2 = ref prev_byte2 in
443443-444444- (* Insert literals *)
445445- for _ = 0 to insert_length - 1 do
446446- if block_length.(0) = 0 then begin
447447- block_type.(0) <- decode_block_type num_block_types.(0)
448448- block_type_trees.(0) block_type_rb.(0) block_type_rb_idx.(0) br;
449449- block_length.(0) <- read_block_length block_len_trees.(0) br;
450450- context_map_slice := block_type.(0) lsl Constants.literal_context_bits;
451451- context_mode := context_modes.(block_type.(0))
452452- end;
453453- let context = Context.get_context (Context.mode_of_int (!context_mode lsr 1))
454454- ~prev_byte1:!prev_byte1 ~prev_byte2:!prev_byte2 in
455455- let tree_idx = literal_context_map.(!context_map_slice + context) in
456456- block_length.(0) <- block_length.(0) - 1;
457457- prev_byte2 := !prev_byte1;
458458- let literal = Huffman.read_symbol literal_trees.(tree_idx) Constants.huffman_max_table_bits br in
459459- prev_byte1 := literal;
460460- if !pos >= Bytes.length dst then
461461- raise (Brotli_error Output_overrun);
462462- Bytes.set dst !pos (Char.chr literal);
463463- incr pos
464464- done;
465465-466466- meta_block_remaining := !meta_block_remaining - insert_length;
467467- if !meta_block_remaining <= 0 then
468468- () (* Break from loop *)
469469- else begin
470470- (* Decode distance if needed *)
471471- if !distance_code < 0 then begin
472472- if block_length.(2) = 0 then begin
473473- block_type.(2) <- decode_block_type num_block_types.(2)
474474- block_type_trees.(2) block_type_rb.(2) block_type_rb_idx.(2) br;
475475- block_length.(2) <- read_block_length block_len_trees.(2) br;
476476- dist_context_map_slice := block_type.(2) lsl Constants.distance_context_bits
477477- end;
478478- block_length.(2) <- block_length.(2) - 1;
479479- let context = Context.distance_context copy_length in
480480- let tree_idx = dist_context_map.(!dist_context_map_slice + context) in
481481- distance_code := Huffman.read_symbol distance_trees.(tree_idx) Constants.huffman_max_table_bits br;
482482-483483- if !distance_code >= num_direct_distance_codes then begin
484484- distance_code := !distance_code - num_direct_distance_codes;
485485- let postfix = !distance_code land distance_postfix_mask in
486486- distance_code := !distance_code lsr distance_postfix_bits;
487487- let nbits = (!distance_code lsr 1) + 1 in
488488- let offset = ((2 + (!distance_code land 1)) lsl nbits) - 4 in
489489- distance_code := num_direct_distance_codes +
490490- ((offset + Bit_reader.read_bits br nbits) lsl distance_postfix_bits) + postfix
491491- end
492492- end;
493493-494494- (* Convert distance code to actual distance *)
495495- let distance = translate_short_codes !distance_code dist_rb !dist_rb_idx in
496496- if distance < 0 then
497497- raise (Brotli_error Invalid_distance);
498498-499499- let max_distance = min !max_backward_distance (!pos - dst_pos) in
500500-501501- if distance > max_distance then begin
502502- (* Dictionary reference *)
503503- if copy_length >= Constants.min_dictionary_word_length &&
504504- copy_length <= Constants.max_dictionary_word_length then begin
505505- let word_id = distance - max_distance - 1 in
506506- let shift = Dictionary.size_bits_by_length.(copy_length) in
507507- let mask = (1 lsl shift) - 1 in
508508- let word_idx = word_id land mask in
509509- let transform_idx = word_id lsr shift in
510510- if transform_idx < Transform.num_transforms then begin
511511- if !pos + copy_length > Bytes.length dst then
512512- raise (Brotli_error Output_overrun);
513513- let length = Transform.transform_dictionary_word
514514- ~dst ~dst_pos:!pos ~word_index:word_idx
515515- ~word_length:copy_length ~transform_id:transform_idx in
516516- pos := !pos + length;
517517- meta_block_remaining := !meta_block_remaining - length
518518- end
519519- else
520520- raise (Brotli_error Invalid_backward_reference)
521521- end
522522- else
523523- raise (Brotli_error Invalid_backward_reference)
524524- end
525525- else begin
526526- (* Regular backward reference *)
527527- if !distance_code > 0 then begin
528528- dist_rb.(!dist_rb_idx land 3) <- distance;
529529- incr dist_rb_idx
530530- end;
531531-532532- if copy_length > !meta_block_remaining then
533533- raise (Brotli_error Invalid_backward_reference);
534534-535535- if !pos + copy_length > Bytes.length dst then
536536- raise (Brotli_error Output_overrun);
537537-538538- (* Optimized copy: use blit when distance >= copy_length *)
539539- if distance >= copy_length then begin
540540- Bytes.blit dst (!pos - distance) dst !pos copy_length;
541541- pos := !pos + copy_length;
542542- meta_block_remaining := !meta_block_remaining - copy_length
543543- end else begin
544544- (* Overlapping copy - must do byte by byte *)
545545- for _ = 0 to copy_length - 1 do
546546- Bytes.set dst !pos (Bytes.get dst (!pos - distance));
547547- incr pos;
548548- decr meta_block_remaining
549549- done
550550- end
551551- end
552552- end
553553- done
554554- end
555555- end
556556- done;
557557-558558- !pos - dst_pos
-1044
ocaml-brotli/src/brotli_encode.ml
···11-(* Brotli compression implementation *)
22-(* Supports quality levels 0-11 with context modeling, block splitting, and optimal parsing *)
33-44-(* Re-export from LZ77 for backward compatibility *)
55-let min_match = Lz77.min_match
66-77-(* Number of literal contexts *)
88-let num_literal_contexts = 64
99-1010-(* Insert length code tables *)
1111-let insert_length_n_bits = [|
1212- 0; 0; 0; 0; 0; 0; 1; 1; 2; 2; 3; 3; 4; 4; 5; 5; 6; 7; 8; 9; 10; 12; 14; 24
1313-|]
1414-1515-let insert_length_offset = [|
1616- 0; 1; 2; 3; 4; 5; 6; 8; 10; 14; 18; 26; 34; 50; 66; 98; 130; 194; 322; 578; 1090; 2114; 6210; 22594
1717-|]
1818-1919-(* Get insert length code *)
2020-let get_insert_code length =
2121- let rec find i =
2222- if i >= 23 then 23
2323- else if length < insert_length_offset.(i + 1) then i
2424- else find (i + 1)
2525- in
2626- find 0
2727-2828-(* Get copy length code *)
2929-let get_copy_code length =
3030- let copy_length_offset = [|
3131- 2; 3; 4; 5; 6; 7; 8; 9; 10; 12; 14; 18; 22; 30; 38; 54; 70; 102; 134; 198; 326; 582; 1094; 2118
3232- |] in
3333- let rec find i =
3434- if i >= 23 then 23
3535- else if length < copy_length_offset.(i + 1) then i
3636- else find (i + 1)
3737- in
3838- find 0
3939-4040-(* Command code lookup tables from RFC 7932 *)
4141-let insert_range_lut = [| 0; 0; 8; 8; 0; 16; 8; 16; 16 |]
4242-let copy_range_lut = [| 0; 8; 0; 8; 16; 0; 16; 8; 16 |]
4343-4444-(* Build command code from insert_code and copy_code.
4545- use_implicit_distance: true ONLY for distance code 0 (last distance)
4646-4747- Per RFC 7932, command codes have range_idx in bits 7-6:
4848- - range_idx 0-1 (cmd_code 0-127): Distance code 0 is IMPLICIT (not read from stream)
4949- The decoder automatically uses distance code 0 (last used distance).
5050- - range_idx 2-8 (cmd_code 128+): Distance code is EXPLICIT (read from stream)
5151- Short codes 0-15 and long codes >= 16 are all written explicitly.
5252-5353- IMPORTANT: Only dist_code=Some 0 can use implicit distance (range_idx 0-1).
5454- For all other short codes (1-15), we must use explicit distance (range_idx >= 2).
5555-*)
5656-let get_command_code insert_code copy_code use_implicit_distance =
5757- let found = ref None in
5858-5959- (* Only use range_idx 0-1 for implicit distance code 0 *)
6060- if use_implicit_distance then begin
6161- for r = 0 to 1 do
6262- if !found = None then begin
6363- let insert_base = insert_range_lut.(r) in
6464- let copy_base = copy_range_lut.(r) in
6565- let insert_delta = insert_code - insert_base in
6666- let copy_delta = copy_code - copy_base in
6767- if insert_delta >= 0 && insert_delta < 8 &&
6868- copy_delta >= 0 && copy_delta < 8 then begin
6969- let cmd_code = (r lsl 6) lor (insert_delta lsl 3) lor copy_delta in
7070- found := Some cmd_code
7171- end
7272- end
7373- done
7474- end;
7575-7676- (* Use range_idx 2-8 for explicit distance (including short codes 0-15) *)
7777- if !found = None then begin
7878- for r = 2 to 8 do
7979- if !found = None then begin
8080- let adjusted_r = r - 2 in
8181- let insert_base = insert_range_lut.(adjusted_r) in
8282- let copy_base = copy_range_lut.(adjusted_r) in
8383- let insert_delta = insert_code - insert_base in
8484- let copy_delta = copy_code - copy_base in
8585- if insert_delta >= 0 && insert_delta < 8 &&
8686- copy_delta >= 0 && copy_delta < 8 then begin
8787- let cmd_code = (r lsl 6) lor (insert_delta lsl 3) lor copy_delta in
8888- found := Some cmd_code
8989- end
9090- end
9191- done
9292- end;
9393-9494- match !found with
9595- | Some cmd_code -> cmd_code
9696- | None ->
9797- (* Fallback - shouldn't happen if LZ77 limits copy_len properly *)
9898- let insert_delta = min insert_code 7 in
9999- let copy_delta = min copy_code 7 in
100100- (2 lsl 6) lor (insert_delta lsl 3) lor copy_delta
101101-102102-(* Encode window bits *)
103103-let encode_window_bits bw =
104104- Bit_writer.write_bits bw 1 1;
105105- Bit_writer.write_bits bw 3 5 (* 22-bit window *)
106106-107107-(* Write empty last block *)
108108-let write_empty_last_block bw =
109109- Bit_writer.write_bits bw 1 1;
110110- Bit_writer.write_bits bw 1 1
111111-112112-(* Write meta-block header *)
113113-let write_meta_block_header bw length is_last is_uncompressed =
114114- Bit_writer.write_bits bw 1 (if is_last then 1 else 0);
115115- if is_last then
116116- Bit_writer.write_bits bw 1 0; (* ISEMPTY = 0 for non-empty last block *)
117117- let nibbles = if length - 1 < (1 lsl 16) then 4 else if length - 1 < (1 lsl 20) then 5 else 6 in
118118- Bit_writer.write_bits bw 2 (nibbles - 4);
119119- for i = 0 to nibbles - 1 do
120120- Bit_writer.write_bits bw 4 (((length - 1) lsr (i * 4)) land 0xF)
121121- done;
122122- if not is_last then
123123- Bit_writer.write_bits bw 1 (if is_uncompressed then 1 else 0)
124124-125125-(* Write uncompressed block *)
126126-let write_uncompressed_block bw src src_pos length =
127127- write_meta_block_header bw length false true;
128128- Bit_writer.align_to_byte bw;
129129- Bit_writer.copy_bytes bw ~src ~src_pos ~len:length
130130-131131-(* Count bits needed to represent values 0 to n-1 (ceiling of log2(n)) *)
132132-let count_bits n =
133133- if n <= 1 then 0
134134- else
135135- let rec count v b = if v = 0 then b else count (v lsr 1) (b + 1) in
136136- count (n - 1) 0
137137-138138-(* Write simple prefix code - 1 to 4 symbols *)
139139-let write_simple_prefix_code bw symbols alphabet_size =
140140- let n = Array.length symbols in
141141- Bit_writer.write_bits bw 2 1; (* HSKIP = 1 means simple code *)
142142- Bit_writer.write_bits bw 2 (n - 1); (* NSYM - 1 *)
143143- let bits = count_bits (alphabet_size - 1) in
144144- for i = 0 to n - 1 do
145145- Bit_writer.write_bits bw bits symbols.(i)
146146- done;
147147- if n = 4 then Bit_writer.write_bits bw 1 0
148148-149149-(* Static Huffman code for code lengths *)
150150-let write_code_length_symbol bw len =
151151- match len with
152152- | 0 -> Bit_writer.write_bits bw 2 0
153153- | 1 -> Bit_writer.write_bits bw 4 7
154154- | 2 -> Bit_writer.write_bits bw 3 3
155155- | 3 -> Bit_writer.write_bits bw 2 2
156156- | 4 -> Bit_writer.write_bits bw 2 1
157157- | 5 -> Bit_writer.write_bits bw 4 15
158158- | _ -> Bit_writer.write_bits bw 2 0
159159-160160-(* Build valid Huffman code lengths using Kraft inequality *)
161161-let build_valid_code_lengths freqs max_len =
162162- let n = Array.length freqs in
163163- let lengths = Array.make n 0 in
164164- let symbols = ref [] in
165165- for i = n - 1 downto 0 do
166166- if freqs.(i) > 0 then
167167- symbols := (freqs.(i), i) :: !symbols
168168- done;
169169- let num_symbols = List.length !symbols in
170170- if num_symbols = 0 then lengths
171171- else if num_symbols = 1 then begin
172172- let (_, sym) = List.hd !symbols in
173173- lengths.(sym) <- 1;
174174- lengths
175175- end
176176- else begin
177177- let sorted = List.sort (fun (f1, _) (f2, _) -> compare f2 f1) !symbols in
178178- let bits_needed = count_bits num_symbols in
179179- let base_len = min max_len (max bits_needed 1) in
180180- let len_to_use = ref base_len in
181181- while (1 lsl !len_to_use) < num_symbols && !len_to_use < max_len do
182182- incr len_to_use
183183- done;
184184- let slots_used = ref num_symbols in
185185- let total_slots = 1 lsl !len_to_use in
186186- List.iter (fun (_, sym) ->
187187- let extra_slots = total_slots - !slots_used in
188188- if extra_slots > 0 && !len_to_use > 1 then begin
189189- let shorter_len = !len_to_use - 1 in
190190- let extra_needed = (1 lsl (!len_to_use - shorter_len)) - 1 in
191191- if extra_slots >= extra_needed then begin
192192- lengths.(sym) <- shorter_len;
193193- slots_used := !slots_used + extra_needed
194194- end else
195195- lengths.(sym) <- !len_to_use
196196- end else
197197- lengths.(sym) <- !len_to_use
198198- ) sorted;
199199- lengths
200200- end
201201-202202-(* Build canonical Huffman codes from lengths *)
203203-let build_codes lengths =
204204- let n = Array.length lengths in
205205- let codes = Array.make n 0 in
206206- let max_len = Array.fold_left max 0 lengths in
207207- if max_len = 0 then codes
208208- else begin
209209- let bl_count = Array.make (max_len + 1) 0 in
210210- Array.iter (fun l -> if l > 0 then bl_count.(l) <- bl_count.(l) + 1) lengths;
211211- let next_code = Array.make (max_len + 1) 0 in
212212- let code = ref 0 in
213213- for bits = 1 to max_len do
214214- code := (!code + bl_count.(bits - 1)) lsl 1;
215215- next_code.(bits) <- !code
216216- done;
217217- for i = 0 to n - 1 do
218218- let len = lengths.(i) in
219219- if len > 0 then begin
220220- codes.(i) <- next_code.(len);
221221- next_code.(len) <- next_code.(len) + 1
222222- end
223223- done;
224224- codes
225225- end
226226-227227-(* Reverse bits for canonical Huffman *)
228228-let reverse_bits v n =
229229- let r = ref 0 in
230230- let v = ref v in
231231- for _ = 0 to n - 1 do
232232- r := (!r lsl 1) lor (!v land 1);
233233- v := !v lsr 1
234234- done;
235235- !r
236236-237237-(* Write a Huffman symbol *)
238238-let write_symbol bw codes lengths sym =
239239- let len = lengths.(sym) in
240240- if len > 0 then
241241- Bit_writer.write_bits bw len (reverse_bits codes.(sym) len)
242242-243243-(* RLE encoding for code lengths *)
244244-let emit_zeros_rle symbols_ref extras_ref total_ref run_len =
245245- if run_len < 3 then begin
246246- for _ = 1 to run_len do
247247- symbols_ref := 0 :: !symbols_ref;
248248- extras_ref := 0 :: !extras_ref;
249249- incr total_ref
250250- done
251251- end else begin
252252- let reps = ref (run_len - 3) in
253253- let rec build acc_codes acc_extras =
254254- let e = !reps land 7 in
255255- reps := !reps lsr 3;
256256- if !reps = 0 then
257257- (17 :: acc_codes, e :: acc_extras)
258258- else begin
259259- reps := !reps - 1;
260260- build (17 :: acc_codes) (e :: acc_extras)
261261- end
262262- in
263263- let (codes, extras) = build [] [] in
264264- List.iter2 (fun c e ->
265265- symbols_ref := c :: !symbols_ref;
266266- extras_ref := e :: !extras_ref
267267- ) codes extras;
268268- total_ref := !total_ref + run_len
269269- end
270270-271271-let emit_nonzero_rle symbols_ref extras_ref total_ref run_len prev_value_ref value =
272272- let to_write = ref run_len in
273273- if !prev_value_ref <> value then begin
274274- symbols_ref := value :: !symbols_ref;
275275- extras_ref := 0 :: !extras_ref;
276276- prev_value_ref := value;
277277- decr to_write;
278278- incr total_ref
279279- end;
280280- if !to_write < 3 then begin
281281- for _ = 1 to !to_write do
282282- symbols_ref := value :: !symbols_ref;
283283- extras_ref := 0 :: !extras_ref
284284- done;
285285- total_ref := !total_ref + !to_write
286286- end else begin
287287- let reps = ref (!to_write - 3) in
288288- let rec build acc_codes acc_extras =
289289- let e = !reps land 3 in
290290- reps := !reps lsr 2;
291291- if !reps = 0 then
292292- (16 :: acc_codes, e :: acc_extras)
293293- else begin
294294- reps := !reps - 1;
295295- build (16 :: acc_codes) (e :: acc_extras)
296296- end
297297- in
298298- let (codes, extras) = build [] [] in
299299- List.iter2 (fun c e ->
300300- symbols_ref := c :: !symbols_ref;
301301- extras_ref := e :: !extras_ref
302302- ) codes extras;
303303- total_ref := !total_ref + !to_write
304304- end
305305-306306-let generate_rle_sequence lengths num_symbols =
307307- let symbols = ref [] in
308308- let extras = ref [] in
309309- let prev_value = ref 8 in
310310- let total = ref 0 in
311311- let i = ref 0 in
312312- while !i < num_symbols do
313313- let value = if !i < Array.length lengths then lengths.(!i) else 0 in
314314- let run_start = !i in
315315- while !i < num_symbols &&
316316- (if !i < Array.length lengths then lengths.(!i) else 0) = value do
317317- incr i
318318- done;
319319- let run_len = !i - run_start in
320320- if value = 0 then
321321- emit_zeros_rle symbols extras total run_len
322322- else
323323- emit_nonzero_rle symbols extras total run_len prev_value value
324324- done;
325325- let syms = Array.of_list (List.rev !symbols) in
326326- let exts = Array.of_list (List.rev !extras) in
327327- (syms, exts)
328328-329329-(* Write complex prefix code with RLE encoding *)
330330-let write_complex_prefix_code bw lengths alphabet_size =
331331- let last_nonzero = ref (-1) in
332332- for i = 0 to min (alphabet_size - 1) (Array.length lengths - 1) do
333333- if lengths.(i) > 0 then last_nonzero := i
334334- done;
335335- let num_symbols = !last_nonzero + 1 in
336336- let (rle_symbols, rle_extra) = generate_rle_sequence lengths num_symbols in
337337- let cl_histogram = Array.make Constants.code_length_codes 0 in
338338- Array.iter (fun sym -> cl_histogram.(sym) <- cl_histogram.(sym) + 1) rle_symbols;
339339- let cl_depths = build_valid_code_lengths cl_histogram Constants.huffman_max_code_length_code_length in
340340- let num_codes = ref 0 in
341341- for i = 0 to Constants.code_length_codes - 1 do
342342- if cl_histogram.(i) > 0 then incr num_codes
343343- done;
344344- let skip_some =
345345- if cl_depths.(Constants.code_length_code_order.(0)) = 0 &&
346346- cl_depths.(Constants.code_length_code_order.(1)) = 0 then
347347- if cl_depths.(Constants.code_length_code_order.(2)) = 0 then 3
348348- else 2
349349- else 0
350350- in
351351- let codes_to_store = ref Constants.code_length_codes in
352352- if !num_codes > 1 then begin
353353- while !codes_to_store > 0 &&
354354- cl_depths.(Constants.code_length_code_order.(!codes_to_store - 1)) = 0 do
355355- decr codes_to_store
356356- done
357357- end;
358358- Bit_writer.write_bits bw 2 skip_some;
359359- let space = ref 32 in
360360- for i = skip_some to !codes_to_store - 1 do
361361- if !space > 0 then begin
362362- let idx = Constants.code_length_code_order.(i) in
363363- let l = cl_depths.(idx) in
364364- write_code_length_symbol bw l;
365365- if l <> 0 then
366366- space := !space - (32 lsr l)
367367- end
368368- done;
369369- let cl_codes = build_codes cl_depths in
370370- for i = 0 to Array.length rle_symbols - 1 do
371371- let sym = rle_symbols.(i) in
372372- if !num_codes > 1 then
373373- write_symbol bw cl_codes cl_depths sym;
374374- if sym = 16 then
375375- Bit_writer.write_bits bw 2 rle_extra.(i)
376376- else if sym = 17 then
377377- Bit_writer.write_bits bw 3 rle_extra.(i)
378378- done
379379-380380-(* Write Huffman code definition - choose simple or complex *)
381381-let write_huffman_code bw lengths alphabet_size =
382382- let symbols = ref [] in
383383- for i = 0 to min (alphabet_size - 1) (Array.length lengths - 1) do
384384- if i < Array.length lengths && lengths.(i) > 0 then
385385- symbols := (i, lengths.(i)) :: !symbols
386386- done;
387387- let sorted = List.sort (fun (s1, l1) (s2, l2) ->
388388- let c = compare l1 l2 in
389389- if c <> 0 then c else compare s1 s2
390390- ) !symbols in
391391- let symbols = Array.of_list (List.map fst sorted) in
392392- let num_symbols = Array.length symbols in
393393- if num_symbols = 0 then
394394- write_simple_prefix_code bw [|0|] alphabet_size
395395- else if num_symbols <= 4 then
396396- write_simple_prefix_code bw symbols alphabet_size
397397- else
398398- write_complex_prefix_code bw lengths alphabet_size
399399-400400-(* Count used symbols in frequency array *)
401401-let count_used_symbols freqs =
402402- let count = ref 0 in
403403- Array.iter (fun f -> if f > 0 then incr count) freqs;
404404- !count
405405-406406-(* Write context map using RLE and IMTF encoding *)
407407-(* Encode a variable length uint8 (matches decode_var_len_uint8 in decoder) *)
408408-let write_var_len_uint8 bw n =
409409- if n = 0 then
410410- Bit_writer.write_bits bw 1 0
411411- else if n = 1 then begin
412412- Bit_writer.write_bits bw 1 1;
413413- Bit_writer.write_bits bw 3 0 (* nbits = 0 means value 1 *)
414414- end else begin
415415- Bit_writer.write_bits bw 1 1;
416416- (* Find nbits such that (1 << nbits) <= n < (1 << (nbits + 1)) *)
417417- let rec find_nbits nb =
418418- if n < (1 lsl (nb + 1)) then nb
419419- else find_nbits (nb + 1)
420420- in
421421- let nbits = find_nbits 1 in
422422- Bit_writer.write_bits bw 3 nbits;
423423- Bit_writer.write_bits bw nbits (n - (1 lsl nbits))
424424- end
425425-426426-let write_context_map bw context_map num_trees =
427427- (* Write NTREES - 1 using variable length encoding *)
428428- write_var_len_uint8 bw (num_trees - 1);
429429-430430- if num_trees > 1 then begin
431431- (* Write RLEMAX flag: 0 = no RLE *)
432432- Bit_writer.write_bits bw 1 0;
433433-434434- (* With RLEMAX=0, alphabet size is just num_trees, symbols are values directly *)
435435- let map_len = Array.length context_map in
436436- let freq = Array.make num_trees 0 in
437437- for i = 0 to map_len - 1 do
438438- freq.(context_map.(i)) <- freq.(context_map.(i)) + 1
439439- done;
440440-441441- (* Build Huffman code for context map values *)
442442- let lengths = build_valid_code_lengths freq 15 in
443443- let codes = build_codes lengths in
444444-445445- (* Write the Huffman code for num_trees symbols *)
446446- write_huffman_code bw lengths num_trees;
447447-448448- (* Write the context map values *)
449449- let num_symbols = count_used_symbols freq in
450450- for i = 0 to map_len - 1 do
451451- if num_symbols > 1 then
452452- write_symbol bw codes lengths context_map.(i)
453453- done;
454454-455455- (* Write IMTF flag: 0 = no inverse move-to-front *)
456456- Bit_writer.write_bits bw 1 0
457457- end
458458-459459-(* Copy length extra bits table *)
460460-let copy_length_n_bits = [|
461461- 0; 0; 0; 0; 0; 0; 0; 0; 1; 1; 2; 2; 3; 3; 4; 4; 5; 5; 6; 7; 8; 9; 10; 24
462462-|]
463463-464464-let copy_length_offset = [|
465465- 2; 3; 4; 5; 6; 7; 8; 9; 10; 12; 14; 18; 22; 30; 38; 54; 70; 102; 134; 198; 326; 582; 1094; 2118
466466-|]
467467-468468-(* Encode distance for NPOSTFIX=0, NDIRECT=0 *)
469469-let encode_distance distance =
470470- if distance < 1 then
471471- (16, 1, 0)
472472- else begin
473473- let d = distance - 1 in
474474- let nbits = ref 1 in
475475- let range_start = ref 0 in
476476- while d >= !range_start + (1 lsl (!nbits + 1)) && !nbits < 24 do
477477- range_start := !range_start + (1 lsl (!nbits + 1));
478478- incr nbits
479479- done;
480480- let half_size = 1 lsl !nbits in
481481- let d_in_range = d - !range_start in
482482- let lcode = if d_in_range >= half_size then 1 else 0 in
483483- let dc = 2 * (!nbits - 1) + lcode in
484484- let code = 16 + dc in
485485- let extra = d_in_range - (lcode * half_size) in
486486- (code, !nbits, extra)
487487- end
488488-489489-(* Quality level for dictionary matching *)
490490-let current_quality = ref 1
491491-492492-(* Write a compressed block with context modeling for quality >= 5 *)
493493-let write_compressed_block_with_context bw src _src_pos _src_len is_last context_mode context_map num_lit_trees num_dist_trees dist_context_map commands =
494494- let num_distance_codes = 16 + 48 in
495495-496496- (* Count frequencies for context-aware literal encoding *)
497497- let lit_freqs = Array.init num_lit_trees (fun _ -> Array.make 256 0) in
498498- let cmd_freq = Array.make 704 0 in
499499- (* Distance frequencies per tree *)
500500- let dist_freqs = Array.init num_dist_trees (fun _ -> Array.make num_distance_codes 0) in
501501-502502- (* Track previous bytes for context calculation *)
503503- let prev1 = ref 0 in
504504- let prev2 = ref 0 in
505505-506506- (* Helper to get distance code value *)
507507- let get_dist_code_val dist_code distance =
508508- match dist_code with
509509- | Some code -> code
510510- | None ->
511511- let dist_code_val, _, _ = encode_distance distance in
512512- min dist_code_val (num_distance_codes - 1)
513513- in
514514-515515- (* Count literals with context and build command/distance frequencies *)
516516- List.iter (fun cmd ->
517517- match cmd with
518518- | Lz77.Literals { start; len } ->
519519- for i = start to start + len - 1 do
520520- let c = Char.code (Bytes.get src i) in
521521- let ctx_id = Context.get_context context_mode ~prev_byte1:!prev1 ~prev_byte2:!prev2 in
522522- let tree_id = context_map.(ctx_id) in
523523- lit_freqs.(tree_id).(c) <- lit_freqs.(tree_id).(c) + 1;
524524- prev2 := !prev1;
525525- prev1 := c
526526- done;
527527- let insert_code = get_insert_code len in
528528- let copy_code = 0 in
529529- let cmd_code = get_command_code insert_code copy_code false in
530530- cmd_freq.(cmd_code) <- cmd_freq.(cmd_code) + 1;
531531- (* Literals command with copy_code=0 has copy_len=2, so dist context = 0 *)
532532- let dist_tree = dist_context_map.(0) in
533533- dist_freqs.(dist_tree).(0) <- dist_freqs.(dist_tree).(0) + 1
534534- | Lz77.InsertCopy { lit_start; lit_len; copy_len; distance; dist_code } ->
535535- for i = lit_start to lit_start + lit_len - 1 do
536536- let c = Char.code (Bytes.get src i) in
537537- let ctx_id = Context.get_context context_mode ~prev_byte1:!prev1 ~prev_byte2:!prev2 in
538538- let tree_id = context_map.(ctx_id) in
539539- lit_freqs.(tree_id).(c) <- lit_freqs.(tree_id).(c) + 1;
540540- prev2 := !prev1;
541541- prev1 := c
542542- done;
543543- let insert_code = get_insert_code lit_len in
544544- let copy_code = get_copy_code copy_len in
545545- let use_implicit = dist_code = Some 0 in
546546- let cmd_code = get_command_code insert_code copy_code use_implicit in
547547- let range_idx = cmd_code lsr 6 in
548548- cmd_freq.(cmd_code) <- cmd_freq.(cmd_code) + 1;
549549- if range_idx >= 2 then begin
550550- let dist_ctx = Context.distance_context copy_len in
551551- let dist_tree = dist_context_map.(dist_ctx) in
552552- let code_val = get_dist_code_val dist_code distance in
553553- dist_freqs.(dist_tree).(code_val) <- dist_freqs.(dist_tree).(code_val) + 1
554554- end
555555- ) commands;
556556-557557- (* Build Huffman codes for each literal tree *)
558558- let lit_lengths_arr = Array.init num_lit_trees (fun i ->
559559- build_valid_code_lengths lit_freqs.(i) 15
560560- ) in
561561- let lit_codes_arr = Array.init num_lit_trees (fun i ->
562562- build_codes lit_lengths_arr.(i)
563563- ) in
564564- let cmd_lengths = build_valid_code_lengths cmd_freq 15 in
565565- let cmd_codes = build_codes cmd_lengths in
566566- (* Build Huffman codes for each distance tree *)
567567- let dist_lengths_arr = Array.init num_dist_trees (fun i ->
568568- build_valid_code_lengths dist_freqs.(i) 15
569569- ) in
570570- let dist_codes_arr = Array.init num_dist_trees (fun i ->
571571- build_codes dist_lengths_arr.(i)
572572- ) in
573573-574574- (* Calculate total uncompressed size *)
575575- let total_len = List.fold_left (fun acc cmd ->
576576- match cmd with
577577- | Lz77.Literals { len; _ } -> acc + len
578578- | Lz77.InsertCopy { lit_len; copy_len; _ } -> acc + lit_len + copy_len
579579- ) 0 commands in
580580-581581- (* Write meta-block header *)
582582- write_meta_block_header bw total_len is_last false;
583583-584584- (* Block type counts: 1 for each category *)
585585- Bit_writer.write_bits bw 1 0; (* NBLTYPESL = 1 *)
586586- Bit_writer.write_bits bw 1 0; (* NBLTYPESI = 1 *)
587587- Bit_writer.write_bits bw 1 0; (* NBLTYPESD = 1 *)
588588-589589- (* Distance parameters: NPOSTFIX=0, NDIRECT=0 *)
590590- Bit_writer.write_bits bw 2 0;
591591- Bit_writer.write_bits bw 4 0;
592592-593593- (* Context mode for literal block type 0 *)
594594- Bit_writer.write_bits bw 2 (Context.int_of_mode context_mode);
595595-596596- (* Literal context map *)
597597- write_context_map bw context_map num_lit_trees;
598598-599599- (* Distance context map: 4 contexts per block type *)
600600- write_context_map bw dist_context_map num_dist_trees;
601601-602602- (* Write Huffman codes for all literal trees *)
603603- for i = 0 to num_lit_trees - 1 do
604604- write_huffman_code bw lit_lengths_arr.(i) 256
605605- done;
606606- write_huffman_code bw cmd_lengths 704;
607607- (* Write Huffman codes for all distance trees *)
608608- for i = 0 to num_dist_trees - 1 do
609609- write_huffman_code bw dist_lengths_arr.(i) num_distance_codes
610610- done;
611611-612612- (* Write commands with context-aware literal and distance encoding *)
613613- let num_cmd_symbols = count_used_symbols cmd_freq in
614614- prev1 := 0;
615615- prev2 := 0;
616616-617617- List.iter (fun cmd ->
618618- match cmd with
619619- | Lz77.Literals { start; len } ->
620620- let insert_code = get_insert_code len in
621621- let copy_code = 0 in
622622- let cmd_code = get_command_code insert_code copy_code false in
623623- if num_cmd_symbols > 1 then
624624- write_symbol bw cmd_codes cmd_lengths cmd_code;
625625- if insert_length_n_bits.(insert_code) > 0 then begin
626626- let extra = len - insert_length_offset.(insert_code) in
627627- Bit_writer.write_bits bw insert_length_n_bits.(insert_code) extra
628628- end;
629629- for i = start to start + len - 1 do
630630- let c = Char.code (Bytes.get src i) in
631631- let ctx_id = Context.get_context context_mode ~prev_byte1:!prev1 ~prev_byte2:!prev2 in
632632- let tree_id = context_map.(ctx_id) in
633633- let num_symbols = count_used_symbols lit_freqs.(tree_id) in
634634- if num_symbols > 1 then
635635- write_symbol bw lit_codes_arr.(tree_id) lit_lengths_arr.(tree_id) c;
636636- prev2 := !prev1;
637637- prev1 := c
638638- done
639639-640640- | Lz77.InsertCopy { lit_start; lit_len; copy_len; distance; dist_code } ->
641641- let insert_code = get_insert_code lit_len in
642642- let copy_code = get_copy_code copy_len in
643643- let use_implicit = dist_code = Some 0 in
644644- let cmd_code = get_command_code insert_code copy_code use_implicit in
645645- let range_idx = cmd_code lsr 6 in
646646- if num_cmd_symbols > 1 then
647647- write_symbol bw cmd_codes cmd_lengths cmd_code;
648648- if insert_length_n_bits.(insert_code) > 0 then begin
649649- let extra = lit_len - insert_length_offset.(insert_code) in
650650- Bit_writer.write_bits bw insert_length_n_bits.(insert_code) extra
651651- end;
652652- if copy_length_n_bits.(copy_code) > 0 then begin
653653- let extra = copy_len - copy_length_offset.(copy_code) in
654654- Bit_writer.write_bits bw copy_length_n_bits.(copy_code) extra
655655- end;
656656- for i = lit_start to lit_start + lit_len - 1 do
657657- let c = Char.code (Bytes.get src i) in
658658- let ctx_id = Context.get_context context_mode ~prev_byte1:!prev1 ~prev_byte2:!prev2 in
659659- let tree_id = context_map.(ctx_id) in
660660- let num_symbols = count_used_symbols lit_freqs.(tree_id) in
661661- if num_symbols > 1 then
662662- write_symbol bw lit_codes_arr.(tree_id) lit_lengths_arr.(tree_id) c;
663663- prev2 := !prev1;
664664- prev1 := c
665665- done;
666666- if range_idx >= 2 then begin
667667- let dist_ctx = Context.distance_context copy_len in
668668- let dist_tree = dist_context_map.(dist_ctx) in
669669- let num_dist_symbols = count_used_symbols dist_freqs.(dist_tree) in
670670- match dist_code with
671671- | Some code ->
672672- if num_dist_symbols > 1 then
673673- write_symbol bw dist_codes_arr.(dist_tree) dist_lengths_arr.(dist_tree) code
674674- | None ->
675675- let dist_code_val, nbits, extra = encode_distance distance in
676676- if num_dist_symbols > 1 then
677677- write_symbol bw dist_codes_arr.(dist_tree) dist_lengths_arr.(dist_tree) dist_code_val;
678678- if nbits > 0 then
679679- Bit_writer.write_bits bw nbits extra
680680- end
681681- ) commands
682682-683683-(* Write a compressed block with LZ77 commands *)
684684-let write_compressed_block bw src src_pos src_len is_last =
685685- (* Dictionary matching provides additional compression for text content *)
686686- let use_dict = !current_quality >= 3 in
687687- let quality = !current_quality in
688688-689689- (* Generate commands using LZ77 or optimal parsing *)
690690- let commands =
691691- if quality >= 10 then
692692- (* Use optimal greedy parsing with lazy matching for quality 10-11 *)
693693- Optimal.generate_commands ~quality src src_pos src_len
694694- else
695695- (* Standard LZ77 for lower quality levels *)
696696- Lz77.generate_commands ~use_dict ~quality src src_pos src_len
697697- in
698698-699699- (* Use context modeling for quality >= 5 *)
700700- if quality >= 5 then begin
701701- let context_mode = Block_split.choose_context_mode src src_pos src_len in
702702- (* For quality >= 7 with enough data, use multiple literal trees *)
703703- let (context_map, num_lit_trees) =
704704- if quality >= 7 && src_len >= 1024 then begin
705705- let max_trees = if quality >= 9 then 4 else 2 in
706706- let (cmap, _histograms, ntrees) =
707707- Block_split.build_literal_context_map context_mode src src_pos src_len max_trees
708708- in
709709- (cmap, ntrees)
710710- end else
711711- (Array.make 64 0, 1)
712712- in
713713- (* Distance context map: 4 contexts based on copy_length *)
714714- (* For now, use single distance tree (infrastructure ready for multiple) *)
715715- let dist_context_map = Array.make 4 0 in
716716- let num_dist_trees = 1 in
717717- write_compressed_block_with_context bw src src_pos src_len is_last
718718- context_mode context_map num_lit_trees num_dist_trees dist_context_map commands
719719- end else begin
720720- (* Original simple encoding for quality < 5 *)
721721-722722- (* Count frequencies for all three alphabets *)
723723- let lit_freq = Array.make 256 0 in
724724- let cmd_freq = Array.make 704 0 in
725725- let num_distance_codes = 16 + 48 in
726726- let dist_freq = Array.make num_distance_codes 0 in
727727-728728- (* Count literals and build command/distance frequencies *)
729729- List.iter (fun cmd ->
730730- match cmd with
731731- | Lz77.Literals { start; len } ->
732732- for i = start to start + len - 1 do
733733- let c = Char.code (Bytes.get src i) in
734734- lit_freq.(c) <- lit_freq.(c) + 1
735735- done;
736736- let insert_code = get_insert_code len in
737737- let copy_code = 0 in
738738- let cmd_code = get_command_code insert_code copy_code false in
739739- cmd_freq.(cmd_code) <- cmd_freq.(cmd_code) + 1;
740740- (* range_idx for Literals command with copy_code=0 is >= 2, so we need distance *)
741741- dist_freq.(0) <- dist_freq.(0) + 1
742742- | Lz77.InsertCopy { lit_start; lit_len; copy_len; distance; dist_code } ->
743743- for i = lit_start to lit_start + lit_len - 1 do
744744- let c = Char.code (Bytes.get src i) in
745745- lit_freq.(c) <- lit_freq.(c) + 1
746746- done;
747747- let insert_code = get_insert_code lit_len in
748748- let copy_code = get_copy_code copy_len in
749749- (* Only dist_code=Some 0 can use implicit distance (range_idx 0-1) *)
750750- let use_implicit = dist_code = Some 0 in
751751- let cmd_code = get_command_code insert_code copy_code use_implicit in
752752- let range_idx = cmd_code lsr 6 in
753753- cmd_freq.(cmd_code) <- cmd_freq.(cmd_code) + 1;
754754- (* Count distance code if range_idx >= 2 (explicit distance) *)
755755- if range_idx >= 2 then begin
756756- match dist_code with
757757- | Some code -> dist_freq.(code) <- dist_freq.(code) + 1
758758- | None ->
759759- let dist_code_val, _, _ = encode_distance distance in
760760- if dist_code_val < num_distance_codes then
761761- dist_freq.(dist_code_val) <- dist_freq.(dist_code_val) + 1
762762- else
763763- dist_freq.(num_distance_codes - 1) <- dist_freq.(num_distance_codes - 1) + 1
764764- end
765765- (* For range_idx 0-1, distance code 0 is implicit, don't count *)
766766- ) commands;
767767-768768- (* Build Huffman codes *)
769769- let lit_lengths = build_valid_code_lengths lit_freq 15 in
770770- let lit_codes = build_codes lit_lengths in
771771- let cmd_lengths = build_valid_code_lengths cmd_freq 15 in
772772- let cmd_codes = build_codes cmd_lengths in
773773- let dist_lengths = build_valid_code_lengths dist_freq 15 in
774774- let dist_codes = build_codes dist_lengths in
775775-776776- (* Calculate total uncompressed size for meta-block header *)
777777- let total_len = List.fold_left (fun acc cmd ->
778778- match cmd with
779779- | Lz77.Literals { len; _ } -> acc + len
780780- | Lz77.InsertCopy { lit_len; copy_len; _ } -> acc + lit_len + copy_len
781781- ) 0 commands in
782782-783783- (* Write meta-block header *)
784784- write_meta_block_header bw total_len is_last false;
785785-786786- (* Block type counts: 1 for each category *)
787787- Bit_writer.write_bits bw 1 0;
788788- Bit_writer.write_bits bw 1 0;
789789- Bit_writer.write_bits bw 1 0;
790790-791791- (* Distance parameters: NPOSTFIX=0, NDIRECT=0 *)
792792- Bit_writer.write_bits bw 2 0;
793793- Bit_writer.write_bits bw 4 0;
794794-795795- (* Context mode for literal block type 0: LSB6 = 0 *)
796796- Bit_writer.write_bits bw 2 0;
797797-798798- (* Literal context map: NTREESL = 1 tree *)
799799- Bit_writer.write_bits bw 1 0;
800800-801801- (* Distance context map: NTREESD = 1 tree *)
802802- Bit_writer.write_bits bw 1 0;
803803-804804- (* Write Huffman codes *)
805805- write_huffman_code bw lit_lengths 256;
806806- write_huffman_code bw cmd_lengths 704;
807807- write_huffman_code bw dist_lengths num_distance_codes;
808808-809809- (* Write commands *)
810810- let num_lit_symbols = count_used_symbols lit_freq in
811811- let num_cmd_symbols = count_used_symbols cmd_freq in
812812- let num_dist_symbols = count_used_symbols dist_freq in
813813-814814- List.iter (fun cmd ->
815815- match cmd with
816816- | Lz77.Literals { start; len } ->
817817- let insert_code = get_insert_code len in
818818- let copy_code = 0 in
819819- let cmd_code = get_command_code insert_code copy_code false in
820820- if num_cmd_symbols > 1 then
821821- write_symbol bw cmd_codes cmd_lengths cmd_code;
822822- if insert_length_n_bits.(insert_code) > 0 then begin
823823- let extra = len - insert_length_offset.(insert_code) in
824824- Bit_writer.write_bits bw insert_length_n_bits.(insert_code) extra
825825- end;
826826- if num_lit_symbols > 1 then begin
827827- for i = start to start + len - 1 do
828828- let c = Char.code (Bytes.get src i) in
829829- write_symbol bw lit_codes lit_lengths c
830830- done
831831- end
832832-833833- | Lz77.InsertCopy { lit_start; lit_len; copy_len; distance; dist_code } ->
834834- let insert_code = get_insert_code lit_len in
835835- let copy_code = get_copy_code copy_len in
836836- (* Only dist_code=Some 0 can use implicit distance (range_idx 0-1) *)
837837- let use_implicit = dist_code = Some 0 in
838838- let cmd_code = get_command_code insert_code copy_code use_implicit in
839839- let range_idx = cmd_code lsr 6 in
840840- if num_cmd_symbols > 1 then
841841- write_symbol bw cmd_codes cmd_lengths cmd_code;
842842- if insert_length_n_bits.(insert_code) > 0 then begin
843843- let extra = lit_len - insert_length_offset.(insert_code) in
844844- Bit_writer.write_bits bw insert_length_n_bits.(insert_code) extra
845845- end;
846846- if copy_length_n_bits.(copy_code) > 0 then begin
847847- let extra = copy_len - copy_length_offset.(copy_code) in
848848- Bit_writer.write_bits bw copy_length_n_bits.(copy_code) extra
849849- end;
850850- if num_lit_symbols > 1 then begin
851851- for i = lit_start to lit_start + lit_len - 1 do
852852- let c = Char.code (Bytes.get src i) in
853853- write_symbol bw lit_codes lit_lengths c
854854- done
855855- end;
856856- (* Write distance code.
857857- For range_idx 0-1 (command codes 0-127), the decoder uses implicit distance code 0
858858- and does NOT read from the stream. For range_idx >= 2, we must write the distance code. *)
859859- if range_idx >= 2 then begin
860860- match dist_code with
861861- | Some code ->
862862- (* Short codes 0-15 - just write the code, no extra bits *)
863863- if num_dist_symbols > 1 then
864864- write_symbol bw dist_codes dist_lengths code
865865- | None ->
866866- let dist_code_val, nbits, extra = encode_distance distance in
867867- if num_dist_symbols > 1 then
868868- write_symbol bw dist_codes dist_lengths dist_code_val;
869869- if nbits > 0 then
870870- Bit_writer.write_bits bw nbits extra
871871- end
872872- (* For range_idx 0-1, distance code 0 is implicit, don't write anything *)
873873- ) commands
874874- end
875875-876876-(* Write a compressed block with only literals *)
877877-let write_literals_only_block bw src src_pos src_len is_last =
878878- write_meta_block_header bw src_len is_last false;
879879- Bit_writer.write_bits bw 1 0;
880880- Bit_writer.write_bits bw 1 0;
881881- Bit_writer.write_bits bw 1 0;
882882- Bit_writer.write_bits bw 2 0;
883883- Bit_writer.write_bits bw 4 0;
884884- Bit_writer.write_bits bw 2 0;
885885- Bit_writer.write_bits bw 1 0;
886886- Bit_writer.write_bits bw 1 0;
887887-888888- let lit_freq = Array.make 256 0 in
889889- for i = src_pos to src_pos + src_len - 1 do
890890- let c = Char.code (Bytes.get src i) in
891891- lit_freq.(c) <- lit_freq.(c) + 1
892892- done;
893893- let num_lit_symbols = count_used_symbols lit_freq in
894894- let lit_lengths = build_valid_code_lengths lit_freq 15 in
895895- let lit_codes = build_codes lit_lengths in
896896-897897- let insert_code = get_insert_code src_len in
898898- let copy_code = 0 in
899899- let cmd_code = get_command_code insert_code copy_code false in
900900- let cmd_freq = Array.make 704 0 in
901901- cmd_freq.(cmd_code) <- 1;
902902- let cmd_lengths = build_valid_code_lengths cmd_freq 15 in
903903-904904- let num_distance_codes = 16 + 48 in
905905- let dist_freq = Array.make num_distance_codes 0 in
906906- dist_freq.(0) <- 1;
907907- let dist_lengths = build_valid_code_lengths dist_freq 15 in
908908-909909- write_huffman_code bw lit_lengths 256;
910910- write_huffman_code bw cmd_lengths 704;
911911- write_huffman_code bw dist_lengths num_distance_codes;
912912-913913- if insert_length_n_bits.(insert_code) > 0 then begin
914914- let extra = src_len - insert_length_offset.(insert_code) in
915915- Bit_writer.write_bits bw insert_length_n_bits.(insert_code) extra
916916- end;
917917-918918- if num_lit_symbols > 1 then begin
919919- for i = src_pos to src_pos + src_len - 1 do
920920- let c = Char.code (Bytes.get src i) in
921921- write_symbol bw lit_codes lit_lengths c
922922- done
923923- end
924924-925925-(* Main compression function *)
926926-let compress_into ?(quality=1) ~src ~src_pos ~src_len ~dst ~dst_pos () =
927927- current_quality := quality;
928928- let bw = Bit_writer.create ~dst ~pos:dst_pos ~len:(Bytes.length dst - dst_pos) in
929929- encode_window_bits bw;
930930-931931- if src_len = 0 then begin
932932- write_empty_last_block bw;
933933- Bit_writer.flush bw - dst_pos
934934- end
935935- else if quality = 0 || src_len < 16 then begin
936936- write_uncompressed_block bw src src_pos src_len;
937937- write_empty_last_block bw;
938938- Bit_writer.flush bw - dst_pos
939939- end
940940- else begin
941941- try
942942- if quality >= 2 && src_len >= min_match then
943943- write_compressed_block bw src src_pos src_len true
944944- else
945945- write_literals_only_block bw src src_pos src_len true;
946946- Bit_writer.flush bw - dst_pos
947947- with _ ->
948948- let bw = Bit_writer.create ~dst ~pos:dst_pos ~len:(Bytes.length dst - dst_pos) in
949949- encode_window_bits bw;
950950- write_uncompressed_block bw src src_pos src_len;
951951- write_empty_last_block bw;
952952- Bit_writer.flush bw - dst_pos
953953- end
954954-955955-let max_compressed_length input_len =
956956- input_len + input_len / 8 + 64
957957-958958-(* Streaming encoder state *)
959959-type streaming_encoder = {
960960- mutable quality : int;
961961- mutable dst : bytes;
962962- mutable dst_pos : int;
963963- mutable header_written : bool;
964964- mutable finished : bool;
965965-}
966966-967967-let create_streaming_encoder ?(quality=1) ~dst ~dst_pos () =
968968- { quality; dst; dst_pos; header_written = false; finished = false }
969969-970970-(* Write a chunk of data to the streaming encoder *)
971971-let streaming_write encoder ~src ~src_pos ~src_len ~is_last =
972972- if encoder.finished then
973973- invalid_arg "streaming encoder already finished";
974974-975975- current_quality := encoder.quality;
976976- let bw = Bit_writer.create ~dst:encoder.dst ~pos:encoder.dst_pos
977977- ~len:(Bytes.length encoder.dst - encoder.dst_pos) in
978978-979979- (* Write header on first chunk *)
980980- if not encoder.header_written then begin
981981- encode_window_bits bw;
982982- encoder.header_written <- true
983983- end;
984984-985985- if src_len = 0 then begin
986986- if is_last then begin
987987- write_empty_last_block bw;
988988- encoder.finished <- true
989989- end
990990- end
991991- else if encoder.quality = 0 || src_len < 16 then begin
992992- (* For low quality or small blocks, write uncompressed *)
993993- if is_last then begin
994994- write_uncompressed_block bw src src_pos src_len;
995995- write_empty_last_block bw;
996996- encoder.finished <- true
997997- end else begin
998998- (* Non-last uncompressed block *)
999999- write_meta_block_header bw src_len false true;
10001000- Bit_writer.align_to_byte bw;
10011001- Bit_writer.copy_bytes bw ~src ~src_pos ~len:src_len
10021002- end
10031003- end
10041004- else begin
10051005- try
10061006- if encoder.quality >= 2 && src_len >= min_match then
10071007- write_compressed_block bw src src_pos src_len is_last
10081008- else
10091009- write_literals_only_block bw src src_pos src_len is_last;
10101010- if is_last then encoder.finished <- true
10111011- with _ ->
10121012- (* Fallback to uncompressed *)
10131013- if is_last then begin
10141014- write_uncompressed_block bw src src_pos src_len;
10151015- write_empty_last_block bw;
10161016- encoder.finished <- true
10171017- end else begin
10181018- write_meta_block_header bw src_len false true;
10191019- Bit_writer.align_to_byte bw;
10201020- Bit_writer.copy_bytes bw ~src ~src_pos ~len:src_len
10211021- end
10221022- end;
10231023-10241024- let written = Bit_writer.flush bw - encoder.dst_pos in
10251025- encoder.dst_pos <- encoder.dst_pos + written;
10261026- written
10271027-10281028-let streaming_finish encoder =
10291029- if not encoder.finished then begin
10301030- let result = streaming_write encoder ~src:(Bytes.create 0) ~src_pos:0 ~src_len:0 ~is_last:true in
10311031- encoder.finished <- true;
10321032- result
10331033- end else 0
10341034-10351035-let streaming_bytes_written encoder =
10361036- encoder.dst_pos
10371037-10381038-(* Re-export command type for Debug module *)
10391039-type command = Lz77.command =
10401040- | InsertCopy of { lit_start: int; lit_len: int; copy_len: int; distance: int; dist_code: int option }
10411041- | Literals of { start: int; len: int }
10421042-10431043-let generate_commands src src_pos src_len =
10441044- Lz77.generate_commands src src_pos src_len
-112
ocaml-brotli/src/constants.ml
···11-(* Brotli format constants from RFC 7932 *)
22-33-(* Specification: 2. Compressed representation overview *)
44-let max_number_of_block_types = 256
55-66-(* Specification: 3.3. Alphabet sizes *)
77-let num_literal_symbols = 256
88-let num_command_symbols = 704
99-let num_block_len_symbols = 26
1010-let num_ins_copy_codes = 24
1111-1212-(* Specification: 3.5. Complex prefix codes *)
1313-let repeat_previous_code_length = 16
1414-let repeat_zero_code_length = 17
1515-let code_length_codes = 18 (* repeat_zero_code_length + 1 *)
1616-let initial_repeated_code_length = 8
1717-1818-(* Specification: 7.3. Encoding of the context map *)
1919-let context_map_max_rle = 16
2020-let max_context_map_symbols = max_number_of_block_types + context_map_max_rle
2121-let max_block_type_symbols = max_number_of_block_types + 2
2222-2323-(* Specification: 7.1. Context modes and context ID lookup for literals *)
2424-let literal_context_bits = 6
2525-let num_literal_contexts = 1 lsl literal_context_bits (* 64 *)
2626-2727-(* Specification: 7.2. Context ID for distances *)
2828-let distance_context_bits = 2
2929-let num_distance_contexts = 1 lsl distance_context_bits (* 4 *)
3030-3131-(* Specification: 4. Encoding of distances *)
3232-let num_distance_short_codes = 16
3333-let max_npostfix = 3
3434-let max_ndirect = 120
3535-let max_distance_bits = 24
3636-3737-(* Large window brotli *)
3838-let large_max_distance_bits = 62
3939-let large_min_wbits = 10
4040-let large_max_wbits = 30
4141-4242-(* Calculate distance alphabet size *)
4343-let distance_alphabet_size ~npostfix ~ndirect ~max_nbits =
4444- num_distance_short_codes + ndirect + (max_nbits lsl (npostfix + 1))
4545-4646-(* Standard distance alphabet size *)
4747-let num_distance_symbols =
4848- distance_alphabet_size ~npostfix:max_npostfix ~ndirect:max_ndirect
4949- ~max_nbits:large_max_distance_bits
5050-5151-(* Maximum expressible distance with NPOSTFIX=0, NDIRECT=0 *)
5252-let max_distance = 0x3FFFFFC (* (1 lsl 26) - 4 *)
5353-5454-(* Specification: 9.1. Format of the Stream Header *)
5555-let window_gap = 16
5656-let min_window_bits = 10
5757-let max_window_bits = 24
5858-5959-let max_backward_limit wbits = (1 lsl wbits) - window_gap
6060-6161-(* Huffman coding constants *)
6262-let huffman_max_code_length = 15
6363-let huffman_max_code_length_code_length = 5
6464-let huffman_max_table_bits = 8 (* Root table size for literals *)
6565-let huffman_max_command_table_bits = 10 (* Root table size for commands *)
6666-6767-(* Code length code order (RFC 7932 section 3.5) *)
6868-let code_length_code_order = [|
6969- 1; 2; 3; 4; 0; 5; 17; 6; 16; 7; 8; 9; 10; 11; 12; 13; 14; 15
7070-|]
7171-7272-(* Minimum dictionary word length *)
7373-let min_dictionary_word_length = 4
7474-let max_dictionary_word_length = 24
7575-7676-(* Number of transforms *)
7777-let num_transforms = 121
7878-7979-(* ============================================================
8080- Shared utility functions
8181- ============================================================ *)
8282-8383-(* Hash multiplier for 4-byte hash functions (from brotli-c) *)
8484-let hash_multiplier = 0x1e35a7bd
8585-8686-(* Fast log2 approximation matching brotli-c FastLog2.
8787- Returns floor(log2(v)) as a float, or 0.0 for v <= 0. *)
8888-let[@inline always] fast_log2 v =
8989- if v <= 0 then 0.0
9090- else
9191- let rec log2_floor v acc = if v <= 1 then acc else log2_floor (v lsr 1) (acc + 1) in
9292- float_of_int (log2_floor v 0)
9393-9494-(* Hash a 4-byte sequence from a bytes buffer.
9595- Returns a hash value with the specified number of bits. *)
9696-let[@inline always] hash4_bytes src pos bits =
9797- let b0 = Char.code (Bytes.unsafe_get src pos) in
9898- let b1 = Char.code (Bytes.unsafe_get src (pos + 1)) in
9999- let b2 = Char.code (Bytes.unsafe_get src (pos + 2)) in
100100- let b3 = Char.code (Bytes.unsafe_get src (pos + 3)) in
101101- let v = b0 lor (b1 lsl 8) lor (b2 lsl 16) lor (b3 lsl 24) in
102102- ((v * hash_multiplier) land 0xFFFFFFFF) lsr (32 - bits)
103103-104104-(* Hash a 4-byte sequence from a string.
105105- Returns a hash value with the specified number of bits. *)
106106-let[@inline always] hash4_string s pos bits =
107107- let b0 = Char.code (String.unsafe_get s pos) in
108108- let b1 = Char.code (String.unsafe_get s (pos + 1)) in
109109- let b2 = Char.code (String.unsafe_get s (pos + 2)) in
110110- let b3 = Char.code (String.unsafe_get s (pos + 3)) in
111111- let v = b0 lor (b1 lsl 8) lor (b2 lsl 16) lor (b3 lsl 24) in
112112- ((v * hash_multiplier) land 0xFFFFFFFF) lsr (32 - bits)
···11-(* Dictionary matching for Brotli encoder *)
22-33-(* Hash table configuration *)
44-let hash_bits = 17
55-let hash_size = 1 lsl hash_bits (* 128K entries *)
66-77-(* Dictionary hash table entry: (word_length, word_index) list *)
88-type dict_entry = (int * int) list
99-1010-(* Build the dictionary hash table lazily *)
1111-let dict_hash_table : dict_entry array Lazy.t = lazy (
1212- let table = Array.make hash_size [] in
1313- (* Index all dictionary words by their first 4 bytes *)
1414- for length = Dictionary.min_word_length to Dictionary.max_word_length do
1515- let num_words = 1 lsl Dictionary.size_bits_by_length.(length) in
1616- for word_idx = 0 to num_words - 1 do
1717- let offset = Dictionary.offset_by_length.(length) + word_idx * length in
1818- if offset + 4 <= String.length Dictionary.data then begin
1919- let h = Constants.hash4_string Dictionary.data offset hash_bits in
2020- table.(h) <- (length, word_idx) :: table.(h)
2121- end
2222- done
2323- done;
2424- table
2525-)
2626-2727-(* Check if two byte sequences match *)
2828-let[@inline] bytes_match src src_pos word word_pos len =
2929- let rec loop i =
3030- if i >= len then true
3131- else if Bytes.get src (src_pos + i) <> word.[word_pos + i] then false
3232- else loop (i + 1)
3333- in
3434- loop 0
3535-3636-(* Transform ID 0: Identity - no transformation *)
3737-(* Transform ID 9: UppercaseFirst - uppercase first letter *)
3838-(* Transform ID 44: UppercaseAll - uppercase all letters *)
3939-4040-(* Check if input matches word with identity transform (ID 0) *)
4141-let match_identity src pos src_end word_length word_idx =
4242- if pos + word_length > src_end then None
4343- else begin
4444- let offset = Dictionary.offset_by_length.(word_length) + word_idx * word_length in
4545- if bytes_match src pos Dictionary.data offset word_length then
4646- Some (word_length, 0) (* length, transform_id *)
4747- else
4848- None
4949- end
5050-5151-(* Lowercase a character if uppercase *)
5252-let[@inline] to_lower c =
5353- if c >= 'A' && c <= 'Z' then Char.chr (Char.code c lor 32)
5454- else c
5555-5656-(* Check if input matches word with uppercase-first transform (ID 9) *)
5757-let match_uppercase_first src pos src_end word_length word_idx =
5858- if pos + word_length > src_end || word_length < 1 then None
5959- else begin
6060- let offset = Dictionary.offset_by_length.(word_length) + word_idx * word_length in
6161- (* First byte should be uppercase version of dictionary's first byte *)
6262- let dict_first = Dictionary.data.[offset] in
6363- let src_first = Bytes.get src pos in
6464- if src_first >= 'A' && src_first <= 'Z' && to_lower src_first = dict_first then begin
6565- (* Rest should match exactly *)
6666- if word_length = 1 || bytes_match src (pos + 1) Dictionary.data (offset + 1) (word_length - 1) then
6767- Some (word_length, 9) (* length, transform_id *)
6868- else
6969- None
7070- end
7171- else
7272- None
7373- end
7474-7575-(* Try to find a dictionary match at the given position.
7676- current_output_pos is the current position in the output buffer (for distance calculation).
7777- The decoder uses min(max_backward_distance, output_pos) as the base for dictionary references. *)
7878-let find_match src pos src_end max_backward_distance ~current_output_pos =
7979- if pos + 4 > src_end then None
8080- else begin
8181- let table = Lazy.force dict_hash_table in
8282- let h = Constants.hash4_bytes src pos hash_bits in
8383- let candidates = table.(h) in
8484-8585- let best = ref None in
8686- let best_score = ref 0 in
8787-8888- List.iter (fun (word_length, word_idx) ->
8989- (* Try identity transform first (most common) *)
9090- (match match_identity src pos src_end word_length word_idx with
9191- | Some (len, transform_id) ->
9292- (* Score: longer matches are better, identity transform is preferred *)
9393- let score = len * 10 in
9494- if score > !best_score then begin
9595- best := Some (len, word_idx, transform_id);
9696- best_score := score
9797- end
9898- | None -> ());
9999-100100- (* Try uppercase-first transform for capitalized words *)
101101- if word_length >= 1 then
102102- (match match_uppercase_first src pos src_end word_length word_idx with
103103- | Some (len, transform_id) ->
104104- let score = len * 10 - 1 in (* Slight penalty for transform *)
105105- if score > !best_score then begin
106106- best := Some (len, word_idx, transform_id);
107107- best_score := score
108108- end
109109- | None -> ())
110110- ) candidates;
111111-112112- match !best with
113113- | None -> None
114114- | Some (match_len, word_idx, transform_id) ->
115115- (* Calculate the dictionary distance code.
116116- The decoder uses: word_id = distance - max_distance - 1
117117- where max_distance = min(max_backward_distance, output_pos)
118118- So we must use the same formula in reverse. *)
119119- let max_distance = min max_backward_distance current_output_pos in
120120- let shift = Dictionary.size_bits_by_length.(match_len) in
121121- let word_id = word_idx lor (transform_id lsl shift) in
122122- let distance = max_distance + 1 + word_id in
123123- Some (match_len, distance)
124124- end
125125-126126-(* Score a dictionary match for comparison with LZ77 matches *)
127127-let score_dict_match match_len =
128128- (* Dictionary matches save literals but have longer distance encoding *)
129129- (* Give them a bonus since they're "free" (no backward reference needed) *)
130130- match_len * 140 (* Slightly higher than LZ77's base score of 135 *)
···11-(* Canonical Huffman coding with 2-level lookup tables for Brotli *)
22-33-let max_length = 15
44-55-(* A Huffman code entry in the lookup table *)
66-type code = {
77- bits : int; (* Number of bits used for this symbol, or bits in subtable *)
88- value : int; (* Symbol value, or offset to subtable *)
99-}
1010-1111-(* A Huffman lookup table - flat array with 2-level structure *)
1212-type table = code array
1313-1414-exception Invalid_huffman_tree
1515-1616-(* Returns reverse(reverse(key, len) + 1, len) for canonical code generation *)
1717-let get_next_key key length =
1818- let rec loop step =
1919- if key land step = 0 then
2020- (key land (step - 1)) + step
2121- else
2222- loop (step lsr 1)
2323- in
2424- loop (1 lsl (length - 1))
2525-2626-(* Store code in table[i], table[i+step], table[i+2*step], ... *)
2727-let replicate_value table base step table_end code =
2828- let rec loop index =
2929- if index >= base then begin
3030- table.(index) <- code;
3131- loop (index - step)
3232- end
3333- in
3434- loop (base + table_end - step)
3535-3636-(* Calculate the width of the next 2nd level table *)
3737-let next_table_bit_size count length root_bits =
3838- let left = ref (1 lsl (length - root_bits)) in
3939- let len = ref length in
4040- while !len < max_length do
4141- left := !left - count.(!len);
4242- if !left <= 0 then
4343- len := max_length (* Break *)
4444- else begin
4545- incr len;
4646- left := !left lsl 1
4747- end
4848- done;
4949- !len - root_bits
5050-5151-(* Build a Huffman lookup table from code lengths *)
5252-let build_table ~code_lengths ~alphabet_size ~root_bits =
5353- let count = Array.make (max_length + 1) 0 in
5454- let offset = Array.make (max_length + 1) 0 in
5555- let sorted_symbols = Array.make alphabet_size 0 in
5656-5757- (* Build histogram of code lengths *)
5858- for symbol = 0 to alphabet_size - 1 do
5959- let len = code_lengths.(symbol) in
6060- count.(len) <- count.(len) + 1
6161- done;
6262-6363- (* Generate offsets into sorted symbol table by code length *)
6464- offset.(1) <- 0;
6565- for length = 1 to max_length - 1 do
6666- offset.(length + 1) <- offset.(length) + count.(length)
6767- done;
6868-6969- (* Sort symbols by length, by symbol order within each length *)
7070- for symbol = 0 to alphabet_size - 1 do
7171- let length = code_lengths.(symbol) in
7272- if length <> 0 then begin
7373- sorted_symbols.(offset.(length)) <- symbol;
7474- offset.(length) <- offset.(length) + 1
7575- end
7676- done;
7777-7878- let table_bits = ref root_bits in
7979- let table_size = ref (1 lsl !table_bits) in
8080- let total_size = ref !table_size in
8181-8282- (* Pre-allocate table with maximum possible size *)
8383- let max_table_size = !table_size * 4 in (* Conservative estimate *)
8484- let root_table = Array.make max_table_size { bits = 0; value = 0 } in
8585-8686- (* Special case: code with only one value *)
8787- if offset.(max_length) = 1 then begin
8888- for key = 0 to !total_size - 1 do
8989- root_table.(key) <- { bits = 0; value = sorted_symbols.(0) land 0xFFFF }
9090- done;
9191- Array.sub root_table 0 !total_size
9292- end
9393- else begin
9494- let table = ref 0 in
9595- let key = ref 0 in
9696- let symbol = ref 0 in
9797- let step = ref 2 in
9898-9999- (* Fill in root table *)
100100- for length = 1 to root_bits do
101101- while count.(length) > 0 do
102102- let code = { bits = length land 0xFF; value = sorted_symbols.(!symbol) land 0xFFFF } in
103103- incr symbol;
104104- replicate_value root_table (!table + !key) !step !table_size code;
105105- key := get_next_key !key length;
106106- count.(length) <- count.(length) - 1
107107- done;
108108- step := !step lsl 1
109109- done;
110110-111111- (* Fill in 2nd level tables and add pointers to root table *)
112112- let mask = !total_size - 1 in
113113- let low = ref (-1) in
114114- step := 2;
115115- let start_table = 0 in
116116-117117- for length = root_bits + 1 to max_length do
118118- while count.(length) > 0 do
119119- if (!key land mask) <> !low then begin
120120- table := !table + !table_size;
121121- table_bits := next_table_bit_size count length root_bits;
122122- table_size := 1 lsl !table_bits;
123123- total_size := !total_size + !table_size;
124124- low := !key land mask;
125125- root_table.(start_table + !low) <- {
126126- bits = (!table_bits + root_bits) land 0xFF;
127127- value = (!table - start_table - !low) land 0xFFFF
128128- }
129129- end;
130130- let code = { bits = (length - root_bits) land 0xFF; value = sorted_symbols.(!symbol) land 0xFFFF } in
131131- incr symbol;
132132- replicate_value root_table (!table + (!key lsr root_bits)) !step !table_size code;
133133- key := get_next_key !key length;
134134- count.(length) <- count.(length) - 1
135135- done;
136136- step := !step lsl 1
137137- done;
138138-139139- Array.sub root_table 0 !total_size
140140- end
141141-142142-(* Read a symbol from the bit stream using the Huffman table *)
143143-let[@inline] read_symbol table root_bits br =
144144- let bits = Bit_reader.peek_bits br 15 in
145145- let initial_idx = bits land ((1 lsl root_bits) - 1) in
146146- let entry = table.(initial_idx) in
147147- if entry.bits <= root_bits then begin
148148- (* Symbol found in root table *)
149149- Bit_reader.skip_bits br entry.bits;
150150- entry.value
151151- end
152152- else begin
153153- (* Need to look in 2nd level table *)
154154- Bit_reader.skip_bits br root_bits;
155155- let extra_bits = entry.bits - root_bits in
156156- let idx2 = (bits lsr root_bits) land ((1 lsl extra_bits) - 1) in
157157- let entry2 = table.(initial_idx + entry.value + idx2) in
158158- Bit_reader.skip_bits br entry2.bits;
159159- entry2.value
160160- end
161161-162162-(* Build Huffman table for simple prefix codes (1-4 symbols) *)
163163-let build_simple_table symbols num_symbols =
164164- let table_size = 1 lsl Constants.huffman_max_table_bits in
165165- let table = Array.make table_size { bits = 0; value = 0 } in
166166-167167- match num_symbols with
168168- | 1 ->
169169- (* Single symbol - use 0 bits *)
170170- for i = 0 to table_size - 1 do
171171- table.(i) <- { bits = 0; value = symbols.(0) }
172172- done;
173173- table
174174- | 2 ->
175175- (* Two symbols - 1 bit each *)
176176- let half = table_size / 2 in
177177- for i = 0 to half - 1 do
178178- table.(i) <- { bits = 1; value = symbols.(0) }
179179- done;
180180- for i = half to table_size - 1 do
181181- table.(i) <- { bits = 1; value = symbols.(1) }
182182- done;
183183- table
184184- | 3 ->
185185- (* Three symbols: 1, 2, 2 bits *)
186186- let quarter = table_size / 4 in
187187- for i = 0 to quarter - 1 do
188188- table.(i) <- { bits = 1; value = symbols.(0) }
189189- done;
190190- for i = quarter to 2 * quarter - 1 do
191191- table.(i) <- { bits = 2; value = symbols.(1) }
192192- done;
193193- for i = 2 * quarter to table_size - 1 do
194194- table.(i) <- { bits = 2; value = symbols.(2) }
195195- done;
196196- table
197197- | 4 ->
198198- (* Four symbols: 2 bits each, with tree-select bit *)
199199- let quarter = table_size / 4 in
200200- for i = 0 to quarter - 1 do
201201- table.(i) <- { bits = 2; value = symbols.(0) }
202202- done;
203203- for i = quarter to 2 * quarter - 1 do
204204- table.(i) <- { bits = 2; value = symbols.(1) }
205205- done;
206206- for i = 2 * quarter to 3 * quarter - 1 do
207207- table.(i) <- { bits = 2; value = symbols.(2) }
208208- done;
209209- for i = 3 * quarter to table_size - 1 do
210210- table.(i) <- { bits = 2; value = symbols.(3) }
211211- done;
212212- table
213213- | _ ->
214214- raise Invalid_huffman_tree
215215-216216-(* Maximum table sizes for different alphabet sizes *)
217217-let max_table_sizes = [|
218218- 256; 402; 436; 468; 500; 534; 566; 598;
219219- 630; 662; 694; 726; 758; 790; 822; 854;
220220- 886; 918; 950; 982; 1014; 1046; 1078; 1080
221221-|]
222222-223223-(* Get maximum table size for a given alphabet size *)
224224-let max_table_size alphabet_size =
225225- if alphabet_size <= 256 then 256
226226- else if alphabet_size <= 704 then 1080
227227- else 2048 (* Large alphabets *)
-544
ocaml-brotli/src/lz77.ml
···11-(* LZ77 matching with distance ring buffer support for Brotli *)
22-(* Implements scoring and parameters matching brotli-c reference *)
33-44-(* Configuration *)
55-let hash_bits = 17
66-let hash_size = 1 lsl hash_bits
77-let min_match = 4
88-let max_match = 258
99-let window_bits = 22
1010-let max_backward_distance = (1 lsl window_bits) - 16
1111-1212-(* Scoring constants from brotli-c (hash.h) *)
1313-let brotli_literal_byte_score = 135
1414-let brotli_distance_bit_penalty = 30
1515-(* BROTLI_SCORE_BASE = DISTANCE_BIT_PENALTY * 8 * sizeof(size_t) = 1920 on 64-bit *)
1616-let brotli_score_base = brotli_distance_bit_penalty * 8 * 8
1717-1818-(* Block size (ring buffer size per bucket) by quality for H5 hasher.
1919- In brotli-c: block_bits = quality - 1 for q5-9 *)
2020-let get_block_size quality =
2121- if quality <= 4 then 1
2222- else if quality = 5 then 16 (* 1 << 4 *)
2323- else if quality = 6 then 32 (* 1 << 5 *)
2424- else if quality = 7 then 64 (* 1 << 6 *)
2525- else if quality = 8 then 128 (* 1 << 7 *)
2626- else 256 (* 1 << 8 for q9+ *)
2727-2828-(* num_last_distances_to_check by quality from brotli-c *)
2929-let get_num_last_distances_to_check quality =
3030- if quality < 7 then 4
3131- else if quality < 9 then 10
3232- else 16
3333-3434-(* Bucket sweep (number of hash slots to check) for lower qualities *)
3535-let get_bucket_sweep quality =
3636- if quality = 2 then 1 (* H2: sweep = 0, single slot *)
3737- else if quality = 3 then 2 (* H3: sweep = 1, 2 slots *)
3838- else if quality = 4 then 4 (* H4: sweep = 2, 4 slots *)
3939- else 1
4040-4141-4242-(* Distance ring buffer for short distance codes *)
4343-type dist_ring = {
4444- mutable distances : int array; (* Last 4 distances *)
4545- mutable idx : int; (* Current index *)
4646-}
4747-4848-let create_dist_ring () = {
4949- distances = [| 16; 15; 11; 4 |]; (* Initial values per RFC 7932 *)
5050- idx = 0;
5151-}
5252-5353-let push_distance ring dist =
5454- ring.distances.(ring.idx land 3) <- dist;
5555- ring.idx <- ring.idx + 1
5656-5757-let get_last_distance ring n =
5858- (* n=0: last, n=1: second-to-last, etc. *)
5959- ring.distances.((ring.idx - 1 - n) land 3)
6060-6161-(* Short distance codes (0-15) per RFC 7932:
6262- 0: last distance
6363- 1: second-to-last
6464- 2: third-to-last
6565- 3: fourth-to-last
6666- 4: last - 1
6767- 5: last + 1
6868- 6: last - 2
6969- 7: last + 2
7070- 8: last - 3
7171- 9: last + 3
7272- 10: second-to-last - 1
7373- 11: second-to-last + 1
7474- 12: second-to-last - 2
7575- 13: second-to-last + 2
7676- 14: second-to-last - 3
7777- 15: second-to-last + 3
7878-*)
7979-let short_code_distances ring =
8080- let last = get_last_distance ring 0 in
8181- let second = get_last_distance ring 1 in
8282- [|
8383- get_last_distance ring 0; (* 0 *)
8484- get_last_distance ring 1; (* 1 *)
8585- get_last_distance ring 2; (* 2 *)
8686- get_last_distance ring 3; (* 3 *)
8787- last - 1; (* 4 *)
8888- last + 1; (* 5 *)
8989- last - 2; (* 6 *)
9090- last + 2; (* 7 *)
9191- last - 3; (* 8 *)
9292- last + 3; (* 9 *)
9393- second - 1; (* 10 *)
9494- second + 1; (* 11 *)
9595- second - 2; (* 12 *)
9696- second + 2; (* 13 *)
9797- second - 3; (* 14 *)
9898- second + 3; (* 15 *)
9999- |]
100100-101101-(* Find short distance code for a distance, or None if not found.
102102- Returns the code that requires the fewest extra bits (codes 0-3 are best).
103103-104104- Short code mapping (RFC 7932):
105105- - Codes 0-3: exact match to last 4 distances
106106- - Codes 4-9: last distance +/- 1,2,3
107107- - Codes 10-15: second-to-last distance +/- 1,2,3 *)
108108-let find_short_code ring distance =
109109- if distance <= 0 then None
110110- else
111111- let last = get_last_distance ring 0 in
112112- let second = get_last_distance ring 1 in
113113- (* Build candidate distances for each short code *)
114114- let candidates = [|
115115- last; (* 0 *)
116116- get_last_distance ring 1; (* 1 *)
117117- get_last_distance ring 2; (* 2 *)
118118- get_last_distance ring 3; (* 3 *)
119119- (if last > 1 then last - 1 else -1); (* 4 *)
120120- last + 1; (* 5 *)
121121- (if last > 2 then last - 2 else -1); (* 6 *)
122122- last + 2; (* 7 *)
123123- (if last > 3 then last - 3 else -1); (* 8 *)
124124- last + 3; (* 9 *)
125125- (if second > 1 then second - 1 else -1); (* 10 *)
126126- second + 1; (* 11 *)
127127- (if second > 2 then second - 2 else -1); (* 12 *)
128128- second + 2; (* 13 *)
129129- (if second > 3 then second - 3 else -1); (* 14 *)
130130- second + 3; (* 15 *)
131131- |] in
132132- (* Find first matching code (lower codes are more efficient) *)
133133- Array.find_index (fun c -> c = distance) candidates
134134-135135-(* Command type with optional short distance code *)
136136-type command =
137137- | InsertCopy of {
138138- lit_start: int;
139139- lit_len: int;
140140- copy_len: int;
141141- distance: int;
142142- dist_code: int option; (* Some code for short codes 0-15, None for explicit *)
143143- }
144144- | Literals of { start: int; len: int }
145145-146146-(* Hash function - produces 17-bit hash from 4 bytes *)
147147-let[@inline always] hash4 src pos =
148148- Constants.hash4_bytes src pos hash_bits
149149-150150-(* Find match length *)
151151-let[@inline always] find_match_length src a b limit =
152152- let len = ref 0 in
153153- let max_len = min max_match (limit - b) in
154154- while !len < max_len && Bytes.get src (a + !len) = Bytes.get src (b + !len) do
155155- incr len
156156- done;
157157- !len
158158-159159-(* Log2 floor for non-zero values - matches brotli-c Log2FloorNonZero *)
160160-let[@inline always] log2_floor_nonzero v =
161161- let rec go v acc = if v <= 1 then acc else go (v lsr 1) (acc + 1) in
162162- go v 0
163163-164164-(* BackwardReferenceScore from brotli-c (hash.h line 115-118):
165165- score = SCORE_BASE + LITERAL_BYTE_SCORE * copy_length
166166- - DISTANCE_BIT_PENALTY * Log2FloorNonZero(backward_reference_offset)
167167- This prefers longer matches and shorter distances. *)
168168-let backward_reference_score copy_len backward_distance =
169169- brotli_score_base +
170170- brotli_literal_byte_score * copy_len -
171171- brotli_distance_bit_penalty * (log2_floor_nonzero backward_distance)
172172-173173-(* BackwardReferenceScoreUsingLastDistance from brotli-c (hash.h line 121-124):
174174- score = LITERAL_BYTE_SCORE * copy_length + SCORE_BASE + 15
175175- Short code 0 (last distance) gets a bonus. *)
176176-let backward_reference_score_using_last_distance copy_len =
177177- brotli_literal_byte_score * copy_len + brotli_score_base + 15
178178-179179-(* BackwardReferencePenaltyUsingLastDistance from brotli-c (hash.h line 127-129):
180180- Penalty for short codes 1-15 (not 0): 39 + lookup(distance_short_code)
181181- The magic constant 0x1CA10 encodes penalties: codes 1-3 get 0, 4-5 get 2, etc. *)
182182-let backward_reference_penalty_using_last_distance distance_short_code =
183183- 39 + ((0x1CA10 lsr (distance_short_code land 0xE)) land 0xE)
184184-185185-(* Score function matching brotli-c exactly *)
186186-let score_match copy_len distance dist_code =
187187- match dist_code with
188188- | Some 0 ->
189189- (* Last distance - use special scoring with bonus *)
190190- backward_reference_score_using_last_distance copy_len
191191- | Some code when code < 16 ->
192192- (* Other short codes - score with last distance bonus minus penalty *)
193193- let score = backward_reference_score_using_last_distance copy_len in
194194- score - backward_reference_penalty_using_last_distance code
195195- | _ ->
196196- (* Explicit distance - standard scoring *)
197197- backward_reference_score copy_len distance
198198-199199-(* Insert length code tables *)
200200-let insert_length_offset = [|
201201- 0; 1; 2; 3; 4; 5; 6; 8; 10; 14; 18; 26; 34; 50; 66; 98; 130; 194; 322; 578; 1090; 2114; 6210; 22594
202202-|]
203203-204204-(* Get insert length code *)
205205-let get_insert_code length =
206206- let rec find i =
207207- if i >= 23 then 23
208208- else if length < insert_length_offset.(i + 1) then i
209209- else find (i + 1)
210210- in
211211- find 0
212212-213213-(* Get max copy_len that fits with a given insert_len *)
214214-let max_copy_len_for_insert insert_len =
215215- let insert_code = get_insert_code insert_len in
216216- if insert_code >= 16 then 9 else max_match
217217-218218-(* Try to find a match at a short code distance.
219219- num_to_check controls how many short codes to check (4, 10, or 16 based on quality) *)
220220-let try_short_code_match ?(num_to_check=16) src pos limit ring =
221221- let candidates = short_code_distances ring in
222222- let best = ref None in
223223- let best_score = ref 0 in
224224- for code = 0 to num_to_check - 1 do
225225- let dist = candidates.(code) in
226226- if dist > 0 && pos - dist >= 0 then begin
227227- let prev = pos - dist in
228228- let match_len = find_match_length src prev pos limit in
229229- if match_len >= min_match then begin
230230- let score = score_match match_len dist (Some code) in
231231- if score > !best_score then begin
232232- best := Some (match_len, dist, code);
233233- best_score := score
234234- end
235235- end
236236- end
237237- done;
238238- !best
239239-240240-(* Score a dictionary match *)
241241-let score_dict_match copy_len =
242242- (* Dictionary matches save literals and have no backward reference overhead *)
243243- copy_len * 140 (* Slightly higher than LZ77's base score of 135 *)
244244-245245-(* Get max chain depth based on quality.
246246- For Q2-4: uses bucket sweep (limited positions per bucket slot)
247247- For Q5-9: uses block_size (ring buffer per bucket)
248248- For Q10-11: uses binary tree with max_tree_search_depth=64 *)
249249-let get_max_chain_depth quality =
250250- if quality <= 4 then get_bucket_sweep quality
251251- else get_block_size quality
252252-253253-(* Literal spree skip optimization from brotli-c quality.h:
254254- When searching for backward references and have not seen matches for a long
255255- time, we can skip some match lookups. Unsuccessful match lookups are very
256256- expensive and this kind of heuristic speeds up compression quite a lot.
257257- At first 8 byte strides are taken and every second byte is put to hasher.
258258- After 4x more literals stride by 16 bytes, put every 4th byte to hasher.
259259- Applied only to qualities 2 to 9. *)
260260-let get_literal_spree_length quality =
261261- if quality < 9 then 64 else 512
262262-263263-(* Find best match using hash chain for higher quality levels.
264264- Matches brotli-c FindLongestMatch: first checks distance cache (short codes),
265265- then searches hash chain/bucket.
266266- chain_table_base is the base offset used for chain_table indexing. *)
267267-let find_best_chain_match src pos src_end hash_table chain_table chain_table_base ring
268268- ~num_last_distances_to_check ~max_chain_depth =
269269- if pos + min_match > src_end then None
270270- else begin
271271- let best_len = ref (min_match - 1) in (* Start at min_match-1 so >= min_match wins *)
272272- let best_dist = ref 0 in
273273- let best_score = ref 0 in
274274- let best_code = ref None in
275275-276276- (* First: try short code distances (distance cache) - like brotli-c *)
277277- let short_dists = short_code_distances ring in
278278- for code = 0 to num_last_distances_to_check - 1 do
279279- let dist = short_dists.(code) in
280280- if dist > 0 && dist <= max_backward_distance then begin
281281- let prev = pos - dist in
282282- if prev >= 0 then begin
283283- let match_len = find_match_length src prev pos src_end in
284284- (* brotli-c accepts len >= 3 for codes 0-1, >= 4 otherwise *)
285285- let min_len = if code < 2 then 3 else min_match in
286286- if match_len >= min_len then begin
287287- let score = score_match match_len dist (Some code) in
288288- if score > !best_score then begin
289289- best_len := match_len;
290290- best_dist := dist;
291291- best_score := score;
292292- best_code := Some code
293293- end
294294- end
295295- end
296296- end
297297- done;
298298-299299- (* Second: search hash chain for more matches *)
300300- let h = hash4 src pos in
301301- let chain_pos = ref hash_table.(h) in
302302- let chain_count = ref 0 in
303303-304304- while !chain_pos >= 0 && !chain_count < max_chain_depth do
305305- let distance = pos - !chain_pos in
306306- if distance > 0 && distance <= max_backward_distance then begin
307307- let match_len = find_match_length src !chain_pos pos src_end in
308308- if match_len >= min_match then begin
309309- let dist_code = find_short_code ring distance in
310310- let score = score_match match_len distance dist_code in
311311- if score > !best_score then begin
312312- best_len := match_len;
313313- best_dist := distance;
314314- best_score := score;
315315- best_code := dist_code
316316- end
317317- end
318318- end;
319319- (* Follow the chain - index relative to base *)
320320- let chain_idx = !chain_pos - chain_table_base in
321321- if chain_idx >= 0 && chain_idx < Array.length chain_table then
322322- chain_pos := chain_table.(chain_idx)
323323- else
324324- chain_pos := -1;
325325- incr chain_count
326326- done;
327327-328328- if !best_len >= min_match then
329329- Some (!best_len, !best_dist, !best_code)
330330- else
331331- None
332332- end
333333-334334-(* Update hash chain. chain_table_base is the base offset for indexing. *)
335335-let update_hash_chain src pos hash_table chain_table chain_table_base =
336336- let chain_idx = pos - chain_table_base in
337337- if chain_idx >= 0 && chain_idx < Array.length chain_table && pos + min_match <= Bytes.length src then begin
338338- let h = hash4 src pos in
339339- chain_table.(chain_idx) <- hash_table.(h);
340340- hash_table.(h) <- pos
341341- end
342342-343343-(* Generate commands with LZ77 matching, dictionary matching, and distance ring buffer.
344344- Parameters match brotli-c quality-dependent configuration. *)
345345-let generate_commands ?(use_dict=false) ?(quality=2) src src_pos src_len =
346346- if src_len < min_match then
347347- [Literals { start = src_pos; len = src_len }]
348348- else begin
349349- let commands = ref [] in
350350- let hash_table = Array.make hash_size (-1) in
351351- (* Chain table for quality 4+ - each position stores prev position with same hash.
352352- The table is indexed relative to src_pos. *)
353353- let chain_table =
354354- if quality >= 4 then Array.make src_len (-1)
355355- else [||] (* Not used for lower qualities *)
356356- in
357357- let chain_table_base = src_pos in (* Base offset for chain_table indexing *)
358358- let ring = create_dist_ring () in
359359- let pos = ref src_pos in
360360- let src_end = src_pos + src_len in
361361- let pending_start = ref src_pos in
362362- let output_pos = ref 0 in
363363- let max_chain_depth = get_max_chain_depth quality in
364364- let num_last_distances_to_check = get_num_last_distances_to_check quality in
365365-366366- (* Cost for lazy matching decision - brotli-c uses heuristic thresholds *)
367367- let lazy_match_cost = if quality >= 4 then 175 else 0 in
368368-369369- (* Literal spree skip optimization - track consecutive literals without matches *)
370370- let literal_spree = ref 0 in
371371- let spree_length = get_literal_spree_length quality in
372372- let use_spree_skip = quality >= 2 && quality <= 9 in
373373-374374- while !pos < src_end - min_match do
375375- (* Determine if we should skip this position due to literal spree *)
376376- let skip_this_position =
377377- if use_spree_skip && !literal_spree >= spree_length then begin
378378- (* In sparse search mode - skip based on spree level *)
379379- let stride = if !literal_spree >= spree_length * 4 then 16 else 8 in
380380- let relative_pos = !pos - !pending_start in
381381- relative_pos mod stride <> 0
382382- end else false
383383- in
384384-385385- if skip_this_position then begin
386386- (* Still update hash table but with reduced frequency *)
387387- let hash_update_stride = if !literal_spree >= spree_length * 4 then 4 else 2 in
388388- let relative_pos = !pos - !pending_start in
389389- if relative_pos mod hash_update_stride = 0 then begin
390390- if quality >= 4 then
391391- update_hash_chain src !pos hash_table chain_table chain_table_base
392392- else
393393- hash_table.(hash4 src !pos) <- !pos
394394- end;
395395- incr pos;
396396- incr literal_spree
397397- end else begin
398398- (* Find best match at current position *)
399399- let hash_match =
400400- if quality >= 4 then
401401- find_best_chain_match src !pos src_end hash_table chain_table chain_table_base ring
402402- ~num_last_distances_to_check ~max_chain_depth
403403- else begin
404404- (* Q2-3: Simple hash lookup with bucket sweep *)
405405- let h = hash4 src !pos in
406406- let prev = hash_table.(h) in
407407- hash_table.(h) <- !pos;
408408- (* Also check distance cache first *)
409409- let short_match = try_short_code_match ~num_to_check:num_last_distances_to_check
410410- src !pos src_end ring in
411411- let hash_result =
412412- if prev >= src_pos && !pos - prev <= max_backward_distance then begin
413413- let match_len = find_match_length src prev !pos src_end in
414414- if match_len >= min_match then
415415- let distance = !pos - prev in
416416- let dist_code = find_short_code ring distance in
417417- Some (match_len, distance, dist_code)
418418- else
419419- None
420420- end
421421- else
422422- None
423423- in
424424- (* Pick best between short code match and hash match *)
425425- match short_match, hash_result with
426426- | None, r -> r
427427- | Some (len, dist, code), None -> Some (len, dist, Some code)
428428- | Some (slen, sdist, scode), Some (hlen, hdist, hcode) ->
429429- let s_score = score_match slen sdist (Some scode) in
430430- let h_score = score_match hlen hdist hcode in
431431- if s_score >= h_score then Some (slen, sdist, Some scode)
432432- else Some (hlen, hdist, hcode)
433433- end
434434- in
435435-436436- (* Update hash chain for quality 4+ *)
437437- if quality >= 4 then
438438- update_hash_chain src !pos hash_table chain_table chain_table_base;
439439-440440- (* Try dictionary match if enabled *)
441441- let dict_match =
442442- if use_dict then begin
443443- let pending_lits = !pos - !pending_start in
444444- let current_output_pos = !output_pos + pending_lits in
445445- Dict_match.find_match src !pos src_end max_backward_distance ~current_output_pos
446446- end
447447- else
448448- None
449449- in
450450-451451- (* Choose the best match based on score *)
452452- let best_match =
453453- match hash_match, dict_match with
454454- | None, None -> None
455455- | Some m, None -> Some m
456456- | None, Some (dict_len, dict_dist) ->
457457- Some (dict_len, dict_dist, None)
458458- | Some (lz_len, lz_dist, lz_code), Some (dict_len, dict_dist) ->
459459- let lz_score = score_match lz_len lz_dist lz_code in
460460- let dict_score = score_dict_match dict_len in
461461- if dict_score > lz_score then
462462- Some (dict_len, dict_dist, None)
463463- else
464464- Some (lz_len, lz_dist, lz_code)
465465- in
466466-467467- match best_match with
468468- | Some (match_len, distance, dist_code) ->
469469- (* Lazy matching for quality 4+: check if delaying gives better match *)
470470- let final_match =
471471- if quality >= 4 && !pos + 1 < src_end - min_match && match_len < max_match then begin
472472- (* Update hash for next position *)
473473- update_hash_chain src (!pos + 1) hash_table chain_table chain_table_base;
474474- let next_match = find_best_chain_match src (!pos + 1) src_end
475475- hash_table chain_table chain_table_base ring
476476- ~num_last_distances_to_check ~max_chain_depth in
477477- match next_match with
478478- | Some (next_len, next_dist, next_code) ->
479479- let curr_score = score_match match_len distance dist_code in
480480- let next_score = score_match next_len next_dist next_code - lazy_match_cost in
481481- if next_score > curr_score then begin
482482- (* Skip current position, emit literal *)
483483- incr pos;
484484- pending_start := !pending_start; (* Keep pending_start *)
485485- None (* Signal to continue loop *)
486486- end else
487487- Some (match_len, distance, dist_code)
488488- | None -> Some (match_len, distance, dist_code)
489489- end else
490490- Some (match_len, distance, dist_code)
491491- in
492492-493493- (match final_match with
494494- | Some (match_len, distance, dist_code) ->
495495- let lit_len = !pos - !pending_start in
496496- let max_copy = max_copy_len_for_insert lit_len in
497497- let copy_len = min match_len max_copy in
498498-499499- commands := InsertCopy {
500500- lit_start = !pending_start;
501501- lit_len;
502502- copy_len;
503503- distance;
504504- dist_code;
505505- } :: !commands;
506506-507507- output_pos := !output_pos + lit_len + copy_len;
508508-509509- (match dist_code with
510510- | Some 0 -> ()
511511- | _ -> push_distance ring distance);
512512-513513- (* Update hash for all positions in the match for better chain coverage *)
514514- let hash_update_count =
515515- if quality >= 10 then min (copy_len - 1) 16
516516- else if quality >= 4 then min (copy_len - 1) 8
517517- else min (copy_len - 1) 2 in
518518- for i = 1 to hash_update_count do
519519- if !pos + i < src_end - min_match then begin
520520- if quality >= 4 then
521521- update_hash_chain src (!pos + i) hash_table chain_table chain_table_base
522522- else
523523- hash_table.(hash4 src (!pos + i)) <- !pos + i
524524- end
525525- done;
526526-527527- pos := !pos + copy_len;
528528- pending_start := !pos;
529529- (* Reset literal spree counter on match *)
530530- literal_spree := 0
531531- | None ->
532532- (* Lazy match chose to skip, position already incremented *)
533533- incr literal_spree)
534534- | None ->
535535- incr pos;
536536- incr literal_spree
537537- end (* end of else begin for skip_this_position *)
538538- done;
539539-540540- if !pending_start < src_end then
541541- commands := Literals { start = !pending_start; len = src_end - !pending_start } :: !commands;
542542-543543- List.rev !commands
544544- end
-984
ocaml-brotli/src/optimal.ml
···11-(* Optimal parsing for Brotli compression (quality 10-11)
22- This implements Zopfli-like optimal matching using dynamic programming,
33- matching the brotli-c reference implementation in backward_references_hq.c *)
44-55-(* Configuration constants from brotli-c quality.h *)
66-let max_zopfli_len_quality_10 = 150
77-let max_zopfli_len_quality_11 = 325
88-let max_zopfli_candidates_q10 = 1 (* MaxZopfliCandidates for Q10 *)
99-let max_zopfli_candidates_q11 = 5 (* MaxZopfliCandidates for Q11 *)
1010-let brotli_long_copy_quick_step = 16384
1111-1212-(* Match parameters *)
1313-let min_match = 4
1414-let max_match = 258
1515-let max_distance = (1 lsl 22) - 16
1616-let hash_bits = 17
1717-let hash_size = 1 lsl hash_bits
1818-let max_tree_search_depth = 64 (* For H10 binary tree hasher *)
1919-2020-(* Distance cache index and offset from brotli-c backward_references_hq.c *)
2121-let distance_cache_index = [| 0; 1; 2; 3; 0; 0; 0; 0; 0; 0; 1; 1; 1; 1; 1; 1 |]
2222-let distance_cache_offset = [| 0; 0; 0; 0; -1; 1; -2; 2; -3; 3; -1; 1; -2; 2; -3; 3 |]
2323-2424-(* Infinity for cost comparison *)
2525-let infinity = max_float
2626-2727-(* Fast log2 approximation matching brotli-c FastLog2 *)
2828-let[@inline always] fast_log2 v =
2929- if v <= 0 then 0.0
3030- else
3131- let rec log2_floor v acc = if v <= 1 then acc else log2_floor (v lsr 1) (acc + 1) in
3232- float_of_int (log2_floor v 0)
3333-3434-(* ============================================================
3535- Cost Model (ZopfliCostModel from brotli-c)
3636- ============================================================ *)
3737-3838-type cost_model = {
3939- (* Cost arrays *)
4040- cost_cmd : float array; (* Command code costs *)
4141- cost_dist : float array; (* Distance code costs *)
4242- literal_costs : float array; (* Cumulative literal costs *)
4343- min_cost_cmd : float; (* Minimum command cost *)
4444- num_bytes : int;
4545-}
4646-4747-(* SetCost from brotli-c: calculate Shannon entropy costs from histogram *)
4848-let set_cost histogram histogram_size is_literal =
4949- let cost = Array.make histogram_size 0.0 in
5050- let sum = Array.fold_left (+) 0 histogram in
5151- if sum = 0 then cost
5252- else begin
5353- let log2sum = fast_log2 sum in
5454- let missing_symbol_sum =
5555- if is_literal then sum
5656- else sum + (Array.fold_left (fun acc h -> if h = 0 then acc + 1 else acc) 0 histogram)
5757- in
5858- let missing_symbol_cost = (fast_log2 missing_symbol_sum) +. 2.0 in
5959- for i = 0 to histogram_size - 1 do
6060- if histogram.(i) = 0 then
6161- cost.(i) <- missing_symbol_cost
6262- else begin
6363- (* Shannon bits: log2(sum) - log2(count) *)
6464- cost.(i) <- max 1.0 (log2sum -. fast_log2 histogram.(i))
6565- end
6666- done;
6767- cost
6868- end
6969-7070-(* UTF-8 position detection from brotli-c literal_cost.c:
7171- Returns the expected position within a UTF-8 multi-byte sequence.
7272- 0 = single byte or first byte, 1 = second byte, 2 = third byte *)
7373-let utf8_position last_byte current_byte max_utf8 =
7474- if current_byte < 128 then
7575- 0 (* ASCII - next one is byte 1 again *)
7676- else if current_byte >= 192 then
7777- (* Start of multi-byte sequence *)
7878- min 1 max_utf8
7979- else begin
8080- (* Continuation byte - check last byte to determine position *)
8181- if last_byte < 0xE0 then
8282- 0 (* Completed two-byte sequence *)
8383- else
8484- (* Third byte of three-byte sequence *)
8585- min 2 max_utf8
8686- end
8787-8888-(* Detect if data is mostly UTF-8 and determine histogram level
8989- Returns 0 for ASCII, 1 for 2-byte UTF-8, 2 for 3-byte UTF-8 *)
9090-let decide_utf8_level src src_pos len =
9191- let counts = Array.make 3 0 in
9292- let last_c = ref 0 in
9393- for i = 0 to min 2000 len - 1 do
9494- let c = Char.code (Bytes.get src (src_pos + i)) in
9595- let utf8_pos = utf8_position !last_c c 2 in
9696- counts.(utf8_pos) <- counts.(utf8_pos) + 1;
9797- last_c := c
9898- done;
9999- (* Use 3-byte histograms if >500 third-position bytes,
100100- 2-byte if >25 second/third position bytes combined,
101101- otherwise single histogram *)
102102- if counts.(2) < 500 then begin
103103- if counts.(1) + counts.(2) < 25 then 0
104104- else 1
105105- end else 2
106106-107107-(* Sliding window literal cost estimation matching brotli-c literal_cost.c
108108- Uses a sliding window to estimate per-position literal costs based on
109109- local byte frequency distribution. For UTF-8 text, uses position-aware
110110- histograms for better cost estimation. *)
111111-let estimate_literal_costs_sliding_window src src_pos num_bytes =
112112- let costs = Array.make (num_bytes + 2) 0.0 in
113113- if num_bytes = 0 then costs
114114- else begin
115115- let max_utf8 = decide_utf8_level src src_pos num_bytes in
116116-117117- if max_utf8 > 0 then begin
118118- (* UTF-8 mode: use position-aware histograms *)
119119- let window_half = 495 in (* Smaller window for UTF-8 from brotli-c *)
120120- let num_histograms = max_utf8 + 1 in
121121- let histograms = Array.init num_histograms (fun _ -> Array.make 256 0) in
122122- let in_window_utf8 = Array.make num_histograms 0 in
123123-124124- (* Bootstrap histograms *)
125125- let initial_window = min window_half num_bytes in
126126- let last_c = ref 0 in
127127- let utf8_pos = ref 0 in
128128- for i = 0 to initial_window - 1 do
129129- let c = Char.code (Bytes.get src (src_pos + i)) in
130130- histograms.(!utf8_pos).(c) <- histograms.(!utf8_pos).(c) + 1;
131131- in_window_utf8.(!utf8_pos) <- in_window_utf8.(!utf8_pos) + 1;
132132- utf8_pos := utf8_position !last_c c max_utf8;
133133- last_c := c
134134- done;
135135-136136- costs.(0) <- 0.0;
137137- let prev1 = ref 0 in
138138- let prev2 = ref 0 in
139139- for i = 0 to num_bytes - 1 do
140140- (* Slide window: remove byte from past *)
141141- if i >= window_half then begin
142142- let past_c = if i < window_half + 1 then 0
143143- else Char.code (Bytes.get src (src_pos + i - window_half - 1)) in
144144- let past_last = if i < window_half + 2 then 0
145145- else Char.code (Bytes.get src (src_pos + i - window_half - 2)) in
146146- let utf8_pos2 = utf8_position past_last past_c max_utf8 in
147147- let remove_c = Char.code (Bytes.get src (src_pos + i - window_half)) in
148148- histograms.(utf8_pos2).(remove_c) <- histograms.(utf8_pos2).(remove_c) - 1;
149149- in_window_utf8.(utf8_pos2) <- in_window_utf8.(utf8_pos2) - 1
150150- end;
151151- (* Slide window: add byte from future *)
152152- if i + window_half < num_bytes then begin
153153- let fut_c = Char.code (Bytes.get src (src_pos + i + window_half - 1)) in
154154- let fut_last = Char.code (Bytes.get src (src_pos + i + window_half - 2)) in
155155- let utf8_pos2 = utf8_position fut_last fut_c max_utf8 in
156156- let add_c = Char.code (Bytes.get src (src_pos + i + window_half)) in
157157- histograms.(utf8_pos2).(add_c) <- histograms.(utf8_pos2).(add_c) + 1;
158158- in_window_utf8.(utf8_pos2) <- in_window_utf8.(utf8_pos2) + 1
159159- end;
160160-161161- (* Calculate cost for current byte using UTF-8 position *)
162162- let c = Char.code (Bytes.get src (src_pos + i)) in
163163- let utf8_pos = utf8_position !prev2 !prev1 max_utf8 in
164164- let histo = max 1 histograms.(utf8_pos).(c) in
165165- let in_win = max 1 in_window_utf8.(utf8_pos) in
166166- let lit_cost = fast_log2 in_win -. fast_log2 histo +. 0.02905 in
167167- let lit_cost = if lit_cost < 1.0 then lit_cost *. 0.5 +. 0.5 else lit_cost in
168168- let prologue_length = 2000 in
169169- let lit_cost =
170170- if i < prologue_length then
171171- lit_cost +. 0.35 +. 0.35 /. float_of_int prologue_length *. float_of_int i
172172- else lit_cost
173173- in
174174- costs.(i + 1) <- costs.(i) +. lit_cost;
175175- prev2 := !prev1;
176176- prev1 := c
177177- done;
178178- costs
179179- end else begin
180180- (* Binary/ASCII mode: single histogram *)
181181- let window_half = 2000 in (* Larger window for non-UTF-8 *)
182182- let histogram = Array.make 256 0 in
183183-184184- (* Bootstrap histogram for first window_half bytes *)
185185- let initial_window = min window_half num_bytes in
186186- for i = 0 to initial_window - 1 do
187187- let c = Char.code (Bytes.get src (src_pos + i)) in
188188- histogram.(c) <- histogram.(c) + 1
189189- done;
190190- let in_window = ref initial_window in
191191-192192- costs.(0) <- 0.0;
193193- for i = 0 to num_bytes - 1 do
194194- (* Slide window: remove byte from past *)
195195- if i >= window_half then begin
196196- let old_c = Char.code (Bytes.get src (src_pos + i - window_half)) in
197197- histogram.(old_c) <- histogram.(old_c) - 1;
198198- decr in_window
199199- end;
200200- (* Slide window: add byte from future *)
201201- if i + window_half < num_bytes then begin
202202- let new_c = Char.code (Bytes.get src (src_pos + i + window_half)) in
203203- histogram.(new_c) <- histogram.(new_c) + 1;
204204- incr in_window
205205- end;
206206-207207- (* Calculate cost for current byte *)
208208- let c = Char.code (Bytes.get src (src_pos + i)) in
209209- let histo = max 1 histogram.(c) in
210210- let lit_cost = fast_log2 !in_window -. fast_log2 histo +. 0.029 in
211211- let lit_cost = if lit_cost < 1.0 then lit_cost *. 0.5 +. 0.5 else lit_cost in
212212- let prologue_length = 2000 in
213213- let lit_cost =
214214- if i < prologue_length then
215215- lit_cost +. 0.35 +. 0.35 /. float_of_int prologue_length *. float_of_int i
216216- else lit_cost
217217- in
218218- costs.(i + 1) <- costs.(i) +. lit_cost
219219- done;
220220- costs
221221- end
222222- end
223223-224224-(* Initialize cost model from literal costs (first pass) *)
225225-let init_cost_model_from_literals src src_pos num_bytes =
226226- (* Use sliding window for accurate per-position literal cost estimation *)
227227- let literal_costs = estimate_literal_costs_sliding_window src src_pos num_bytes in
228228-229229- (* Command costs: FastLog2(11 + cmd_code) *)
230230- let cost_cmd = Array.init 704 (fun i -> fast_log2 (11 + i)) in
231231- let min_cost_cmd = fast_log2 11 in
232232-233233- (* Distance costs: FastLog2(20 + dist_code) *)
234234- let cost_dist = Array.init 544 (fun i -> fast_log2 (20 + i)) in
235235-236236- { cost_cmd; cost_dist; literal_costs; min_cost_cmd; num_bytes }
237237-238238-(* Initialize cost model from command histograms (second pass for Q11) *)
239239-let init_cost_model_from_histograms src src_pos num_bytes
240240- ~lit_histogram ~cmd_histogram ~dist_histogram =
241241- (* Literal costs from histogram *)
242242- let lit_costs = set_cost lit_histogram 256 true in
243243- let literal_costs = Array.make (num_bytes + 2) 0.0 in
244244- literal_costs.(0) <- 0.0;
245245- for i = 0 to num_bytes - 1 do
246246- let c = Char.code (Bytes.get src (src_pos + i)) in
247247- literal_costs.(i + 1) <- literal_costs.(i) +. lit_costs.(c)
248248- done;
249249-250250- (* Command costs from histogram *)
251251- let cost_cmd = set_cost cmd_histogram 704 false in
252252- let min_cost_cmd = Array.fold_left min infinity cost_cmd in
253253-254254- (* Distance costs from histogram *)
255255- let cost_dist = set_cost dist_histogram 544 false in
256256-257257- { cost_cmd; cost_dist; literal_costs; min_cost_cmd; num_bytes }
258258-259259-let get_literal_cost model from_pos to_pos =
260260- model.literal_costs.(to_pos) -. model.literal_costs.(from_pos)
261261-262262-let get_command_cost model cmd_code =
263263- if cmd_code < 704 then model.cost_cmd.(cmd_code) else 20.0
264264-265265-let get_distance_cost model dist_code =
266266- if dist_code < 544 then model.cost_dist.(dist_code) else 20.0
267267-268268-(* ============================================================
269269- StartPosQueue - maintains 8 best starting positions
270270- ============================================================ *)
271271-272272-type pos_data = {
273273- pos : int;
274274- distance_cache : int array;
275275- costdiff : float;
276276- cost : float;
277277-}
278278-279279-type start_pos_queue = {
280280- mutable q : pos_data array;
281281- mutable idx : int;
282282-}
283283-284284-let create_start_pos_queue () =
285285- let empty = { pos = 0; distance_cache = [|16;15;11;4|]; costdiff = infinity; cost = infinity } in
286286- { q = Array.make 8 empty; idx = 0 }
287287-288288-let start_pos_queue_size queue =
289289- min queue.idx 8
290290-291291-let start_pos_queue_push queue posdata =
292292- let offset = (lnot queue.idx) land 7 in
293293- queue.idx <- queue.idx + 1;
294294- let len = start_pos_queue_size queue in
295295- queue.q.(offset) <- posdata;
296296- (* Restore sorted order by costdiff *)
297297- let q = queue.q in
298298- for i = 1 to len - 1 do
299299- let idx1 = (offset + i - 1) land 7 in
300300- let idx2 = (offset + i) land 7 in
301301- if q.(idx1).costdiff > q.(idx2).costdiff then begin
302302- let tmp = q.(idx1) in
303303- q.(idx1) <- q.(idx2);
304304- q.(idx2) <- tmp
305305- end
306306- done
307307-308308-let start_pos_queue_at queue k =
309309- queue.q.((k - queue.idx) land 7)
310310-311311-(* ============================================================
312312- Zopfli Node - DP state at each position
313313- ============================================================ *)
314314-315315-type zopfli_node = {
316316- mutable length : int; (* Copy length (lower 25 bits) + len_code modifier *)
317317- mutable distance : int; (* Copy distance *)
318318- mutable dcode_insert_length : int; (* Short code (upper 5 bits) + insert length *)
319319- mutable cost : float; (* Cost or next pointer *)
320320- mutable shortcut : int; (* Shortcut for distance cache computation *)
321321-}
322322-323323-let create_zopfli_node () =
324324- { length = 1; distance = 0; dcode_insert_length = 0; cost = infinity; shortcut = 0 }
325325-326326-let zopfli_node_copy_length node = node.length land 0x1FFFFFF
327327-let zopfli_node_copy_distance node = node.distance
328328-let zopfli_node_insert_length node = node.dcode_insert_length land 0x7FFFFFF
329329-let zopfli_node_distance_code node =
330330- let short_code = node.dcode_insert_length lsr 27 in
331331- if short_code = 0 then zopfli_node_copy_distance node + 16 - 1
332332- else short_code - 1
333333-334334-let zopfli_node_command_length node =
335335- zopfli_node_copy_length node + zopfli_node_insert_length node
336336-337337-(* ============================================================
338338- Hash functions and match finding
339339- ============================================================ *)
340340-341341-let[@inline always] hash4 src pos =
342342- let b0 = Char.code (Bytes.unsafe_get src pos) in
343343- let b1 = Char.code (Bytes.unsafe_get src (pos + 1)) in
344344- let b2 = Char.code (Bytes.unsafe_get src (pos + 2)) in
345345- let b3 = Char.code (Bytes.unsafe_get src (pos + 3)) in
346346- let v = b0 lor (b1 lsl 8) lor (b2 lsl 16) lor (b3 lsl 24) in
347347- ((v * 0x1e35a7bd) land 0xFFFFFFFF) lsr (32 - hash_bits)
348348-349349-let[@inline always] find_match_length src a b limit =
350350- let len = ref 0 in
351351- let max_len = min max_match (limit - b) in
352352- while !len < max_len && Bytes.get src (a + !len) = Bytes.get src (b + !len) do
353353- incr len
354354- done;
355355- !len
356356-357357-(* Backward match structure *)
358358-type backward_match = {
359359- bm_distance : int;
360360- bm_length : int;
361361- bm_len_code : int;
362362-}
363363-364364-(* Find all matches at a position, sorted by length *)
365365-let find_all_matches src pos src_end hash_table chain_table chain_base max_distance =
366366- if pos + min_match > src_end then []
367367- else begin
368368- let matches = ref [] in
369369- let best_len = ref (min_match - 1) in
370370-371371- (* Search hash chain *)
372372- let h = hash4 src pos in
373373- let chain_pos = ref hash_table.(h) in
374374- let chain_count = ref 0 in
375375-376376- while !chain_pos >= 0 && !chain_count < max_tree_search_depth do
377377- let distance = pos - !chain_pos in
378378- if distance > 0 && distance <= max_distance then begin
379379- let match_len = find_match_length src !chain_pos pos src_end in
380380- if match_len > !best_len then begin
381381- best_len := match_len;
382382- matches := { bm_distance = distance; bm_length = match_len; bm_len_code = match_len } :: !matches
383383- end
384384- end;
385385- let chain_idx = !chain_pos - chain_base in
386386- if chain_idx >= 0 && chain_idx < Array.length chain_table then
387387- chain_pos := chain_table.(chain_idx)
388388- else
389389- chain_pos := -1;
390390- incr chain_count
391391- done;
392392-393393- (* Sort by length ascending *)
394394- List.sort (fun a b -> compare a.bm_length b.bm_length) !matches
395395- end
396396-397397-(* ============================================================
398398- Insert/Copy length encoding (from brotli-c prefix.h)
399399- ============================================================ *)
400400-401401-let get_insert_length_code insert_len =
402402- if insert_len < 6 then insert_len
403403- else if insert_len < 130 then
404404- let nbits = Lz77.log2_floor_nonzero (insert_len - 2) - 1 in
405405- (nbits lsl 1) + ((insert_len - 2) lsr nbits) + 2
406406- else if insert_len < 2114 then
407407- Lz77.log2_floor_nonzero (insert_len - 66) + 10
408408- else if insert_len < 6210 then 21
409409- else if insert_len < 22594 then 22
410410- else 23
411411-412412-let get_copy_length_code copy_len =
413413- if copy_len < 10 then copy_len - 2
414414- else if copy_len < 134 then
415415- let nbits = Lz77.log2_floor_nonzero (copy_len - 6) - 1 in
416416- (nbits lsl 1) + ((copy_len - 6) lsr nbits) + 4
417417- else if copy_len < 2118 then
418418- Lz77.log2_floor_nonzero (copy_len - 70) + 12
419419- else 23
420420-421421-let get_insert_extra insert_code =
422422- let kInsertExtraBits = [| 0;0;0;0;0;0;1;1;2;2;3;3;4;4;5;5;6;7;8;9;10;12;14;24 |] in
423423- if insert_code < 24 then kInsertExtraBits.(insert_code) else 24
424424-425425-let get_copy_extra copy_code =
426426- let kCopyExtraBits = [| 0;0;0;0;0;0;0;0;1;1;2;2;3;3;4;4;5;5;6;7;8;9;10;24 |] in
427427- if copy_code < 24 then kCopyExtraBits.(copy_code) else 24
428428-429429-let combine_length_codes inscode copycode use_last_distance =
430430- let inscode64 = (inscode land 0x7) lor ((inscode land 0x18) lsl 2) in
431431- let copycode64 = (copycode land 0x7) lor ((copycode land 0x18) lsl 3) in
432432- let c = (copycode64 land 0x38) lor inscode64 in
433433- if use_last_distance && inscode < 8 && copycode < 16 then c
434434- else if inscode < 8 && copycode < 16 then c lor 64
435435- else c lor (128 + (if copycode >= 16 then 64 else 0))
436436-437437-(* ============================================================
438438- Distance encoding
439439- ============================================================ *)
440440-441441-let prefix_encode_copy_distance dist_code =
442442- if dist_code < 16 then (dist_code, 0, 0)
443443- else begin
444444- let dist = dist_code - 15 in
445445- let nbits = Lz77.log2_floor_nonzero dist in
446446- let prefix = (nbits lsl 1) + ((dist lsr (nbits - 1)) land 1) + 12 in
447447- let extra_bits = nbits - 1 in
448448- let extra = dist land ((1 lsl extra_bits) - 1) in
449449- (prefix, extra_bits, extra)
450450- end
451451-452452-(* ============================================================
453453- Main Zopfli DP Algorithm
454454- ============================================================ *)
455455-456456-(* Compute distance cache at a position from the DP path *)
457457-let compute_distance_cache pos starting_dist_cache nodes =
458458- let dist_cache = Array.make 4 0 in
459459- let idx = ref 0 in
460460- let p = ref nodes.(pos).shortcut in
461461- while !idx < 4 && !p > 0 do
462462- let node = nodes.(!p) in
463463- let c_len = zopfli_node_copy_length node in
464464- let i_len = zopfli_node_insert_length node in
465465- let dist = zopfli_node_copy_distance node in
466466- dist_cache.(!idx) <- dist;
467467- incr idx;
468468- p := nodes.(!p - c_len - i_len).shortcut
469469- done;
470470- for i = !idx to 3 do
471471- dist_cache.(i) <- starting_dist_cache.(i - !idx)
472472- done;
473473- dist_cache
474474-475475-(* Compute distance shortcut *)
476476-let compute_distance_shortcut block_start pos max_backward_limit nodes =
477477- if pos = 0 then 0
478478- else begin
479479- let node = nodes.(pos) in
480480- let c_len = zopfli_node_copy_length node in
481481- let i_len = zopfli_node_insert_length node in
482482- let dist = zopfli_node_copy_distance node in
483483- if dist + c_len <= block_start + pos &&
484484- dist <= max_backward_limit &&
485485- zopfli_node_distance_code node > 0 then
486486- pos
487487- else
488488- nodes.(pos - c_len - i_len).shortcut
489489- end
490490-491491-(* Update Zopfli node with new values *)
492492-let update_zopfli_node nodes pos start len len_code dist short_code cost =
493493- let node = nodes.(pos + len) in
494494- node.length <- len lor ((len + 9 - len_code) lsl 25);
495495- node.distance <- dist;
496496- node.dcode_insert_length <- (short_code lsl 27) lor (pos - start);
497497- node.cost <- cost
498498-499499-(* Compute minimum copy length that can improve cost *)
500500-let compute_minimum_copy_length start_cost nodes num_bytes pos =
501501- let min_cost = ref start_cost in
502502- let len = ref 2 in
503503- let next_len_bucket = ref 4 in
504504- let next_len_offset = ref 10 in
505505- while pos + !len <= num_bytes && nodes.(pos + !len).cost <= !min_cost do
506506- incr len;
507507- if !len = !next_len_offset then begin
508508- min_cost := !min_cost +. 1.0;
509509- next_len_offset := !next_len_offset + !next_len_bucket;
510510- next_len_bucket := !next_len_bucket * 2
511511- end
512512- done;
513513- !len
514514-515515-(* Evaluate node and push to queue if eligible *)
516516-let evaluate_node block_start pos max_backward_limit starting_dist_cache model queue nodes =
517517- let node_cost = nodes.(pos).cost in
518518- nodes.(pos).shortcut <- compute_distance_shortcut block_start pos max_backward_limit nodes;
519519- if node_cost <= get_literal_cost model 0 pos then begin
520520- let dist_cache = compute_distance_cache pos starting_dist_cache nodes in
521521- let posdata = {
522522- pos;
523523- distance_cache = dist_cache;
524524- costdiff = node_cost -. get_literal_cost model 0 pos;
525525- cost = node_cost;
526526- } in
527527- start_pos_queue_push queue posdata
528528- end
529529-530530-(* Update nodes at a position - core Zopfli DP step *)
531531-let update_nodes num_bytes block_start pos src src_pos model
532532- max_backward_limit starting_dist_cache
533533- num_matches matches queue nodes max_zopfli_len max_iters =
534534- let cur_ix = block_start + pos in
535535- let max_distance_here = min cur_ix max_backward_limit in
536536- let max_len = num_bytes - pos in
537537- let result = ref 0 in
538538-539539- evaluate_node block_start pos max_backward_limit starting_dist_cache model queue nodes;
540540-541541- (* Compute minimum copy length based on best queue entry *)
542542- let posdata0 = start_pos_queue_at queue 0 in
543543- let min_cost = posdata0.cost +. model.min_cost_cmd +. get_literal_cost model posdata0.pos pos in
544544- let min_len = compute_minimum_copy_length min_cost nodes num_bytes pos in
545545-546546- (* Go over starting positions in order of increasing cost difference *)
547547- let queue_size = start_pos_queue_size queue in
548548- for k = 0 to min (max_iters - 1) (queue_size - 1) do
549549- let posdata = start_pos_queue_at queue k in
550550- let start = posdata.pos in
551551- let inscode = get_insert_length_code (pos - start) in
552552- let start_costdiff = posdata.costdiff in
553553- let base_cost = start_costdiff +. float_of_int (get_insert_extra inscode) +.
554554- get_literal_cost model 0 pos in
555555-556556- (* Check distance cache matches first *)
557557- let best_len = ref (min_len - 1) in
558558- for j = 0 to 15 do
559559- if !best_len < max_len then begin
560560- let idx = distance_cache_index.(j) in
561561- let backward = posdata.distance_cache.(idx) + distance_cache_offset.(j) in
562562- if backward > 0 && backward <= max_distance_here then begin
563563- let prev_ix = cur_ix - backward in
564564- let match_len = find_match_length src prev_ix (src_pos + pos) (src_pos + num_bytes) in
565565- if match_len >= 2 then begin
566566- let dist_cost = base_cost +. get_distance_cost model j in
567567- for l = !best_len + 1 to match_len do
568568- let copycode = get_copy_length_code l in
569569- let cmdcode = combine_length_codes inscode copycode (j = 0) in
570570- let cost = (if cmdcode < 128 then base_cost else dist_cost) +.
571571- float_of_int (get_copy_extra copycode) +.
572572- get_command_cost model cmdcode in
573573- if cost < nodes.(pos + l).cost then begin
574574- update_zopfli_node nodes pos start l l backward (j + 1) cost;
575575- result := max !result l
576576- end;
577577- best_len := l
578578- done
579579- end
580580- end
581581- end
582582- done;
583583-584584- (* For iterations >= 2, only look at distance cache matches *)
585585- if k < 2 then begin
586586- (* Loop through all matches *)
587587- let len = ref min_len in
588588- for j = 0 to num_matches - 1 do
589589- let m = matches.(j) in
590590- let dist = m.bm_distance in
591591- let dist_code = dist + 16 - 1 in (* Add 16 short codes *)
592592- let (dist_symbol, distnumextra, _) = prefix_encode_copy_distance dist_code in
593593- let dist_cost = base_cost +. float_of_int distnumextra +.
594594- get_distance_cost model dist_symbol in
595595- let max_match_len = m.bm_length in
596596-597597- (* For long matches or dictionary, try only max length *)
598598- if !len < max_match_len && max_match_len > max_zopfli_len then
599599- len := max_match_len;
600600-601601- while !len <= max_match_len do
602602- let len_code = m.bm_len_code in
603603- let copycode = get_copy_length_code len_code in
604604- let cmdcode = combine_length_codes inscode copycode false in
605605- let cost = dist_cost +. float_of_int (get_copy_extra copycode) +.
606606- get_command_cost model cmdcode in
607607- if cost < nodes.(pos + !len).cost then begin
608608- update_zopfli_node nodes pos start !len len_code dist 0 cost;
609609- result := max !result !len
610610- end;
611611- incr len
612612- done
613613- done
614614- end
615615- done;
616616- !result
617617-618618-(* Compute shortest path from nodes *)
619619-let compute_shortest_path_from_nodes num_bytes nodes =
620620- let index = ref num_bytes in
621621- let num_commands = ref 0 in
622622- (* Find the actual end position *)
623623- while zopfli_node_insert_length nodes.(!index) = 0 &&
624624- nodes.(!index).length = 1 && !index > 0 do
625625- decr index
626626- done;
627627- nodes.(!index).shortcut <- max_int; (* Mark as end *)
628628- while !index > 0 do
629629- let len = zopfli_node_command_length nodes.(!index) in
630630- index := !index - len;
631631- nodes.(!index).shortcut <- len; (* Use shortcut to store next length *)
632632- incr num_commands
633633- done;
634634- !num_commands
635635-636636-(* ============================================================
637637- Main Zopfli function for Q10
638638- ============================================================ *)
639639-640640-let zopfli_compute_shortest_path src src_pos num_bytes starting_dist_cache =
641641- let max_backward_limit = max_distance in
642642- let max_zopfli_len = max_zopfli_len_quality_10 in
643643- let max_iters = max_zopfli_candidates_q10 in
644644-645645- (* Initialize nodes *)
646646- let nodes = Array.init (num_bytes + 1) (fun _ -> create_zopfli_node ()) in
647647- nodes.(0).length <- 0;
648648- nodes.(0).cost <- 0.0;
649649-650650- (* Initialize cost model from literal costs (first pass) *)
651651- let model = init_cost_model_from_literals src src_pos num_bytes in
652652-653653- (* Hash table and chain *)
654654- let hash_table = Array.make hash_size (-1) in
655655- let chain_table = Array.make num_bytes (-1) in
656656- let chain_base = src_pos in
657657-658658- (* Initialize queue *)
659659- let queue = create_start_pos_queue () in
660660-661661- (* Main DP loop *)
662662- let i = ref 0 in
663663- while !i + min_match - 1 < num_bytes do
664664- let pos = src_pos + !i in
665665- let max_distance_here = min pos max_backward_limit in
666666-667667- (* Update hash table *)
668668- if pos + min_match <= src_pos + num_bytes then begin
669669- let h = hash4 src pos in
670670- let chain_idx = !i in
671671- if chain_idx < Array.length chain_table then
672672- chain_table.(chain_idx) <- hash_table.(h);
673673- hash_table.(h) <- pos
674674- end;
675675-676676- (* Find all matches *)
677677- let matches = find_all_matches src pos (src_pos + num_bytes)
678678- hash_table chain_table chain_base max_distance_here in
679679- let matches_arr = Array.of_list matches in
680680- let num_matches = Array.length matches_arr in
681681-682682- (* Check for long match to skip *)
683683- let skip =
684684- if num_matches > 0 then begin
685685- let last_match = matches_arr.(num_matches - 1) in
686686- if last_match.bm_length > max_zopfli_len then begin
687687- (* Use only longest match *)
688688- matches_arr.(0) <- last_match;
689689- last_match.bm_length
690690- end else 0
691691- end else 0
692692- in
693693-694694- let update_skip = update_nodes num_bytes src_pos !i src src_pos model
695695- max_backward_limit starting_dist_cache
696696- (if skip > 0 then 1 else num_matches) matches_arr queue nodes
697697- max_zopfli_len max_iters in
698698-699699- let actual_skip = if update_skip < brotli_long_copy_quick_step then 0 else update_skip in
700700- let skip = max skip actual_skip in
701701-702702- if skip > 1 then begin
703703- let skip_remaining = ref (skip - 1) in
704704- while !skip_remaining > 0 && !i + min_match - 1 < num_bytes do
705705- incr i;
706706- evaluate_node src_pos !i max_backward_limit starting_dist_cache model queue nodes;
707707- decr skip_remaining
708708- done
709709- end;
710710- incr i
711711- done;
712712-713713- (nodes, compute_shortest_path_from_nodes num_bytes nodes)
714714-715715-(* ============================================================
716716- HQ Zopfli function for Q11 (two passes with histogram refinement)
717717- ============================================================ *)
718718-719719-(* Build histograms from completed DP nodes for second pass cost refinement.
720720- This matches brotli-c ZopfliCostModelSetFromCommands in backward_references_hq.c *)
721721-let build_histograms_from_nodes src src_pos num_bytes nodes =
722722- let lit_histogram = Array.make 256 0 in
723723- let cmd_histogram = Array.make 704 0 in
724724- let dist_histogram = Array.make 544 0 in
725725-726726- (* Reconstruct path from nodes *)
727727- let idx = ref num_bytes in
728728- (* Find the actual end position *)
729729- while zopfli_node_insert_length nodes.(!idx) = 0 &&
730730- nodes.(!idx).length = 1 && !idx > 0 do
731731- decr idx
732732- done;
733733-734734- let pending_lit_start = ref 0 in
735735- let end_pos = !idx in
736736-737737- (* Walk backwards through the path *)
738738- idx := end_pos;
739739- let path = ref [] in
740740- while !idx > 0 do
741741- let node = nodes.(!idx) in
742742- let cmd_len = zopfli_node_command_length node in
743743- if cmd_len > 0 then begin
744744- path := !idx :: !path;
745745- idx := !idx - cmd_len
746746- end else
747747- idx := 0
748748- done;
749749-750750- (* Process path forward to count symbols *)
751751- pending_lit_start := 0;
752752- List.iter (fun end_pos ->
753753- let node = nodes.(end_pos) in
754754- let copy_len = zopfli_node_copy_length node in
755755- let _insert_len = zopfli_node_insert_length node in
756756- let dist_code = zopfli_node_distance_code node in
757757-758758- let copy_start = end_pos - copy_len in
759759- let lit_len = copy_start - !pending_lit_start in
760760-761761- (* Count literals *)
762762- for i = !pending_lit_start to copy_start - 1 do
763763- let c = Char.code (Bytes.get src (src_pos + i)) in
764764- lit_histogram.(c) <- lit_histogram.(c) + 1
765765- done;
766766-767767- (* Count command code *)
768768- let inscode = get_insert_length_code lit_len in
769769- let copycode = get_copy_length_code copy_len in
770770- let use_last = dist_code = 0 in
771771- let cmdcode = combine_length_codes inscode copycode use_last in
772772- if cmdcode < 704 then
773773- cmd_histogram.(cmdcode) <- cmd_histogram.(cmdcode) + 1;
774774-775775- (* Count distance code if explicit *)
776776- if cmdcode >= 128 then begin
777777- let dc = if dist_code < 16 then dist_code
778778- else begin
779779- let (symbol, _, _) = prefix_encode_copy_distance (node.distance + 16 - 1) in
780780- symbol
781781- end
782782- in
783783- if dc < 544 then
784784- dist_histogram.(dc) <- dist_histogram.(dc) + 1
785785- end;
786786-787787- pending_lit_start := end_pos
788788- ) !path;
789789-790790- (* Count remaining literals *)
791791- for i = !pending_lit_start to num_bytes - 1 do
792792- let c = Char.code (Bytes.get src (src_pos + i)) in
793793- lit_histogram.(c) <- lit_histogram.(c) + 1
794794- done;
795795-796796- (lit_histogram, cmd_histogram, dist_histogram)
797797-798798-let hq_zopfli_compute_shortest_path src src_pos num_bytes starting_dist_cache =
799799- let max_backward_limit = max_distance in
800800- let max_zopfli_len = max_zopfli_len_quality_11 in
801801- let max_iters = max_zopfli_candidates_q11 in
802802-803803- (* Pre-compute all matches *)
804804- let hash_table = Array.make hash_size (-1) in
805805- let chain_table = Array.make num_bytes (-1) in
806806- let chain_base = src_pos in
807807- let all_matches = Array.make num_bytes [||] in
808808- let num_matches_arr = Array.make num_bytes 0 in
809809-810810- for i = 0 to num_bytes - min_match do
811811- let pos = src_pos + i in
812812- let max_distance_here = min pos max_backward_limit in
813813-814814- (* Update hash *)
815815- if pos + min_match <= src_pos + num_bytes then begin
816816- let h = hash4 src pos in
817817- chain_table.(i) <- hash_table.(h);
818818- hash_table.(h) <- pos
819819- end;
820820-821821- let matches = find_all_matches src pos (src_pos + num_bytes)
822822- hash_table chain_table chain_base max_distance_here in
823823- let matches_arr = Array.of_list matches in
824824- all_matches.(i) <- matches_arr;
825825- num_matches_arr.(i) <- Array.length matches_arr;
826826-827827- (* Skip after very long match *)
828828- if Array.length matches_arr > 0 then begin
829829- let last = matches_arr.(Array.length matches_arr - 1) in
830830- if last.bm_length > max_zopfli_len then begin
831831- let skip = last.bm_length - 1 in
832832- for j = 1 to min skip (num_bytes - min_match - i) do
833833- all_matches.(i + j) <- [||];
834834- num_matches_arr.(i + j) <- 0
835835- done
836836- end
837837- end
838838- done;
839839-840840- (* Do two iterations with histogram refinement *)
841841- let final_nodes = ref (Array.init (num_bytes + 1) (fun _ -> create_zopfli_node ())) in
842842- let final_count = ref 0 in
843843- let first_pass_nodes = ref None in
844844-845845- for iteration = 0 to 1 do
846846- let nodes = Array.init (num_bytes + 1) (fun _ -> create_zopfli_node ()) in
847847- nodes.(0).length <- 0;
848848- nodes.(0).cost <- 0.0;
849849-850850- let model =
851851- if iteration = 0 then
852852- (* First pass: use sliding window literal cost estimation *)
853853- init_cost_model_from_literals src src_pos num_bytes
854854- else begin
855855- (* Second pass: build histograms from first pass for refined estimation *)
856856- match !first_pass_nodes with
857857- | None -> init_cost_model_from_literals src src_pos num_bytes
858858- | Some prev_nodes ->
859859- let (lit_hist, cmd_hist, dist_hist) =
860860- build_histograms_from_nodes src src_pos num_bytes prev_nodes
861861- in
862862- init_cost_model_from_histograms src src_pos num_bytes
863863- ~lit_histogram:lit_hist ~cmd_histogram:cmd_hist ~dist_histogram:dist_hist
864864- end
865865- in
866866-867867- let queue = create_start_pos_queue () in
868868-869869- (* Main DP loop *)
870870- let i = ref 0 in
871871- while !i + min_match - 1 < num_bytes do
872872- let skip = update_nodes num_bytes src_pos !i src src_pos model
873873- max_backward_limit starting_dist_cache
874874- num_matches_arr.(!i) all_matches.(!i) queue nodes
875875- max_zopfli_len max_iters in
876876-877877- let skip = if skip < brotli_long_copy_quick_step then 0 else skip in
878878-879879- if skip > 1 then begin
880880- let skip_remaining = ref (skip - 1) in
881881- while !skip_remaining > 0 && !i + min_match - 1 < num_bytes do
882882- incr i;
883883- evaluate_node src_pos !i max_backward_limit starting_dist_cache model queue nodes;
884884- decr skip_remaining
885885- done
886886- end;
887887- incr i
888888- done;
889889-890890- (* Save first pass nodes for histogram building *)
891891- if iteration = 0 then begin
892892- let _ = compute_shortest_path_from_nodes num_bytes nodes in
893893- first_pass_nodes := Some nodes
894894- end;
895895-896896- final_nodes := nodes;
897897- final_count := compute_shortest_path_from_nodes num_bytes nodes
898898- done;
899899-900900- (!final_nodes, !final_count)
901901-902902-(* ============================================================
903903- Create commands from Zopfli nodes
904904- ============================================================ *)
905905-906906-let zopfli_create_commands num_bytes src_pos nodes =
907907- let commands = ref [] in
908908- let ring = Lz77.create_dist_ring () in
909909-910910- (* First, reconstruct the path using shortcut field *)
911911- let path = ref [] in
912912- let idx = ref num_bytes in
913913- while !idx > 0 && nodes.(!idx).shortcut <> max_int do
914914- path := !idx :: !path;
915915- let len = nodes.(!idx).shortcut in
916916- if len > 0 && len <= !idx then
917917- idx := !idx - len
918918- else
919919- idx := 0
920920- done;
921921-922922- (* Now process each command in the path *)
923923- let pending_lit_start = ref 0 in
924924- List.iter (fun end_pos ->
925925- let node = nodes.(end_pos) in
926926- let copy_len = zopfli_node_copy_length node in
927927- let _insert_len = zopfli_node_insert_length node in
928928- let distance = zopfli_node_copy_distance node in
929929- let dist_code = zopfli_node_distance_code node in
930930-931931- let copy_start = end_pos - copy_len in
932932- let lit_len = copy_start - !pending_lit_start in
933933-934934- (* Determine short code *)
935935- let short_code =
936936- if dist_code < 16 then Some dist_code
937937- else None
938938- in
939939-940940- commands := Lz77.InsertCopy {
941941- lit_start = src_pos + !pending_lit_start;
942942- lit_len;
943943- copy_len;
944944- distance;
945945- dist_code = short_code;
946946- } :: !commands;
947947-948948- (* Update ring buffer *)
949949- (match short_code with
950950- | Some 0 -> ()
951951- | _ -> Lz77.push_distance ring distance);
952952-953953- pending_lit_start := end_pos
954954- ) !path;
955955-956956- (* Handle remaining literals *)
957957- if !pending_lit_start < num_bytes then
958958- commands := Lz77.Literals {
959959- start = src_pos + !pending_lit_start;
960960- len = num_bytes - !pending_lit_start
961961- } :: !commands;
962962-963963- List.rev !commands
964964-965965-(* ============================================================
966966- Public API
967967- ============================================================ *)
968968-969969-let generate_commands ?(quality=11) src src_pos src_len =
970970- if src_len = 0 then []
971971- else if src_len < min_match then
972972- [Lz77.Literals { start = src_pos; len = src_len }]
973973- else begin
974974- let starting_dist_cache = [| 16; 15; 11; 4 |] in
975975-976976- let (nodes, _num_commands) =
977977- if quality >= 11 then
978978- hq_zopfli_compute_shortest_path src src_pos src_len starting_dist_cache
979979- else
980980- zopfli_compute_shortest_path src src_pos src_len starting_dist_cache
981981- in
982982-983983- zopfli_create_commands src_len src_pos nodes
984984- end