├── .gitignore ├── dune-project ├── test ├── what.png ├── dune └── test.ml ├── .merlin ├── src ├── dune ├── tsdl_image.mli └── tsdl_image.ml ├── .travis.yml ├── README.md └── tsdl_image.opam /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *.install 3 | *.merlin 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.11) 2 | (name tsdl_image) 3 | (explicit_js_mode) 4 | -------------------------------------------------------------------------------- /test/what.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tokenrove/tsdl-image/HEAD/test/what.png -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S src 2 | S test 3 | B _build/** 4 | PKG tsdl 5 | PKG ctypes 6 | PKG result 7 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (modules test) 4 | (libraries tsdl tsdl_image result)) 5 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tsdl_image) 3 | (public_name tsdl_image) 4 | (modules tsdl_image) 5 | (libraries ctypes tsdl result) 6 | (c_library_flags -lSDL2_image)) 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | dist: bionic 3 | sudo: required 4 | install: 5 | - wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-ocaml.sh 6 | - bash -ex .travis-ocaml.sh 7 | - opam install -y depext 8 | - opam depext -y tsdl 9 | - opam pin -y add tsdl 0.9.6 # workaround for missing sdl 2.0.9 10 | script: 11 | - wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh 12 | - bash -ex .travis-opam.sh 13 | env: 14 | - OCAML_VERSION=4.02 15 | - OCAML_VERSION=4.03 16 | - OCAML_VERSION=4.04 17 | - OCAML_VERSION=4.05 18 | - OCAML_VERSION=4.06 19 | - OCAML_VERSION=4.07 20 | - OCAML_VERSION=4.08 21 | os: 22 | - linux 23 | - osx 24 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | 2 | open Tsdl 3 | open Tsdl_image 4 | open Result 5 | 6 | let (>>=) o f = 7 | match o with | Error (`Msg e) -> failwith (Printf.sprintf "Error %s" e) 8 | | Ok a -> f a 9 | 10 | let () = 11 | ignore (Sdl.init Sdl.Init.everything); 12 | let flags = Image.Init.(jpg + png) in 13 | assert ((Image.init flags) = flags); 14 | Image.load "what.png" >>= fun sface -> 15 | assert ((Sdl.get_surface_size sface) = (64,64)); 16 | assert ((Image.save_png sface "output.png") = 0); 17 | Sdl.rw_from_file "what.png" "rb" >>= fun f -> 18 | assert (false = Image.is_format Image.Ico f); 19 | assert (false = Image.is_format Image.Bmp f); 20 | assert (false = Image.is_format Image.Gif f); 21 | assert (false = Image.is_format Image.Pcx f); 22 | assert (false = Image.is_format Image.Jpg f); 23 | assert (Image.is_format Image.Png f); 24 | Sdl.rw_close f |> ignore; 25 | Image.quit (); 26 | Sdl.quit (); 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Tsdl\_image — SDL2\_Image bindings for OCaml with Tsdl 2 | ------------------------------------------------------ 3 | 4 | Tsdl\_image provides bindings to 5 | [SDL2_Image](https://www.libsdl.org/projects/SDL_image/) intended to 6 | be used with [Tsdl](http://erratique.ch/software/tsdl). 7 | 8 | It has as siblings [tsdl-mixer](https://github.com/tokenrove/tsdl-mixer) 9 | and [tsdl-ttf](https://github.com/tokenrove/tsdl-ttf). 10 | 11 | Note that these bindings are at an early stage and have only been used 12 | minimally. The interface may change. Comments and bug reports are 13 | welcome through the [github page](https://github.com/tokenrove/tsdl-image) 14 | or by emailing Julian Squires <[julian@cipht.net](mailto:julian@cipht.net)>. 15 | 16 | ## Installation 17 | 18 | Via [opam](https://opam.ocaml.org/): 19 | 20 | opam install tsdl_image 21 | 22 | ## Documentation 23 | 24 | Documentation can be generated with `ocamldoc`, but the binding 25 | follows the SDL2_image interface closely, so it may be sufficient to 26 | consult 27 | [its documentation](https://www.libsdl.org/projects/SDL_image/docs/index.html). 28 | -------------------------------------------------------------------------------- /tsdl_image.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "0.3.0" 3 | maintainer: "Julian Squires " 4 | authors: ["Julian Squires "] 5 | homepage: "http://github.com/tokenrove/tsdl-image" 6 | dev-repo: "git+https://github.com/tokenrove/tsdl-image.git" 7 | bug-reports: "http://github.com/tokenrove/tsdl-image/issues" 8 | tags: [ "bindings" "graphics" ] 9 | license: "BSD-3-Clause" 10 | depends: [ 11 | "ocaml" {>= "4.02"} 12 | "ctypes" {>= "0.4.0"} 13 | "ctypes-foreign" 14 | "tsdl" {>= "0.9.0"} 15 | "result" 16 | "dune" {build & >= "1.11.0"} 17 | ] 18 | depexts: [ 19 | ["libsdl2-image-dev"] {os-family = "debian"} 20 | ["sdl2_image"] {os-distribution = "homebrew" & os = "macos"} 21 | ["sdl2_image"] {os-distribution = "arch"} 22 | ] 23 | build: [ 24 | ["dune" "build" "-p" name "-j" jobs] 25 | ["dune" "build" "test/what.png" "test/test.exe"] {with-test} 26 | ["dune" "build" "@doc" "-p" name] {with-doc} 27 | ] 28 | run-test: ["dune" "runtest" "-p" name] 29 | synopsis: "SDL2_Image bindings to go with Tsdl" 30 | description: """ 31 | Tsdl_image provides bindings to SDL2_Image intended to be used with 32 | Tsdl.""" 33 | -------------------------------------------------------------------------------- /src/tsdl_image.mli: -------------------------------------------------------------------------------- 1 | (** SDL2_image bindings 2 | 3 | {b References} 4 | {ul 5 | {- {{:https://www.libsdl.org/projects/SDL_image/docs/index.html}SDL_image API}}} *) 6 | 7 | module Image : sig 8 | 9 | type 'a result = 'a Tsdl.Sdl.result 10 | 11 | (** {1 Initialization} *) 12 | 13 | module Init : sig 14 | type t 15 | val ( + ) : t -> t -> t 16 | val test : t -> t -> bool 17 | val eq : t -> t -> bool 18 | val empty : t 19 | val jpg : t 20 | val png : t 21 | val tif : t 22 | val webp : t 23 | end 24 | 25 | val init : Init.t -> Init.t 26 | (** {{:https://www.libsdl.org/projects/SDL_image/docs/SDL_image_8.html#SEC8}IMG_Init} *) 27 | 28 | val quit : unit -> unit 29 | (** {{:https://www.libsdl.org/projects/SDL_image/docs/SDL_image_9.html#SEC9}IMG_Quit} *) 30 | 31 | type format = Ico | Cur | Bmp | Gif | Jpg | Lbm | Pcx | Png | Pnm | Tif | Xcf 32 | | Xpm | Xv | Webp | Tga 33 | 34 | (** {1 Loading} *) 35 | 36 | val load : string -> Tsdl.Sdl.surface result 37 | (** {{:https://www.libsdl.org/projects/SDL_image/docs/SDL_image_11.html#SEC11}IMG_Load} *) 38 | 39 | val load_rw : Tsdl.Sdl.rw_ops -> bool -> Tsdl.Sdl.surface result 40 | (** {{:https://www.libsdl.org/projects/SDL_image/docs/SDL_image_12.html#SEC12}IMG_Load_RW} *) 41 | 42 | val load_typed_rw : Tsdl.Sdl.rw_ops -> bool -> format -> Tsdl.Sdl.surface result 43 | (** {{:https://www.libsdl.org/projects/SDL_image/docs/SDL_image_13.html#SEC13}IMG_LoadTyped_RW} *) 44 | 45 | val load_texture : Tsdl.Sdl.renderer -> string -> Tsdl.Sdl.texture result 46 | val load_texture_rw : Tsdl.Sdl.renderer -> Tsdl.Sdl.rw_ops -> bool -> Tsdl.Sdl.texture result 47 | val load_texture_typed_rw : Tsdl.Sdl.renderer -> Tsdl.Sdl.rw_ops -> bool -> format -> Tsdl.Sdl.texture result 48 | 49 | val load_format_rw : format -> Tsdl.Sdl.rw_ops -> Tsdl.Sdl.surface result 50 | 51 | val read_xpm_from_array : string -> Tsdl.Sdl.surface result 52 | (** {{:https://www.libsdl.org/projects/SDL_image/docs/SDL_image_28.html#SEC28}IMG_ReadXPMFromArray} *) 53 | 54 | (** {1 Saving} *) 55 | 56 | val save_png : Tsdl.Sdl.surface -> string -> int 57 | val save_png_rw : Tsdl.Sdl.surface -> Tsdl.Sdl.rw_ops -> bool -> int 58 | 59 | (** {1 Info} *) 60 | 61 | val is_format : format -> Tsdl.Sdl.rw_ops -> bool 62 | (** {{:https://www.libsdl.org/projects/SDL_image/docs/SDL_image_29.html#SEC29}IMG_is*} 63 | 64 | Note that, uniquely, [is_format Tga] will throw an exception, as 65 | SDL_image does not support testing if a file is in Targa format. *) 66 | 67 | end 68 | -------------------------------------------------------------------------------- /src/tsdl_image.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | open Foreign 3 | open Tsdl 4 | open Result 5 | 6 | module Image = struct 7 | 8 | type 'a result = 'a Sdl.result 9 | 10 | let error () = Error (`Msg (Sdl.get_error ())) 11 | 12 | let bool = 13 | view ~read:((<>)0) ~write:(fun b -> compare b false) int 14 | 15 | module Init = struct 16 | type t = Unsigned.uint32 17 | let i = Unsigned.UInt32.of_int 18 | let ( + ) = Unsigned.UInt32.logor 19 | let test f m = Unsigned.UInt32.(compare (logand f m) zero <> 0) 20 | let eq f f' = Unsigned.UInt32.(compare f f' = 0) 21 | let empty = i 0 22 | let jpg = i 1 23 | let png = i 2 24 | let tif = i 4 25 | let webp = i 8 26 | end 27 | 28 | let init = 29 | foreign "IMG_Init" (uint32_t @-> returning uint32_t) 30 | 31 | let quit = 32 | foreign "IMG_Quit" (void @-> returning void) 33 | 34 | let surface = 35 | view 36 | ~read:Sdl.unsafe_surface_of_ptr 37 | ~write:Sdl.unsafe_ptr_of_surface 38 | nativeint 39 | 40 | let texture_result = 41 | let read v = 42 | if Nativeint.(compare v zero) = 0 43 | then error () 44 | else Ok (Sdl.unsafe_texture_of_ptr v) 45 | and write = function 46 | | Ok v -> Sdl.unsafe_ptr_of_texture v 47 | | Error _ -> raw_address_of_ptr null 48 | in 49 | view ~read ~write nativeint 50 | 51 | let surface_result = 52 | let read v = 53 | if Nativeint.(compare v zero) = 0 54 | then error () 55 | else Ok (Sdl.unsafe_surface_of_ptr v) 56 | and write = function 57 | | Ok v -> Sdl.unsafe_ptr_of_surface v 58 | | Error _ -> raw_address_of_ptr null 59 | in 60 | view ~read ~write nativeint 61 | 62 | let rw_ops = 63 | view ~read:Sdl.unsafe_rw_ops_of_ptr ~write:Sdl.unsafe_ptr_of_rw_ops nativeint 64 | let renderer = 65 | view ~read:Sdl.unsafe_renderer_of_ptr ~write:Sdl.unsafe_ptr_of_renderer nativeint 66 | 67 | let load = 68 | foreign "IMG_Load" (string @-> returning surface_result) 69 | 70 | let load_rw = 71 | foreign "IMG_Load_RW" (rw_ops @-> bool @-> returning surface_result) 72 | 73 | type format = Ico | Cur | Bmp | Gif | Jpg | Lbm | Pcx | Png | Pnm | Tif | Xcf 74 | | Xpm | Xv | Webp | Tga 75 | let string_of_format = function 76 | | Ico -> "ICO" | Cur -> "CUR" | Bmp -> "BMP" | Gif -> "GIF" 77 | | Jpg -> "JPG" | Lbm -> "LBM" | Pcx -> "PCX" | Png -> "PNG" 78 | | Pnm -> "PNM" | Tif -> "TIF" | Xcf -> "XCF" | Xpm -> "XPM" 79 | | Xv -> "XV" | Webp -> "WEBP" | Tga -> "TGA" 80 | 81 | let load_typed_rw = 82 | foreign "IMG_LoadTyped_RW" 83 | (rw_ops @-> bool @-> string @-> returning surface_result) 84 | let load_typed_rw r b f = load_typed_rw r b (string_of_format f) 85 | 86 | let load_texture = 87 | foreign "IMG_LoadTexture" 88 | (renderer @-> string @-> returning texture_result) 89 | 90 | let load_texture_rw = 91 | foreign "IMG_LoadTexture_RW" 92 | (renderer @-> rw_ops @-> bool @-> returning texture_result) 93 | 94 | let load_texture_typed_rw = 95 | foreign "IMG_LoadTextureTyped_RW" 96 | (renderer @-> rw_ops @-> bool @-> string @-> returning texture_result) 97 | let load_texture_typed_rw r o b f = 98 | load_texture_typed_rw r o b (string_of_format f) 99 | 100 | let is_ico = foreign "IMG_isICO" (rw_ops @-> returning bool) 101 | let is_cur = foreign "IMG_isCUR" (rw_ops @-> returning bool) 102 | let is_bmp = foreign "IMG_isBMP" (rw_ops @-> returning bool) 103 | let is_gif = foreign "IMG_isGIF" (rw_ops @-> returning bool) 104 | let is_jpg = foreign "IMG_isJPG" (rw_ops @-> returning bool) 105 | let is_lbm = foreign "IMG_isLBM" (rw_ops @-> returning bool) 106 | let is_pcx = foreign "IMG_isPCX" (rw_ops @-> returning bool) 107 | let is_png = foreign "IMG_isPNG" (rw_ops @-> returning bool) 108 | let is_pnm = foreign "IMG_isPNM" (rw_ops @-> returning bool) 109 | let is_tif = foreign "IMG_isTIF" (rw_ops @-> returning bool) 110 | let is_xcf = foreign "IMG_isXCF" (rw_ops @-> returning bool) 111 | let is_xpm = foreign "IMG_isXPM" (rw_ops @-> returning bool) 112 | let is_xv = foreign "IMG_isXV" (rw_ops @-> returning bool) 113 | let is_webp = foreign "IMG_isWEBP" (rw_ops @-> returning bool) 114 | let is_format fmt = match fmt with 115 | | Ico -> is_ico | Cur -> is_cur | Bmp -> is_bmp | Gif -> is_gif 116 | | Jpg -> is_jpg | Lbm -> is_lbm | Pcx -> is_pcx | Png -> is_png 117 | | Pnm -> is_pnm | Tif -> is_tif | Xcf -> is_xcf | Xpm -> is_xpm 118 | | Xv -> is_xv | Webp -> is_webp 119 | | Tga -> failwith "TGA cannot safely be detected" 120 | 121 | let load_ico_rw = foreign "IMG_LoadICO_RW" (rw_ops @-> returning surface_result) 122 | let load_cur_rw = foreign "IMG_LoadCUR_RW" (rw_ops @-> returning surface_result) 123 | let load_bmp_rw = foreign "IMG_LoadBMP_RW" (rw_ops @-> returning surface_result) 124 | let load_gif_rw = foreign "IMG_LoadGIF_RW" (rw_ops @-> returning surface_result) 125 | let load_jpg_rw = foreign "IMG_LoadJPG_RW" (rw_ops @-> returning surface_result) 126 | let load_lbm_rw = foreign "IMG_LoadLBM_RW" (rw_ops @-> returning surface_result) 127 | let load_pcx_rw = foreign "IMG_LoadPCX_RW" (rw_ops @-> returning surface_result) 128 | let load_png_rw = foreign "IMG_LoadPNG_RW" (rw_ops @-> returning surface_result) 129 | let load_pnm_rw = foreign "IMG_LoadPNM_RW" (rw_ops @-> returning surface_result) 130 | let load_tga_rw = foreign "IMG_LoadTGA_RW" (rw_ops @-> returning surface_result) 131 | let load_tif_rw = foreign "IMG_LoadTIF_RW" (rw_ops @-> returning surface_result) 132 | let load_xcf_rw = foreign "IMG_LoadXCF_RW" (rw_ops @-> returning surface_result) 133 | let load_xpm_rw = foreign "IMG_LoadXPM_RW" (rw_ops @-> returning surface_result) 134 | let load_xv_rw = foreign "IMG_LoadXV_RW" (rw_ops @-> returning surface_result) 135 | let load_webp_rw = foreign "IMG_LoadWEBP_RW" (rw_ops @-> returning surface_result) 136 | let load_format_rw = function 137 | | Ico -> load_ico_rw | Cur -> load_cur_rw | Bmp -> load_bmp_rw | Gif -> load_gif_rw 138 | | Jpg -> load_jpg_rw | Lbm -> load_lbm_rw | Pcx -> load_pcx_rw | Png -> load_png_rw 139 | | Pnm -> load_pnm_rw | Tif -> load_tif_rw | Xcf -> load_xcf_rw | Xpm -> load_xpm_rw 140 | | Xv -> load_xv_rw | Webp -> load_webp_rw | Tga -> load_tga_rw 141 | 142 | let read_xpm_from_array = 143 | foreign "IMG_ReadXPMFromArray" (string @-> returning surface_result) 144 | 145 | let save_png = 146 | foreign "IMG_SavePNG" (surface @-> string @-> returning int) 147 | let save_png_rw = 148 | foreign "IMG_SavePNG_RW" (surface @-> rw_ops @-> bool @-> returning int) 149 | 150 | end 151 | --------------------------------------------------------------------------------