mlImage/showtext.ml at master · answer-42/mlImage · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
(*
 * "THE BEER-WARE LICENSE" (Revision 42):
 * <sebastian.benque@gmail.com> wrote this file. As long as you retain this notice you
 * can do whatever you want with this stuff. If we meet some day, and you think
 * this stuff is worth it, you can buy me a beer in return Sebastian Benque
*)

open Batteries
open Imagetypes

(*
let font_name = "Tuffy_Bold.ttf"
*)
let font_name = "/usr/share/fonts/TTF/DejaVuSansMono.ttf"

(** This function initalizes the fontsystem and returns the font that we will
 * use in subsequent calls to render fonts. Fonts will be added to the state. *)
let init_fonts =
  Sdlttf.init ();
  at_exit Sdlttf.quit;
  Sdlttf.open_font font_name 20

(** Create surface containing the filename *)
let render_info state =
  (* Create the text surface *)
  let text = Sdlttf.render_text_solid state.font
                                      state.image_list.(state.current_image_id)
                                      ~fg:Sdlvideo.white
  in
  (* Get the size of the resulting text *)
  let (w,h) = Sdlttf.size_text state.font
                               state.image_list.(state.current_image_id)
  in
  (* Blip text on image *)
  let rect = { Sdlvideo.r_x = 0;
               Sdlvideo.r_y = 0;
               Sdlvideo.r_w = w;
               Sdlvideo.r_h = h;
             }
  in
  (* Create the black canvas where we write the text on *)
  Sdlvideo.fill_rect ~rect:rect state.screen Int32.zero;
  (* Write the text on the canvas *)
  Sdlvideo.blit_surface text state.screen ()

let render_help state =
  let text = ["esc       Quit the program";
              "right     Next image";
              "left      Prev image";
              "a         Move image left";
              "d         Move image right";
              "s         Move image down";
              "w         Move image up";
              "i         Zoom in";
              "o         Zoom out";
              "f         Fit image";
              "z         Full image";
              "t         Show file name";
              "h         Show this help text";
              "n         Don't show any text"]
  in
  let h = Sdlttf.font_height state.font in
  let w = List.max @@ List.map (fst % Sdlttf.size_text state.font) text in
  let rect = { Sdlvideo.r_x = 0;
               Sdlvideo.r_y = 0;
               Sdlvideo.r_w = w;
               Sdlvideo.r_h = h*(List.length text);
             }
  in
  (* Create the black canvas where we write the text on *)
  Sdlvideo.fill_rect ~rect:rect state.screen Int32.zero;
  (* Write the text on the canvas *)
  List.iteri (fun n x ->
    let t = Sdlttf.render_text_solid state.font x ~fg:Sdlvideo.white in
    Sdlvideo.blit_surface ~dst_rect:{rect with Sdlvideo.r_y = h*n}
                          ~src:t
                          ~dst:state.screen ())
             text