├── src ├── qoic.mllib ├── qoic.mli └── qoic.ml ├── BRZO ├── .merlin ├── images └── README.md ├── .gitignore ├── .ocp-indent ├── CHANGES.md ├── _tags ├── doc └── index.mld ├── pkg ├── META └── pkg.ml ├── DEVEL.md ├── LICENSE.md ├── README.md ├── opam ├── test ├── example.ml ├── bigfile.mli ├── bigfile.ml └── trip.ml └── B0.ml /src/qoic.mllib: -------------------------------------------------------------------------------- 1 | Qoic -------------------------------------------------------------------------------- /BRZO: -------------------------------------------------------------------------------- 1 | (srcs-x pkg tmp) -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG b0.kit unix 2 | S src 3 | S test 4 | B _b0/** -------------------------------------------------------------------------------- /images/README.md: -------------------------------------------------------------------------------- 1 | See [`../DEVEL.md`](../DEVEL.md). 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _b0 2 | _build 3 | tmp 4 | *.install 5 | images/*.qoi -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | strict_with=always,match_clause=4,strict_else=never -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | v0.1.0 YYYY-MM-DD Loc 2 | ------------------------ 3 | 4 | First release. 5 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string 2 | 3 | <_b0> : -traverse 4 | : include 5 | : package(unix) 6 | : package(b0.std) -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Qoic {%html: %%VERSION%%%}} 2 | 3 | Qoic encodes and decodes {{:https://qoiformat.org/}QOI images}. 4 | 5 | {1:api API} 6 | 7 | {!modules: 8 | Qoic 9 | } 10 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "QOI codec for OCaml" 2 | version = "%%VERSION_NUM%%" 3 | requires = "" 4 | archive(byte) = "qoic.cma" 5 | archive(native) = "qoic.cmxa" 6 | plugin(byte) = "qoic.cma" 7 | plugin(native) = "qoic.cmxs" 8 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let () = 7 | Pkg.describe "qoic" @@ fun c -> 8 | Ok [ Pkg.mllib "src/qoic.mllib"; 9 | Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld"; 10 | Pkg.test "test/trip"; 11 | Pkg.test "test/example"; ] 12 | -------------------------------------------------------------------------------- /DEVEL.md: -------------------------------------------------------------------------------- 1 | # Downloading test images 2 | 3 | To download the specification test images to the [`images`](images/) directory 4 | issue: 5 | 6 | ``` 7 | b0 -- download-spec-images 8 | ``` 9 | 10 | # Test image round tripping 11 | 12 | To round trip the images 13 | 14 | ```sh 15 | b0 -- trip # Round trip images from images/ 16 | b0 -- trip [FILE.qoi]… # Round trip given images. 17 | ``` 18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2021 The qoic programmers 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | qoic — QOI image codec for OCaml 2 | ================================ 3 | %%VERSION%% 4 | 5 | Qoic encodes and decodes [QOI images][qoi]. 6 | 7 | Qoic is distributed under the ISC license. It has no dependencies. 8 | 9 | [qoi]: https://qoiformat.org/ 10 | 11 | Homepage: 12 | 13 | # Installation 14 | 15 | Qoic can be installed with `opam`: 16 | 17 | opam install qoic 18 | 19 | If you don't use `opam` consult the [`opam`](opam) file for build 20 | instructions. 21 | 22 | # Documentation 23 | 24 | The documentation can be consulted [online][doc] or via `odig doc qoic`. 25 | 26 | Questions are welcome but better asked on the [OCaml forum][ocaml-forum] 27 | than on the issue tracker. 28 | 29 | [doc]: https://erratique.ch/software/qoic/doc 30 | [ocaml-forum]: https://discuss.ocaml.org/ 31 | 32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "qoic" 3 | synopsis: """QOI image codec for OCaml""" 4 | maintainer: ["Daniel Bünzli "] 5 | authors: ["The qoic programmers"] 6 | homepage: "https://erratique.ch/software/qoic" 7 | doc: "https://erratique.ch/software/qoic/doc" 8 | dev-repo: "git+https://erratique.ch/repos/qoic.git" 9 | bug-reports: "https://github.com/dbuenzli/qoic/issues" 10 | license: ["ISC"] 11 | tags: ["codec" "qoi" "image" "org:erratique"] 12 | depends: ["ocaml" {>= "4.12.0"} 13 | "ocamlfind" {build} 14 | "ocamlbuild" {build}] 15 | build: [["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"]] 16 | description: """ 17 | Qoic encodes and decodes [QOI images][qoi]. 18 | 19 | Qoic is distributed under the ISC license. It has no dependencies. 20 | 21 | [qoi]: https://qoiformat.org/ 22 | 23 | Homepage: """ 24 | -------------------------------------------------------------------------------- /test/example.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2021 The qoic programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | let recode ?channels file ~dst = 7 | let ( let* ) = Result.bind in 8 | let* bytes = Bigfile.read file in 9 | let* meta, pixels = Qoic.decode' ?channels bytes in 10 | Bigfile.write dst (Qoic.encode meta pixels) 11 | 12 | (*--------------------------------------------------------------------------- 13 | Copyright (c) 2021 The qoic programmers 14 | 15 | Permission to use, copy, modify, and/or distribute this software for any 16 | purpose with or without fee is hereby granted, provided that the above 17 | copyright notice and this permission notice appear in all copies. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 20 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 21 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 22 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 23 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 24 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 25 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 26 | ---------------------------------------------------------------------------*) 27 | -------------------------------------------------------------------------------- /test/bigfile.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2021 The qoic programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | type fpath = string 7 | type bigbytes = 8 | (int, Stdlib.Bigarray.int8_unsigned_elt, Stdlib.Bigarray.c_layout) 9 | Stdlib.Bigarray.Array1.t 10 | 11 | val read : fpath -> (bigbytes, string) result 12 | val write : fpath -> bigbytes -> (unit, string) result 13 | 14 | (*--------------------------------------------------------------------------- 15 | Copyright (c) 2021 The qoic programmers 16 | 17 | Permission to use, copy, modify, and/or distribute this software for any 18 | purpose with or without fee is hereby granted, provided that the above 19 | copyright notice and this permission notice appear in all copies. 20 | 21 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 22 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 23 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 24 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 25 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 26 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 27 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 28 | ---------------------------------------------------------------------------*) 29 | -------------------------------------------------------------------------------- /test/bigfile.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2021 The qoic programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | type fpath = string 7 | 8 | type bigbytes = 9 | (int, Stdlib.Bigarray.int8_unsigned_elt, Stdlib.Bigarray.c_layout) 10 | Stdlib.Bigarray.Array1.t 11 | 12 | let map_bytes ?(len = -1) ~write fd = 13 | let t = Stdlib.Bigarray.int8_unsigned and l = Bigarray.C_layout in 14 | Stdlib.Bigarray.array1_of_genarray (Unix.map_file fd t l write [|len|]) 15 | 16 | let error f e = Error (Printf.sprintf "%s: %s" f (Unix.error_message e)) 17 | 18 | let read file = 19 | try 20 | let fd = Unix.openfile file Unix.[O_RDONLY] 0x600 in 21 | let finally () = try Unix.close fd with Unix.Unix_error _ -> () in 22 | Fun.protect ~finally @@ fun () -> Ok (map_bytes ~write:false fd) 23 | with 24 | | Unix.Unix_error (e, _, _) -> error file e 25 | 26 | let write file bytes = 27 | try 28 | let fd = Unix.openfile file Unix.[O_CREAT; O_RDWR; O_TRUNC] 0o644 in 29 | let finally () = try Unix.close fd with Unix.Unix_error _ -> () in 30 | Fun.protect ~finally @@ fun () -> 31 | let len = Stdlib.Bigarray.Array1.dim bytes in 32 | let dst = map_bytes ~len ~write:true fd in 33 | Ok (Stdlib.Bigarray.Array1.blit bytes dst) 34 | with 35 | | Unix.Unix_error (e, _, _) -> error file e 36 | 37 | (*--------------------------------------------------------------------------- 38 | Copyright (c) 2021 The qoic programmers 39 | 40 | Permission to use, copy, modify, and/or distribute this software for any 41 | purpose with or without fee is hereby granted, provided that the above 42 | copyright notice and this permission notice appear in all copies. 43 | 44 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 45 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 46 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 47 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 48 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 49 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 50 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 51 | ---------------------------------------------------------------------------*) 52 | -------------------------------------------------------------------------------- /B0.ml: -------------------------------------------------------------------------------- 1 | open B0_kit.V000 2 | open Result.Syntax 3 | 4 | (* OCaml library names *) 5 | 6 | let qoic = B0_ocaml.libname "qoic" 7 | let unix = B0_ocaml.libname "unix" 8 | let b0_std = B0_ocaml.libname "b0.std" 9 | 10 | (* Libraries *) 11 | 12 | let qoic_lib = 13 | let srcs = Fpath.[ `Dir (v "src") ] in 14 | let requires = [] in 15 | B0_ocaml.lib qoic ~doc:"Qoic library" ~srcs ~requires 16 | 17 | (* Tests *) 18 | 19 | let test_src f = `File (Fpath.v (Fmt.str "test/%s" f)) 20 | let bigfile_srcs = [test_src "bigfile.mli"; test_src "bigfile.ml" ] 21 | 22 | let test = 23 | let srcs = test_src "trip.ml" :: bigfile_srcs in 24 | let requires = [ b0_std; qoic; unix ] in 25 | let meta = 26 | B0_meta.empty 27 | |> B0_meta.(tag test) 28 | |> B0_meta.add B0_unit.Action.cwd `Scope_dir 29 | in 30 | let doc = "Round trip QOI images" in 31 | B0_ocaml.exe "trip" ~doc ~meta ~srcs ~requires 32 | 33 | let example = 34 | let srcs = test_src "example.ml" :: bigfile_srcs in 35 | let requires = [ qoic; unix ] in 36 | let meta = B0_meta.empty |> B0_meta.tag B0_meta.test in 37 | let doc = "Sample code" in 38 | B0_ocaml.exe "example" ~doc ~meta ~srcs ~requires 39 | 40 | (* Packs *) 41 | 42 | let default = 43 | let meta = 44 | B0_meta.empty 45 | |> B0_meta.(add authors) ["The qoic programmers"] 46 | |> B0_meta.(add maintainers) 47 | ["Daniel Bünzli "] 48 | |> B0_meta.(add homepage) "https://erratique.ch/software/qoic" 49 | |> B0_meta.(add online_doc) "https://erratique.ch/software/qoic/doc" 50 | |> B0_meta.(add licenses) ["ISC"] 51 | |> B0_meta.(add repo) "git+https://erratique.ch/repos/qoic.git" 52 | |> B0_meta.(add issues) "https://github.com/dbuenzli/qoic/issues" 53 | |> B0_meta.(add description_tags) ["codec"; "qoi"; "image"; "org:erratique"] 54 | |> B0_meta.tag B0_opam.tag 55 | |> B0_meta.add B0_opam.build 56 | {|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%"]]|} 57 | |> B0_meta.add B0_opam.depends 58 | [ "ocaml", {|>= "4.12.0"|}; 59 | "ocamlfind", {|build|}; 60 | "ocamlbuild", {|build|}; ] 61 | in 62 | B0_pack.make "default" ~doc:"qoic package" ~meta ~locked:true @@ 63 | B0_unit.list () 64 | 65 | (* Actions *) 66 | 67 | let spec_images = 68 | let doc = "Download specification test images" in 69 | B0_unit.of_action "download-spec-images" ~doc @@ 70 | fun env _ ~args -> 71 | let src = "https://qoiformat.org/qoi_test_images.zip" in 72 | let dst = B0_env.in_scope_dir env (Fpath.v "images") in 73 | let* curl = B0_env.get_cmd env (Cmd.arg "curl") in 74 | let* unzip = B0_env.get_cmd env (Cmd.arg "unzip") in 75 | let* tmp_zip = Os.Path.tmp ~name:"tmp-%s.zip" () in 76 | let* () = 77 | let outf = Os.Cmd.out_file ~force:true ~make_path:false tmp_zip in 78 | Os.Cmd.run ~stdout:outf Cmd.(curl % "-L" % src) 79 | in 80 | Os.Cmd.run @@ 81 | Cmd.(unzip % "-j" % "-o" %% path tmp_zip % "*.qoi" % "-d" %% path dst) 82 | -------------------------------------------------------------------------------- /test/trip.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2021 The qoic programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open B0_std 7 | open Result.Syntax 8 | 9 | let green = Fmt.st [`Fg `Green] 10 | let red = Fmt.st [`Fg `Red] 11 | let log = Format.printf 12 | let log_trip_ok () = log " %a@." green "OK" 13 | let log_trip_error e = log "@\n%a: %s@\n@." red "Error" e 14 | let log_final_result span n fail = 15 | let pp_span = Mtime.Span.pp in 16 | if fail <> 0 17 | then log "[%a] %d out of %d files did not round trip.@." red "FAIL" fail n 18 | else log "[ %a ] All %d file(s) round trip in %a.@." green "OK" n pp_span span 19 | 20 | let hexdump ~dst bytes = 21 | let bytes_dump = Fpath.(dst + ".bytes") in 22 | let* xxd = Os.Cmd.get Cmd.(arg "xxd") in 23 | let* () = Bigfile.write (Fpath.to_string bytes_dump) bytes in 24 | let* () = Os.Cmd.run Cmd.(xxd %% path bytes_dump %% path dst) in 25 | Ok dst 26 | 27 | let diff file spec_bytes qoic_bytes = 28 | Result.retract @@ Result.join @@ Os.Dir.with_tmp @@ fun dir -> 29 | let* diff = 30 | let color = match Fmt.styler () with 31 | | Fmt.Plain -> "--color=never" 32 | | Fmt.Ansi -> "--color=always" 33 | in 34 | Os.Cmd.get Cmd.(arg "git" % "diff" % "--no-index" % "--patience" % color) 35 | in 36 | let base = Fpath.(dir / basename file) in 37 | let* spec_hex = hexdump ~dst:Fpath.(base + ".spec") spec_bytes in 38 | let* qoic_hex = hexdump ~dst:Fpath.(base + ".qoic") qoic_bytes in 39 | let diff = Cmd.(diff % Fpath.basename spec_hex % Fpath.basename qoic_hex) in 40 | Result.map snd (Os.Cmd.run_status_out ~trim:false ~cwd:dir diff) 41 | 42 | let trip file = 43 | log "Trip %a@?" Fpath.pp_unquoted file; 44 | let* bytes = Bigfile.read (Fpath.to_string file) in 45 | let* meta, pixels = Qoic.decode' bytes in 46 | log " %a@?" Qoic.Meta.pp meta; 47 | let bytes' = Qoic.encode meta pixels in 48 | if bytes <> bytes' then 49 | let outf = Fpath.to_string Fpath.(file -+ "-notrip.qoi") in 50 | let* () = Bigfile.write outf bytes' in 51 | Error ("\n" ^ diff file bytes bytes') 52 | else Ok () 53 | 54 | let default_files () = 55 | let default_dir = Fpath.v "images" in 56 | let* fs = Os.Dir.fold_files ~recurse:true Os.Dir.path_list default_dir [] in 57 | Ok (List.rev (List.filter (Fpath.has_ext ".qoi") fs)) 58 | 59 | let trips files = 60 | Log.if_error ~use:1 @@ 61 | let* files = match files with [] -> default_files () | files -> Ok files in 62 | let rec loop t n fail = function 63 | | [] -> log_final_result (Os.Mtime.count t) n fail; Ok fail 64 | | f :: fs -> 65 | match trip f with 66 | | Error e -> log_trip_error e; loop t (n + 1) (fail + 1) fs 67 | | Ok () -> log_trip_ok (); loop t (n + 1) fail fs 68 | in 69 | loop (Os.Mtime.counter ()) 0 0 files 70 | 71 | let main () = 72 | let usage = "Usage: trip [FILE.qoi]…" in 73 | let rev_files = ref [] in 74 | let pos s = rev_files := Fpath.v s :: !rev_files in 75 | Arg.parse [] pos usage; 76 | trips (List.rev !rev_files) 77 | 78 | let () = if !Sys.interactive then () else exit (main ()) 79 | 80 | (*--------------------------------------------------------------------------- 81 | Copyright (c) 2021 The qoic programmers 82 | 83 | Permission to use, copy, modify, and/or distribute this software for any 84 | purpose with or without fee is hereby granted, provided that the above 85 | copyright notice and this permission notice appear in all copies. 86 | 87 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 88 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 89 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 90 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 91 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 92 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 93 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 94 | ---------------------------------------------------------------------------*) 95 | -------------------------------------------------------------------------------- /src/qoic.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2021 The qoic programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** QOI image codec. 7 | 8 | Encodes and decodes {{:https://qoiformat.org/}QOI images}. 9 | 10 | See the {{!limitations}limitations} and an {{!example}example}. *) 11 | 12 | (** {1:meta Image metadata} *) 13 | 14 | type color_space = [ `Srgb | `Linear ] 15 | (** The type for color spaces. *) 16 | 17 | type channels = [ `Rgb | `Rgba ] 18 | (** The type for image channels. *) 19 | 20 | val channel_count : channels -> int 21 | (** [channel_count c] is the number of channels in [c]. *) 22 | 23 | (** Image metadata. *) 24 | module Meta : sig 25 | type t 26 | (** The type for image metadata. *) 27 | 28 | val v : color_space -> channels -> w:int -> h:int -> t 29 | (** [v] is image metadata with the given parameters. See accessors for 30 | semantics. 31 | 32 | Raises [Invalid_argument] if [w] or [h] are not in the range of 33 | unsigned 32-bit integers. *) 34 | 35 | val w : t -> int 36 | (** [w m] is the image width in pixels. *) 37 | 38 | val h : t -> int 39 | (** [h m] is the image height in pixels. *) 40 | 41 | val channels : t -> channels 42 | (** [channels m] are the image's channels. *) 43 | 44 | val color_space : t -> color_space 45 | (** [color_space m] is the image's colorspace. *) 46 | 47 | val pixels_byte_length : t -> int option 48 | (** [pixels_byte_length m] is the number of bytes needed to store 49 | the pixels of an image described by [m]. This is [None] if [w m * 50 | h m * channel_count (channels m)] overflows. *) 51 | 52 | val encodable : t -> bool 53 | (** [encodable m] is [true] iff [m] can be encoded by Qoic. This just 54 | checks that the allocated encoding buffer length does not overflow. *) 55 | 56 | val pp : Format.formatter -> t -> unit 57 | (** [pp ppf m] formats an unspecified representation of [m] on [ppf]. *) 58 | end 59 | 60 | (** {1:bytes_pixels Bytes and pixel data} *) 61 | 62 | type uint32 = int32 63 | (** The type for unsigned 32-bit integers. *) 64 | 65 | (** Bigarrays of bytes. *) 66 | module Bigbytes : sig 67 | type t = 68 | (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 69 | (** The type for bigarrays of bytes. *) 70 | 71 | val create : len:int -> init:int -> t 72 | (** [create ~len ~init] is a bigarray of bytes of length [len] filled 73 | with byte [init]. *) 74 | 75 | val length : t -> int 76 | (** [length b] is the length of [b]. *) 77 | 78 | val get : t -> int -> int 79 | (** [get b i] is the byte at index [i] of [b]. *) 80 | 81 | val set : t -> int -> int -> unit 82 | (** [set b i v] sets the byte at index [i] of [b] to [v]. *) 83 | 84 | val get_uint32_be : t -> int -> uint32 85 | (** [get b i] is the big endian unsigned 32-bit integer at byte index [i] 86 | of [b]. *) 87 | 88 | val set_uint32_be : t -> int -> uint32 -> unit 89 | (** [set b i v] sets the big endian unsigned 32-bit integer at byte index [i] 90 | of [b] to [v]. *) 91 | end 92 | 93 | type pixels = Bigbytes.t 94 | (** The type for pixel data. 95 | 96 | Pixels are stored in a linear buffer, line-by-line, from left to 97 | right and top to bottom in RGB or RGBA order with one byte per 98 | component. *) 99 | 100 | (** {1:encoding Encoding} *) 101 | 102 | val encode : Meta.t -> pixels -> Bigbytes.t 103 | (** [encode m p] is the encoding of pixels [p] described by [m]. 104 | 105 | Raises [Invalid_argument] if [Meta.pixels_byte_length m] does not 106 | match [p]'s length or if [Meta.encodable m] is [false]. *) 107 | 108 | (** {1:decoding Decoding} *) 109 | 110 | (** Decoding errors. *) 111 | module Error : sig 112 | type kind = 113 | | Image_too_large of uint32 * uint32 114 | | Invalid_channels of int 115 | | Invalid_color_space of int 116 | | Invalid_end_marker 117 | | Invalid_image 118 | | Not_a_qoi_file 119 | | Truncated_chunk_stream (** *) 120 | (** The type for kinds of decoding errors. *) 121 | 122 | val pp_kind : Format.formatter -> kind -> unit 123 | (** [pp_kind ppf k] formats [k] in english on [ppf]. *) 124 | 125 | type t = kind * int 126 | (** The type for errors. The kind of error and the byte offset where it 127 | occured. *) 128 | 129 | val pp : Format.formatter -> t -> unit 130 | (** [pp ppf e] formats [e] in english on [ppf]. *) 131 | 132 | val to_string : t -> string 133 | (** [to_string e] is an english error message for [e]. *) 134 | end 135 | 136 | val decode : 137 | ?channels:channels -> Bigbytes.t -> (Meta.t * pixels, Error.t) result 138 | (** [decode ~channels b] decodes a QOI image from [b]. 139 | 140 | If [channels] is [Some c], forces the channels of the resulting 141 | metadata and pixels to be [c]. An [`Rgb] image forced to 142 | [`Rgba] gets a constant [0xFF] alpha channel and an [`Rgba] image forced 143 | to [`Rgb] drops the alpha channel. *) 144 | 145 | val decode' : 146 | ?channels:channels -> Bigbytes.t -> (Meta.t * pixels, string) result 147 | (** [decode' b] is [Result.map_error Error.to_string (decode b)]. *) 148 | 149 | val decode_meta : Bigbytes.t -> (Meta.t, Error.t) result 150 | (** [decode_meta b] decodes QOI image metadata from [b]. *) 151 | 152 | (** {1:limitations Limitations} 153 | 154 | {ul 155 | {- [int]s are used for the image size and indexing pixel components in 156 | bigarrays of bytes. On 32-bit platforms, this limits images 157 | to around 536 millions pixels (23k x 23k) for RGBA.} 158 | {- The codec is not streaming. It encodes and decodes to memory.}} 159 | 160 | {1:example Example} 161 | 162 | The [Stdlib] (at least until 4.14) does not provide a simple interface to 163 | interface bigarrays with files. Assume we have a module 164 | with the following interface (see below for an 165 | implementation): 166 | {[ 167 | module Bigfile : sig 168 | type fpath = string 169 | type bigbytes = 170 | (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 171 | 172 | val read : fpath -> (bigbytes, string) result 173 | val write : fpath -> bigbytes -> (unit, string) result 174 | end 175 | ]} 176 | The following function recodes a QOI file with {!Qoic}: 177 | {[ 178 | let recode ?channels file ~dst = 179 | let ( let* ) = Result.bind in 180 | let* bytes = Bigfile.read file in 181 | let* meta, pixels = Qoic.decode' ?channels bytes in 182 | Bigfile.write dst (Qoic.encode meta pixels) 183 | ]} 184 | 185 | The [Bigfile] module can be implemented by: 186 | {[ 187 | module Bigfile = struct 188 | type fpath = string 189 | type bigbytes = 190 | (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t 191 | 192 | let map_bytes ?(len = -1) ~write fd = 193 | let t = Bigarray.int8_unsigned and l = Bigarray.C_layout in 194 | Bigarray.array1_of_genarray (Unix.map_file fd t l write [|len|]) 195 | 196 | let error f e = Error (Printf.sprintf "%s: %s" f (Unix.error_message e)) 197 | 198 | let read file = 199 | try 200 | let fd = Unix.openfile file Unix.[O_RDONLY] 0x600 in 201 | let finally () = try Unix.close fd with Unix.Unix_error _ -> () in 202 | Fun.protect ~finally @@ fun () -> Ok (map_bytes ~write:false fd) 203 | with 204 | | Unix.Unix_error (e, _, _) -> error file e 205 | 206 | let write file bytes = 207 | try 208 | let fd = Unix.openfile file Unix.[O_CREAT; O_RDWR; O_TRUNC] 0o644 in 209 | let finally () = try Unix.close fd with Unix.Unix_error _ -> () in 210 | Fun.protect ~finally @@ fun () -> 211 | let dst = map_bytes ~len:(Bigarray.Array1.dim bytes) ~write:true fd in 212 | Ok (Bigarray.Array1.blit bytes dst) 213 | with 214 | | Unix.Unix_error (e, _, _) -> error file e 215 | end 216 | ]} 217 | *) 218 | 219 | (*--------------------------------------------------------------------------- 220 | Copyright (c) 2021 The qoic programmers 221 | 222 | Permission to use, copy, modify, and/or distribute this software for any 223 | purpose with or without fee is hereby granted, provided that the above 224 | copyright notice and this permission notice appear in all copies. 225 | 226 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 227 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 228 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 229 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 230 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 231 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 232 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 233 | ---------------------------------------------------------------------------*) 234 | -------------------------------------------------------------------------------- /src/qoic.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2021 The qoic programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* Programming errors. *) 7 | 8 | let strf = Printf.sprintf 9 | let err_img_too_large = "Image too large to be encoded" 10 | let err_img_size w h = strf "Invalid image size: %dx%d" w h 11 | let err_byte_size isize bsize = 12 | let isize = match isize with None -> "overflow" | Some s -> string_of_int s in 13 | strf "Image byte size (%s) does not match buffer size (%d)" isize bsize 14 | 15 | (* Integer fiddling *) 16 | 17 | type uint32 = int32 18 | let int_is_uint32 u = 0 <= u && Int64.(compare (of_int u) 4294967295L) <= 0 19 | 20 | let shift8 = Sys.word_size - 9 21 | let[@inline] int8_of_uint8_bits v = (v lsl shift8) asr shift8 22 | 23 | (* Bigarrays of bytes *) 24 | 25 | module Bigbytes = struct 26 | type t = (int,Bigarray.int8_unsigned_elt,Bigarray.c_layout) Bigarray.Array1.t 27 | 28 | let _create len = Bigarray.(Array1.create int8_unsigned c_layout len) 29 | let create ~len ~init:v = let a = _create len in Bigarray.Array1.fill a v; a 30 | let length b = Bigarray.Array1.dim b 31 | 32 | let[@inline] get b i = (Bigarray.Array1.get : t -> int -> int) b i 33 | let[@inline] set b i v = (Bigarray.Array1.set : t -> int -> int -> unit) b i v 34 | 35 | external swap_32 : int32 -> int32 = "%bswap_int32" 36 | external get_uint32_ne : t -> int -> uint32 = "%caml_bigstring_get32" 37 | external set_uint32_ne : t -> int -> uint32 -> unit = "%caml_bigstring_set32" 38 | 39 | let[@inline] get_uint32_be b i = 40 | if Sys.big_endian 41 | then get_uint32_ne b i 42 | else swap_32 (get_uint32_ne b i) 43 | 44 | let[@inline] set_uint32_be b i v = 45 | if Sys.big_endian 46 | then set_uint32_ne b i v 47 | else set_uint32_ne b i (swap_32 v) 48 | 49 | let resize b ~len = Bigarray.Array1.sub b 0 len 50 | end 51 | 52 | type pixels = Bigbytes.t 53 | 54 | (* QOI constants *) 55 | 56 | let qoi_magic = 0x716f6966l (* "qoif" *) 57 | let qoi_header_length = 14 58 | let qoi_end_marker_length = 8 59 | let qoi_op_mask = 0xc0 60 | let qoi_op_index = 0x00 61 | let qoi_op_diff = 0x40 62 | let qoi_op_luma = 0x80 63 | let qoi_op_run = 0xc0 64 | let qoi_op_rgb = 0xfe 65 | let qoi_op_rgba = 0xff 66 | 67 | (* Image metadata *) 68 | 69 | type color_space = [ `Srgb | `Linear ] 70 | type channels = [ `Rgb | `Rgba ] 71 | let channel_count = function `Rgb -> 3 | `Rgba -> 4 72 | 73 | module Meta = struct 74 | type t = 75 | { w : int; h : int; 76 | channels : channels; 77 | color_space : color_space; } 78 | 79 | let v color_space channels ~w ~h = 80 | if not (int_is_uint32 w) || not (int_is_uint32 h) 81 | then invalid_arg (err_img_size w h) 82 | else { w; h; channels; color_space } 83 | 84 | let w m = m.w 85 | let h m = m.h 86 | let color_space m = m.color_space 87 | let channels m = m.channels 88 | let pixels_byte_length m = 89 | let count = m.w * m.h * channel_count m.channels in 90 | if count < m.w || count < m.h then None (* overflow *) else Some count 91 | 92 | let encoding_buffer_byte_length m = 93 | let pixel_count = m.w * m.h in 94 | let count = pixel_count * channel_count m.channels in 95 | if count < pixel_count || count < pixel_count then None (* overflow *) else 96 | let l = count + pixel_count + qoi_header_length + qoi_end_marker_length in 97 | if l < count then None else Some l 98 | 99 | let encodable m = Option.is_some (encoding_buffer_byte_length m) 100 | 101 | let samples_descr m = match m.color_space, m.channels with 102 | | `Srgb, `Rgb -> "sRGB" 103 | | `Srgb, `Rgba -> "sRGBA" 104 | | `Linear, `Rgb -> "linear RGB" 105 | | `Linear, `Rgba -> "linear RGBA" 106 | 107 | let pp ppf m = Format.fprintf ppf "%dx%d %s" m.w m.h (samples_descr m) 108 | end 109 | 110 | (* Pixel index *) 111 | 112 | module Index = struct 113 | let create () = Array.make (64 * 4) 0 114 | let[@inline] get a i = Array.get a i 115 | let[@inline] set a i v = Array.set a i v 116 | 117 | let[@inline] color_idx r g b a = (r * 3 + g * 5 + b * 7 + a * 11) mod 64 118 | let[@inline] color_idx_pos idx = idx * 4 119 | let[@inline] set index ~color_idx r g b a = 120 | let k = color_idx_pos color_idx in 121 | set index k r; set index (k + 1) g; 122 | set index (k + 2) b; set index (k + 3) a 123 | 124 | let[@inline] get_r index ~color_idx_pos:k = get index k 125 | let[@inline] get_g index ~color_idx_pos:k = get index (k + 1) 126 | let[@inline] get_b index ~color_idx_pos:k = get index (k + 2) 127 | let[@inline] get_a index ~color_idx_pos:k = get index (k + 3) 128 | end 129 | 130 | (* Encoding *) 131 | 132 | let check_length_match m p = 133 | let plen = Bigbytes.length p in 134 | match Meta.pixels_byte_length m with 135 | | None -> invalid_arg (err_byte_size None plen) 136 | | Some mlen as l -> if mlen <> plen then invalid_arg (err_byte_size l plen) 137 | 138 | let encode_header dst m = 139 | Bigbytes.set_uint32_be dst 0 qoi_magic; 140 | Bigbytes.set_uint32_be dst 4 (Int32.of_int (Meta.w m)); 141 | Bigbytes.set_uint32_be dst 8 (Int32.of_int (Meta.h m)); 142 | Bigbytes.set dst 12 (match Meta.channels m with `Rgb -> 3 | `Rgba -> 4); 143 | Bigbytes.set dst 13 (match Meta.color_space m with `Srgb -> 0 | `Linear -> 1) 144 | 145 | let encode_padding_and_finish dst i = 146 | Bigbytes.set_uint32_be dst i 0x00l; 147 | Bigbytes.set_uint32_be dst (i + 4) 0x01l; 148 | Bigbytes.resize dst ~len:(i + 8) 149 | 150 | let encode_pixels src ~channels dst = 151 | let p_max = Bigbytes.length src - 1 in 152 | let index = Index.create () in 153 | let rec loop run i p r g b a = 154 | if p > p_max then encode_padding_and_finish dst i else 155 | let nr = Bigbytes.get src (p ) in 156 | let ng = Bigbytes.get src (p + 1) in 157 | let nb = Bigbytes.get src (p + 2) in 158 | let na = if channels = 4 then Bigbytes.get src (p + 3) else a in 159 | let p = p + channels in 160 | if r = nr && g = ng && b = nb && a = na then 161 | let run = run + 1 in 162 | if not (run = 62 || p > p_max) then loop run i p r g b a else 163 | let op = qoi_op_run lor (run - 1) in 164 | Bigbytes.set dst i op; 165 | (loop[@tailcall]) 0 (i + 1) p r g b a 166 | else 167 | let i = 168 | if run = 0 then i else 169 | let op = qoi_op_run lor (run - 1) in 170 | Bigbytes.set dst i op; i + 1 171 | in 172 | let color_idx = Index.color_idx nr ng nb na in 173 | let color_idx_pos = Index.color_idx_pos color_idx in 174 | let ir = Index.get_r index ~color_idx_pos in 175 | let ig = Index.get_g index ~color_idx_pos in 176 | let ib = Index.get_b index ~color_idx_pos in 177 | let ia = Index.get_a index ~color_idx_pos in 178 | if ir = nr && ig = ng && ib = nb && ia = na then 179 | let op = qoi_op_index lor color_idx in 180 | Bigbytes.set dst i op; 181 | (loop[@tailcall]) 0 (i + 1) p nr ng nb na 182 | else 183 | let () = Index.set index ~color_idx nr ng nb na in 184 | if a <> na then 185 | (Bigbytes.set dst i qoi_op_rgba; 186 | Bigbytes.set dst (i + 1) nr; 187 | Bigbytes.set dst (i + 2) ng; 188 | Bigbytes.set dst (i + 3) nb; 189 | Bigbytes.set dst (i + 4) na; 190 | (loop[@tailcall]) 0 (i + 5) p nr ng nb na) 191 | else 192 | let dr = int8_of_uint8_bits ((nr - r) land 0xFF) in 193 | let dg = int8_of_uint8_bits ((ng - g) land 0xFF) in 194 | let db = int8_of_uint8_bits ((nb - b) land 0xFF) in 195 | if dr > -3 && dr < 2 && dg > -3 && dg < 2 && db > -3 && db < 2 then 196 | let d = ((dr + 2) lsl 4) lor ((dg + 2) lsl 2) lor (db + 2) in 197 | Bigbytes.set dst i (qoi_op_diff lor d); 198 | (loop[@tailcall]) 0 (i + 1) p nr ng nb na 199 | else 200 | let dr_dg = int8_of_uint8_bits ((dr - dg) land 0xFF)in 201 | let db_dg = int8_of_uint8_bits ((db - dg) land 0xFF)in 202 | if dr_dg > -9 && dr_dg < 8 && dg > -33 && dg < 32 && db_dg > -9 && db_dg < 8 203 | then 204 | (Bigbytes.set dst i (qoi_op_luma lor (dg + 32)); 205 | Bigbytes.set dst (i + 1) (((dr_dg + 8) lsl 4) lor (db_dg + 8)); 206 | loop 0 (i + 2) p nr ng nb na) 207 | else 208 | (Bigbytes.set dst i qoi_op_rgb; 209 | Bigbytes.set dst (i + 1) nr; 210 | Bigbytes.set dst (i + 2) ng; 211 | Bigbytes.set dst (i + 3) nb; 212 | (loop[@tailcall]) 0 (i + 4) p nr ng nb na) 213 | in 214 | loop 0 qoi_header_length 0 0 0 0 0xFF 215 | 216 | let encode m p = 217 | check_length_match m p; 218 | let dst = match Meta.encoding_buffer_byte_length m with 219 | | None -> invalid_arg err_img_too_large 220 | | Some len -> Bigbytes._create len 221 | in 222 | let channels = channel_count (Meta.channels m) in 223 | encode_header dst m; 224 | encode_pixels p ~channels dst 225 | 226 | (* Decoding *) 227 | 228 | module Error = struct 229 | type kind = 230 | | Image_too_large of uint32 * uint32 231 | | Invalid_channels of int 232 | | Invalid_color_space of int 233 | | Invalid_end_marker 234 | | Invalid_image 235 | | Not_a_qoi_file 236 | | Truncated_chunk_stream 237 | 238 | let pp_str = Format.pp_print_string 239 | let pf = Format.fprintf 240 | let pp_kind ppf = function 241 | | Image_too_large (w, h) -> pf ppf "Image too large (%lux%lu)" w h 242 | | Invalid_channels i -> pf ppf "Invalid channels (%d)" i 243 | | Invalid_color_space i -> pf ppf "Invalid color space (%d)" i 244 | | Invalid_end_marker -> pp_str ppf "Invalid end marker" 245 | | Invalid_image -> pp_str ppf "Invalid image" 246 | | Not_a_qoi_file -> pp_str ppf "Not a QOI file" 247 | | Truncated_chunk_stream -> pp_str ppf "Truncated chunk stream" 248 | 249 | type t = kind * int 250 | 251 | let pp ppf (k, pos) = pf ppf "%d: %a" pos pp_kind k 252 | let to_string e = Format.asprintf "%a" pp e 253 | end 254 | 255 | exception Err of Error.t 256 | let err k pos = raise (Err (k, pos)) 257 | 258 | let pixel_buffer m = match Meta.pixels_byte_length m with 259 | | Some len -> Bigbytes._create len 260 | | None -> err Int32.(Image_too_large (of_int (Meta.w m), of_int (Meta.h m))) 0 261 | 262 | let decode_header ?channels b = 263 | if Bigbytes.length b < qoi_header_length then err Not_a_qoi_file 0 else 264 | let magic = Bigbytes.get_uint32_be b 0 in 265 | if magic <> qoi_magic then err Not_a_qoi_file 0 else 266 | let w = Bigbytes.get_uint32_be b 4 in 267 | let h = Bigbytes.get_uint32_be b 8 in 268 | let decoded_channels = match Bigbytes.get b 12 with 269 | | 3 -> `Rgb | 4 -> `Rgba | i -> err (Invalid_channels i) 12 270 | in 271 | let channels = Option.value ~default:decoded_channels channels in 272 | let color_space = match Bigbytes.get b 13 with 273 | | 0 -> `Srgb | 1 -> `Linear | i -> err (Invalid_color_space i) 13 274 | in 275 | let wi = Int32.unsigned_to_int w and hi = Int32.unsigned_to_int h in 276 | match wi, hi with 277 | | None, _ | _, None -> err (Image_too_large (h, w)) 4 278 | | Some w, Some h -> Meta.v color_space channels ~w ~h 279 | 280 | let decode_end_marker b = 281 | let first = Bigbytes.length b - qoi_end_marker_length in 282 | if first < qoi_header_length then err Invalid_end_marker first else 283 | let m0 = Bigbytes.get_uint32_be b (first ) in 284 | let m1 = Bigbytes.get_uint32_be b (first + 4) in 285 | if m0 <> 0l || m1 <> 1l then err Invalid_end_marker first else () 286 | 287 | let[@inline] set_pixel channels dst p r g b a = 288 | Bigbytes.set dst (p ) r; 289 | Bigbytes.set dst (p + 1) g; 290 | Bigbytes.set dst (p + 2) b; 291 | if channels = 4 then Bigbytes.set dst (p + 3) a; 292 | p + channels 293 | 294 | let decode_pixels src ~channels dst = 295 | let i_max = Bigbytes.length src - qoi_end_marker_length - 1 in 296 | let p_max = Bigbytes.length dst - 1 in 297 | let index = Index.create () in 298 | let rec loop run i p r g b a = 299 | if p > p_max 300 | then (if run <> 0 || i <> i_max + 1 then err Invalid_image i_max else ()) 301 | else 302 | if run > 0 then 303 | let p = set_pixel channels dst p r g b a in 304 | (loop[@tailcall]) (run - 1) i p r g b a 305 | else 306 | if i > i_max then err Truncated_chunk_stream i_max else 307 | let b1 = Bigbytes.get src i in 308 | if b1 = qoi_op_rgb then 309 | if i + 3 > i_max then err Truncated_chunk_stream i_max else 310 | let r = Bigbytes.get src (i + 1) in 311 | let g = Bigbytes.get src (i + 2) in 312 | let b = Bigbytes.get src (i + 3) in 313 | let p = set_pixel channels dst p r g b a in 314 | Index.set index ~color_idx:(Index.color_idx r g b a) r g b a; 315 | (loop[@tailcall]) run (i + 4) p r g b a 316 | else 317 | if b1 = qoi_op_rgba then 318 | if i + 4 > i_max then err Truncated_chunk_stream i_max else 319 | let r = Bigbytes.get src (i + 1) in 320 | let g = Bigbytes.get src (i + 2) in 321 | let b = Bigbytes.get src (i + 3) in 322 | let a = Bigbytes.get src (i + 4) in 323 | let p = set_pixel channels dst p r g b a in 324 | Index.set index ~color_idx:(Index.color_idx r g b a) r g b a; 325 | (loop[@tailcall]) run (i + 5) p r g b a 326 | else 327 | let op = b1 land qoi_op_mask in 328 | if op = qoi_op_index then 329 | let color_idx_pos = Index.color_idx_pos b1 in 330 | let r = Index.get_r index ~color_idx_pos in 331 | let g = Index.get_g index ~color_idx_pos in 332 | let b = Index.get_b index ~color_idx_pos in 333 | let a = Index.get_a index ~color_idx_pos in 334 | let p = set_pixel channels dst p r g b a in 335 | (loop[@tailcall]) run (i + 1) p r g b a 336 | else 337 | if op = qoi_op_diff then 338 | let r = (r + ((b1 lsr 4) land 0x03) - 2) land 0xFF in 339 | let g = (g + ((b1 lsr 2) land 0x03) - 2) land 0xFF in 340 | let b = (b + ((b1 ) land 0x03) - 2) land 0xFF in 341 | let p = set_pixel channels dst p r g b a in 342 | Index.set index ~color_idx:(Index.color_idx r g b a) r g b a; 343 | (loop[@tailcall]) run (i + 1) p r g b a 344 | else 345 | if op = qoi_op_luma then 346 | if i + 1 > i_max then err Truncated_chunk_stream i_max else 347 | let b2 = Bigbytes.get src (i + 1) in 348 | let dg = (b1 land 0x3f) - 32 in 349 | let r = (r + dg - 8 + ((b2 lsr 4) land 0x0f)) land 0xFF in 350 | let g = (g + dg) land 0xFF in 351 | let b = (b + dg - 8 + (b2 land 0x0f)) land 0xFF in 352 | let p = set_pixel channels dst p r g b a in 353 | Index.set index ~color_idx:(Index.color_idx r g b a) r g b a; 354 | (loop[@tailcall]) run (i + 2) p r g b a 355 | else 356 | if op = qoi_op_run then 357 | let run = b1 land 0x3f in 358 | let p = set_pixel channels dst p r g b a in 359 | (loop[@tailcall]) run (i + 1) p r g b a 360 | else 361 | assert false 362 | in 363 | let r = 0 and g = 0 and b = 0 and a = 0xFF in 364 | Index.set index ~color_idx:(Index.color_idx r g b a) r g b a; 365 | loop 0 qoi_header_length 0 r g b a 366 | 367 | let decode ?channels src = 368 | try 369 | let m = decode_header ?channels src in 370 | let () = decode_end_marker src in 371 | let dst = pixel_buffer m in 372 | let channels = channel_count (Meta.channels m) in 373 | decode_pixels src ~channels dst; 374 | Ok (m, dst) 375 | with 376 | | Err e -> Error e 377 | 378 | let decode' ?channels b = Result.map_error Error.to_string (decode ?channels b) 379 | let decode_meta b = try Ok (decode_header b) with Err e -> Error e 380 | 381 | (*--------------------------------------------------------------------------- 382 | Copyright (c) 2021 The qoic programmers 383 | 384 | Permission to use, copy, modify, and/or distribute this software for any 385 | purpose with or without fee is hereby granted, provided that the above 386 | copyright notice and this permission notice appear in all copies. 387 | 388 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 389 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 390 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 391 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 392 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 393 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 394 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 395 | ---------------------------------------------------------------------------*) 396 | --------------------------------------------------------------------------------