#! /usr/bin/env ocaml (* {{{ COPYING *) (* * Copyright (C) 2005 Florent Monnier * * This is a simple OCaml/openGL image viewer. * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * http://www.fsf.org/licensing/licenses/gpl.html * * You should have received a copy of the GNU General Public License * along with this program; if not, * write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA * * Contact: monnier.florent (Φ) gmail.com * * }}} *) (* {{{ compilation *) (* ocamlopt unix.cmxa \ -I +lablGL lablgl.cmxa lablglut.cmxa \ -I +imageMagick magick.cmxa \ image-viewer.ml -o glov )* }}} *) (* {{{ deps *) #directory "+lablGL" ;; #load "lablgl.cma" ;; #load "lablglut.cma" ;; #directory "+imageMagick" ;; #load "magick.cma" ;; #load "unix.cma" ;; (* }}} *) (* {{{ parse arg *) let verbose = ref false let fullscreen = ref false let diaporama = ref false let image_name = ref "" let img_list = ref [] let _ = Arg.parse [ ( "-v", Arg.Set verbose, "verbose" ); ( "-f", Arg.Set fullscreen, "fullscreen" ); ( "-d", Arg.Set diaporama, "diaporama" ); ( "-i", Arg.String (fun i -> image_name := i), "image" ) ] (fun img -> img_list := img::!img_list) ("Image Viewer") (* }}} *) (* {{{ gpl notice *) let gpl_notice () = let program_name = Filename.basename Sys.argv.(0) in let user_name = try Sys.getenv "USER" with Not_found -> "" in if user_name <> "blue_prawn" then Printf.printf " %s, Copyright (C) 2005 Florent Monnier %s comes with ABSOLUTELY NO WARRANTY. This is free software, and you are welcome to redistribute it under the GPL license conditions.\n\n" program_name program_name ; flush_all () (* }}} *) (* {{{ file_exists *) let file_exists filename = if Sys.file_exists filename then true else begin prerr_endline (Printf.sprintf "Error: file '%s' does not exist" filename); false end (* }}} *) (* {{{ is_readable *) let is_readable filename = try ignore(open_in filename); true with _ -> begin prerr_endline (Printf.sprintf "Error: file '%s' is not readable" Sys.argv.(1)); false end (* }}} *) (* {{{ is_file *) let is_file filename = if Sys.file_exists filename then begin let file_stat = Unix.stat filename in match file_stat.Unix.st_kind with | Unix.S_REG -> true; | _ -> false; end else false (* }}} *) (* {{{ is_dir *) let is_dir dirname = if Sys.file_exists dirname then begin let file_stat = Unix.stat dirname in match file_stat.Unix.st_kind with | Unix.S_DIR -> true; | _ -> false; end else false (* }}} *) (* {{{ file_get_contents *) let file_get_contents filename = let rec read ic = try let i = input_line ic in i::read ic with End_of_file -> [] in let buf = Buffer.create 4096 in let lines = let ic = open_in filename in read ic in let foreach line = Buffer.add_string buf (line ^ "\n") in List.iter foreach lines ; let contents = Buffer.contents buf in Buffer.reset buf ; contents (* }}} *) (* {{{ chan_get_contents *) let chan_get_contents chan = let rec read ic = try let i = input_line ic in i::read ic with End_of_file -> [] in let buf = Buffer.create 4096 in let lines = read chan in let foreach line = Buffer.add_string buf (line ^ "\n") in List.iter foreach lines ; let contents = Buffer.contents buf in Buffer.reset buf ; contents (* }}} *) (* {{{ round *) let closest_float f = let _floor = floor f in let _ceil = ceil f in if (f -. _floor) < (_ceil -. f) then _floor else _ceil let round f d = let decal = 10. ** (float d) in let f = closest_float (f *. decal) in let f = (f /. decal) in f (* }}} *) (* {{{ get_closer_size *) (* returns the closer suitable openGL image size *) let get_closer_size t_img = let w = Magick.Imper.get_image_width t_img and h = Magick.Imper.get_image_height t_img in let average = (w + h) / 2 in let rec loop dim = let curt_dim__average__distance = abs (dim - average) and succ_dim__average__distance = abs ((dim * 2) - average) in if succ_dim__average__distance < curt_dim__average__distance then loop (dim * 2) else dim in let return = loop 2 in if !verbose then begin Printf.printf "\t(width, height) = (%d, %d)\n" w h; Printf.printf "\taverage = %d\n" average; Printf.printf "\tcloser dim = %d\n" return; flush_all(); end; return (* }}} *) (* {{{ get_floor_size *) (* returns the floor suitable openGL image size *) let get_floor_size t_img = let w = Magick.Imper.get_image_width t_img and h = Magick.Imper.get_image_height t_img in let average = (w + h) / 2 in let rec loop dim = if dim > average then (dim / 2) else loop (dim * 2) in let return = loop 2 in if !verbose then begin Printf.printf "\t(width, height) = (%d, %d)\n" w h; Printf.printf "\taverage = %d\n" average; Printf.printf "\tceil dim = %d\n" return; flush_all(); end; return (* }}} *) (* {{{ get_ceil_size *) (* returns the ceil suitable openGL image size *) let get_ceil_size t_img = let w = Magick.Imper.get_image_width t_img and h = Magick.Imper.get_image_height t_img in let average = (w + h) / 2 in let rec loop dim = if dim > average then dim else loop (dim * 2) in let return = loop 2 in if !verbose then begin Printf.printf "\t(width, height) = (%d, %d)\n" w h; Printf.printf "\taverage = %d\n" average; Printf.printf "\tceil dim = %d\n" return; flush_all(); end; return (* }}} *) (* {{{ make_image *) let make_image image_name = (* (* {{{ test if file exists *) if not(Sys.file_exists image_name) then begin prerr_endline (Printf.sprintf "Error: file '%s' does not exist" image_name); exit 1; end; (* }}} *) (* {{{ test if file is readable *) begin try ignore(open_in(image_name)) with _ -> begin prerr_endline (Printf.sprintf "Error: file '%s' is not readable" image_name); exit 1; end end; (* }}} *) *) if not (Magick.Imper.ping_image image_name) then begin prerr_endline (Printf.sprintf "Error: cannot access image '%s'" image_name); exit 1; end; let t_img = try let _t = Magick.Imper.read_image image_name in (* Printf.printf " image %s loaded\n" image_name; flush_all(); *) _t with _ -> let (width, height, pseudo_format) = (200, 150, "pattern:checkerboard") in let _t = Magick.Imper.get_image ~width ~height ~pseudo_format in Printf.printf "\tcannot load image %s\n" image_name; flush_all(); _t in let image_width = Magick.Imper.get_image_width t_img and image_height = Magick.Imper.get_image_height t_img in (* ratio <- (float image_width) /. (float image_height); *) let ratio = (float image_width) /. (float image_height) in (* let exec_time_start = Unix.gettimeofday () in *) (* let image_size = get_closer_size t_img in let image_size = get_ceil_size t_img in let image_size = 256 in *) let image_size = get_floor_size t_img in (* Magick.Imper.resize t_img image_size image_size Magick.Imper.QuadraticFilter 1.0; Magick.Imper.resize t_img image_size image_size Magick.Imper.LanczosFilter 1.0; (* quality resizing (slow) *) Magick.Imper.scale t_img image_size image_size; (* medium resizing *) *) Magick.Imper.sample t_img image_size image_size; (* very fast resizing (low quality) *) (* let exec_time_final = Unix.gettimeofday () in let exec_time = exec_time_final -. exec_time_start in Printf.printf " resizing image in %.3fs\n" exec_time; flush_all(); *) let image_width = image_size and image_height = image_size in (* let pixel_matrix = Magick.Imper.get_raw_without_alpha t_img in let gl_image = GlPix.create `ubyte ~format:`rgb ~width:image_width ~height:image_height in for i = 0 to image_width - 1 do let _pixel_matrix = pixel_matrix.(i) in for j = 0 to image_height - 1 do let (r, g, b) = _pixel_matrix.(j) in Raw.sets (GlPix.to_raw gl_image) ~pos:(3*(i*image_height+j)) [|r/256;g/256;b/256|] done done; *) (* let pixel_matrix = Magick.Imper.get_raw4 t_img in let gl_image = GlPix.create `ubyte ~format:`rgb ~width:image_width ~height:image_height in for i = 0 to image_width - 1 do for j = 0 to image_height - 1 do let (r, g, b) = pixel_matrix.((image_width * j) + i) in Raw.sets (GlPix.to_raw gl_image) ~pos:(3*(i*image_height+j)) [|r/256;g/256;b/256|] done done; *) (* let pixel_matrix = Magick.Imper.get_raw5 t_img in let gl_image = GlPix.create `ubyte ~format:`rgb ~width:image_width ~height:image_height in for i = 0 to image_width - 1 do for j = 0 to image_height - 1 do let index = i*image_height+j in let (r, g, b) = pixel_matrix.(index) in Raw.sets (GlPix.to_raw gl_image) ~pos:(3*index) [|r/256;g/256;b/256|] done done; *) (* *) let exec_time_start = Unix.gettimeofday () in let pixel_matrix = Magick.Imper.get_raw_gl_indexed_without_alpha t_img in let gl_image = GlPix.create `ubyte ~format:`rgb ~width:image_width ~height:image_height in for i = 0 to image_width * image_height - 1 do let (r, g, b) = pixel_matrix.(i) in Raw.sets (GlPix.to_raw gl_image) ~pos:(3*i) [|r/256;g/256;b/256|] done; let exec_time_final = Unix.gettimeofday () in let exec_time = exec_time_final -. exec_time_start in Printf.printf " transfer = %.4f s\n" exec_time; flush_all(); (* *) (gl_image, ratio) (* }}} *) (* {{{ image_obj *) class image_obj image_filename_init = object(self) (* {{{ Variables *) val mutable image_filename = image_filename_init val mutable gl_id = (None : GlList.t option) val mutable position = (0.0, 0.0, 0.0) val mutable rot_y = 0.0 val mutable x = 2.0 (* val mutable gl_image = (None : GlPix.t (`ubyte, `rgb) option) *) val mutable tex_id = (None : GlTex.texture_id option) (* }}} *) (* {{{ display *) method display = GlMat.push(); GlMat.translate3 position; GlMat.rotate ~angle:rot_y ~y:1.0 (); begin match gl_id with | Some id -> GlList.call id; | None -> self#draw; end; GlMat.pop(); (* Printf.printf "\timg=%s\n" image_filename; flush_all(); *) (* }}} *) (* {{{ draw *) method private draw = (* GlTex.image2d gl_image; *) begin match tex_id with | Some texid -> GlTex.bind_texture ~target:`texture_2d texid; | None -> (); end; GlDraw.begins `quads; GlTex.coord2(1.0, 0.0); GlDraw.vertex3((-. x), -2.0, 0.0); GlTex.coord2(0.0, 0.0); GlDraw.vertex3((-. x), 2.0, 0.0); GlTex.coord2(0.0, 1.0); GlDraw.vertex3( x , 2.0, 0.0); GlTex.coord2(1.0, 1.0); GlDraw.vertex3( x , -2.0, 0.0); GlDraw.ends(); (* }}} *) (* {{{ compile *) method compile = begin match gl_id with | Some id -> GlList.delete id; | None -> () end; let id = GlList.create `compile in self#draw; GlList.ends(); gl_id <- Some(id); (* }}} *) (* {{{ Initializer *) initializer let (_gl_image, ratio) = make_image image_filename in x <- 2.0 *. ratio; (* gl_image <- _gl_image; *) let id = GlList.create `compile in GlTex.image2d _gl_image; self#draw; GlList.ends(); gl_id <- Some(id); (* *) (* GlTex.image2d _gl_image; let _tex_id = GlTex.gen_texture () in tex_id <- Some(_tex_id); *) GlPix.store (`unpack_alignment 1); (* GlTex.image2d gl_image; *) List.iter (GlTex.parameter ~target:`texture_2d) [ `wrap_s `clamp; `wrap_t `clamp; `mag_filter `nearest; `min_filter `nearest ]; (* GlTex.parameter ~target:`texture_2d (`mag_filter `linear); GlTex.parameter ~target:`texture_2d (`min_filter `linear_mipmap_linear); *) GlTex.env (`mode `decal); Gl.enable `texture_2d; GlDraw.shade_model `flat; (* }}} *) end (* }}} *) class image_viewer = object(self) (* {{{ Variables *) val mutable images = ([] : image_obj list) (* *) (* val mutable idle_count = 0 *) (* Image change delay for slide show *) val mutable ch_delay = 1000 * 2 (* The timer callback is called every [ch_delay] mili-seconds 1000 make it called every second. *) val mutable ratio = 1.0 val mutable x = 2.0 val mutable old_x = 0 val mutable old_y = 0 val mutable presse = false val mutable tran_x = 0.0 val mutable tran_y = 0.0 val mutable tran_z = 0.1 val mutable tran_factor = 0.3 val tran_factor_static = 0.02 val tran_factor_step = 0.9 val mutable window_width = 800 val mutable window_height = 600 val mutable current_image = 0 val mutable slide_show = false (* }}} *) (* {{{ slide_show *) method slide_show value = slide_show <- value; (* }}} *) (* {{{ add_image *) method add_image img = images <- img :: images; (* *) (* }}} *) (* {{{ Display *) method display_view = GlClear.clear [`color;`depth]; (* GlMat.load_identity (); *) GlMat.push (); GlMat.translate3 (tran_x, tran_y, tran_z); (* GlDraw.begins `quads; GlTex.coord2(1.0, 0.0); GlDraw.vertex3((-. x), -2.0, 0.0); GlTex.coord2(0.0, 0.0); GlDraw.vertex3((-. x), 2.0, 0.0); GlTex.coord2(0.0, 1.0); GlDraw.vertex3( x , 2.0, 0.0); GlTex.coord2(1.0, 1.0); GlDraw.vertex3( x , -2.0, 0.0); GlDraw.ends (); *) (* List.iter (fun img -> img#display) images; *) let c_img = List.nth images current_image in c_img#display; GlMat.pop (); Gl.flush (); Glut.swapBuffers (); (* }}} *) (* {{{ Reshape *) method reshape ~w ~h= (* let _ratio = (float w) /. (float h) in GlDraw.viewport 0 0 w h; GlMat.mode `projection; GlMat.load_identity (); GluMat.perspective ~fovy:45.0 ~aspect:_ratio ~z:(0.1, 100.0); GlMat.mode `modelview; GlMat.load_identity (); window_width <- w; window_height <- h; *) GlDraw.viewport ~x:0 ~y:0 ~w ~h; GlMat.mode `projection; GlMat.load_identity (); GluMat.perspective ~fovy:60.0 ~aspect:(float w /. float h) ~z:(0.0001, 80.0); GlMat.mode `modelview; GlMat.load_identity (); GlMat.translate ~z:(-3.6) (); window_width <- w; window_height <- h; (* }}} *) (* {{{ Keyboard *) method keyboard ~key ~x ~y = Glut.setCursor Glut.CURSOR_NONE; match (char_of_int key) with | 'q' -> exit 0; | 'Q' -> exit 0; | '+' -> self#zoom_in; | '-' -> self#zoom_out; | '6' -> self#grab ~mv_x:4 ~mv_y:0; | '4' -> self#grab ~mv_x:(-4) ~mv_y:0; | '8' -> self#grab ~mv_x:0 ~mv_y:(-4); | '2' -> self#grab ~mv_x:0 ~mv_y:4; | 'f' -> Glut.fullScreen (); | 'z' -> Gl.enable `depth_test; Glut.postRedisplay(); print_endline "Gl.enable `depth_test"; | 'Z' -> Gl.disable `depth_test; Glut.postRedisplay(); print_endline "Gl.disable `depth_test"; | 'd' -> (* List.iter (fun img -> img#dump) images; *) (); (* {{{ | 'l' -> Gl.polygonMode [`front_and_back; `line]; Glut.postRedisplay(); }}} *) | _ -> match key with | 27 (* ESC *) -> exit 0; | 17 (* Ctrl+Q *) -> exit 0; | 13 (* Return *) -> (); (* | _ -> print_endline (Printf.sprintf "key %d pressed %c" key (char_of_int key)) *) | _ -> () (* }}} *) (* {{{ Special Keys *) method special_key ~key ~x ~y = Glut.setCursor Glut.CURSOR_NONE; match key with | Glut.KEY_LEFT -> self#prev_img; | Glut.KEY_RIGHT -> self#next_img; | Glut.KEY_DOWN -> (); | Glut.KEY_UP -> (); | Glut.KEY_PAGE_DOWN -> (); | Glut.KEY_PAGE_UP -> (); | Glut.KEY_HOME -> self#first_img; | Glut.KEY_END -> self#last_img; | Glut.KEY_INSERT -> (); | Glut.KEY_F1 -> (); | _ -> (); (* }}} *) (* {{{ Next Prev *) method private prev_img = (* current_image <- max (current_image - 1) 0; *) current_image <- current_image - 1; if current_image < 0 then current_image <- ((List.length images) - 1); Glut.postRedisplay (); method private next_img = (* current_image <- min (current_image + 1) ((List.length images) - 1); *) current_image <- current_image + 1; if current_image > ((List.length images) - 1) then current_image <- 0; Glut.postRedisplay (); method private first_img = current_image <- 0; Glut.postRedisplay (); method private last_img = current_image <- ((List.length images) - 1); Glut.postRedisplay (); (* }}} *) (* {{{ Zoom *) method zoom_in = if tran_z < 2.8 then begin tran_z <- tran_z +. 0.4; (* Printf.printf "\tz=%f\n" tran_z; flush_all(); *) tran_factor <- tran_factor *. tran_factor_step; Glut.postRedisplay (); end method zoom_out = tran_z <- tran_z -. 0.4; tran_factor <- tran_factor /. tran_factor_step; Glut.postRedisplay (); (* }}} *) (* {{{ Mouse *) method mouse ~button ~state ~x ~y = match button, state with | Glut.LEFT_BUTTON, Glut.DOWN -> self#next_img; | Glut.LEFT_BUTTON, Glut.UP -> Glut.setCursor Glut.CURSOR_NONE; | Glut.RIGHT_BUTTON, Glut.DOWN -> self#prev_img; | Glut.RIGHT_BUTTON, Glut.UP -> Glut.setCursor Glut.CURSOR_NONE; | Glut.MIDDLE_BUTTON, Glut.DOWN -> Glut.setCursor Glut.CURSOR_INHERIT; presse <- true; old_x <- x; old_y <- y; | Glut.MIDDLE_BUTTON, Glut.UP -> Glut.setCursor Glut.CURSOR_NONE; presse <- false; | Glut.OTHER_BUTTON a, Glut.DOWN -> begin match a with 3 -> self#zoom_in | 4 -> self#zoom_out | _ -> () end; | Glut.OTHER_BUTTON a, Glut.UP -> (); (* }}} *) (* {{{ Motion *) method motion ~x ~y = if presse then begin (* Printf.printf "\tx y old_x old_y = %d %d %d %d\n" x y old_x old_y; flush_all(); *) self#grab (x - old_x) (y - old_y); (* Printf.printf "\ttran_x tran_y = %f %f\n" tran_x tran_y; flush_all(); *) end; old_x <- x; old_y <- y; (* Printf.printf "."; flush_all(); *) method private grab ~mv_x ~mv_y = tran_x <- tran_x +. ((float mv_x) *. tran_factor_static *. tran_factor); tran_y <- tran_y -. ((float mv_y) *. tran_factor_static *. tran_factor); Glut.postRedisplay (); (* }}} *) (* {{{ Passive *) method passive ~x ~y = Glut.setCursor Glut.CURSOR_INHERIT; Glut.timerFunc ~ms:800 ~cb:(fun ~value -> self#hide_cursor ~value) ~value:0 ; (* }}} *) (* {{{ Idle * method idle = idle_count <- succ idle_count * }}} *) (* {{{ Timer *) method timer ~value = if slide_show then begin (* List.iter (fun img -> img#rotate 5.0) images; *) Printf.printf " dia T=%d\n" value; flush_all(); self#next_img; Glut.postRedisplay(); (* Glut.timerFunc ~ms:ch_delay ~cb:(fun ~value -> self#timer ~value) ~value:0; *) Glut.timerFunc ~ms:ch_delay ~cb:(fun ~value -> self#timer ~value) ~value:(succ value); end (* }}} *) (* {{{ Hide Cursor *) method hide_cursor ~value = Glut.setCursor Glut.CURSOR_NONE; (* }}} *) (* {{{ Initializer *) initializer (* Glut initialisation *) ignore(Glut.init Sys.argv); (* Display parameters *) Glut.initDisplayMode ~alpha:true ~depth:true ~double_buffer:true (); (* Glut.initDisplayMode ~alpha:true ~depth:true (); *) (* Size and position of the window *) if not !fullscreen then begin Glut.initWindowSize ~w:window_width ~h:window_height; Glut.initWindowPosition ~x:0 ~y:18; end; let window_title = Filename.basename Sys.argv.(0) in ignore(Glut.createWindow ~title:window_title); (* Creation of the window *) (* {{{ inits *) (* GlDraw.shade_model `smooth; GlClear.depth 1.0; GlFunc.depth_func `lequal; GlMisc.hint `perspective_correction `nicest; *) GlClear.color (0.0, 0.0, 0.0); Gl.enable `depth_test; GlFunc.depth_func `less; (* let gl_image = self#make_image Sys.argv.(1) in *) (* let (gl_image, _ratio) = make_image Sys.argv.(1) in ratio <- _ratio; x <- 2.0 *. ratio; *) GlPix.store (`unpack_alignment 1); (* GlTex.image2d gl_image; *) List.iter (GlTex.parameter ~target:`texture_2d) [ `wrap_s `clamp; `wrap_t `clamp; `mag_filter `nearest; `min_filter `nearest ]; GlTex.env (`mode `decal); Gl.enable `texture_2d; GlDraw.shade_model `flat; (* }}} *) (* {{{ Callbacks *) Glut.displayFunc (fun () -> self#display_view); Glut.reshapeFunc (fun ~w ~h -> self#reshape ~w ~h); Glut.keyboardFunc (fun ~key ~x ~y -> self#keyboard ~key ~x ~y); Glut.specialFunc (fun ~key ~x ~y -> self#special_key ~key ~x ~y); Glut.mouseFunc (fun ~button ~state ~x ~y -> self#mouse ~button ~state ~x ~y); Glut.motionFunc (fun ~x ~y -> self#motion ~x ~y); Glut.passiveMotionFunc (fun ~x ~y -> self#passive ~x ~y); Glut.timerFunc ~ms:ch_delay ~cb:(fun ~value -> self#timer ~value) ~value:0 ; (* Glut.idleFunc (Some (fun () -> self#idle)); *) (* }}} *) (* }}} *) end (* {{{ main *) let _ = gpl_notice (); let sc = new image_viewer in (* {{{ load image file names *) let load_image filename = try (*if is_file filename then*) if Magick.Imper.ping_image filename then begin let img = new image_obj filename in sc#add_image img end with _ -> () in if (Array.length Sys.argv) > 1 then for f = 1 to ((Array.length Sys.argv) -1) do load_image Sys.argv.(f); done; (* }}} *) if !fullscreen then Glut.fullScreen(); if !diaporama then sc#slide_show true; GluMat.perspective ~fovy:60.0 ~aspect:(1.0 *. float 800 /. float 600) ~z:(0.0001, 80.0); Glut.postRedisplay(); Glut.mainLoop(); (* }}} *) (* vim:cindent sw=2 ts=2 sts=2 et fdm=marker *)