···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