Source file render.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    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, version 3 of the License.       *)
(*                                                                               *)
(*    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.                               *)
(*                                                                               *)
(*    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., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Rendering utilities. *)

open Tsdl
open Misc

include (val Log.create_src "stk.render")

[@@@landmark "auto"]

let set_draw_color rend color =
  let (r,g,b,a) = Color.to_int8s color in
  Sdl.set_render_draw_color rend r g b a

let with_color rend color f =
  let> (r,g,b,a) = Sdl.get_render_draw_color rend in
  let> () = set_draw_color rend color in
  let x = f rend in
  let> () = Sdl.set_render_draw_color rend r g b a in
  x

let fill_rect rend rect color =
  debug (fun m -> m "Render.fill_rect rect=%a color=%#lx"
    (fun fmt -> function None -> () | Some r -> G.pp fmt r) rect
       color);
  with_color rend color
    (fun r ->
       let rect = Option.map G.to_rect rect in
       let>() = Sdl.render_fill_rect r rect in ())

let draw_line_color rend x1 y1 x2 y2 color =
  debug (fun m -> m "Render.draw_line_color x1=%d, y1=%d, x2=%d, y2=%d color=%#lx"
     x1 y1 x2 y2 color);
  with_color rend color
    (fun r -> let>() = Sdl.render_draw_line r x1 y1 x2 y2 in ())

let draw_rect rend rect color =
  debug (fun m -> m "Render.draw_rect rect=%a color=%#lx"
    (fun fmt -> function None -> () | Some r -> G.pp fmt r) rect
       color);
  with_color rend color
    (fun r ->
       let rect = Option.map G.to_rect rect in
       let>() = Sdl.render_draw_rect r rect in ())

let render_copy rend ~src ~dst tex =
  debug (fun m -> m "Render.render_copy src=%a dst=%a" G.pp src G.pp dst);
  let src = G.to_rect src in
  let dst = G.to_rect dst in
  Sdl.render_copy ~src ~dst rend tex


let render_borders rend ~offset:(x,y) ~g geom bw bc =
  let g = G.translate ~x ~y g in
  let geom = G.translate ~x ~y geom in
  debug (fun m -> m "Render.render_borders offset=(%d,%d) g=%a geom=%a" x y G.pp g G.pp geom);
  debug (fun m -> m "Render.render_borders width=%a color=%a"
     Props.(pp_prop border_width) bw
     Props.(pp_prop border_color) bc);

  (let h = bw.Props.top in
   if h > 0 then
     match G.inter geom { g with h } with
     | None -> ()
     | rect -> fill_rect rend rect bc.Props.top
  );
  (let h = bw.Props.bottom in
   if h > 0 then
     match G.inter geom { g with y = g.y + g.h - h } with
   | None -> ()
   | rect -> fill_rect rend rect bc.Props.bottom
  );
  let rec render_v col op bw (g:G.t) =
    if bw > 0 then
      (
       let g2 = { G.w = 1 ; x = op g.x (bw-1) ; y = g.y + (bw-1) ; h = g.h - (bw-1) * 2 } in
       let () = match G.inter geom g2 with
         | None -> ()
         | rect -> fill_rect rend rect col
       in
       render_v col op (bw-1) g
      )
  in
  render_v bc.left (+) bw.Props.left { g with x = g.x };
  render_v bc.right (-) bw.Props.right {g with x = g.x + g.w - 1}

let draw_circle =
  let draw_point rend x y =
    (*prerr_endline (Printf.sprintf "draw point x=%d, y=%d" (truncate x) (truncate y));*)
    let> () = Sdl.render_draw_point rend (truncate x) (truncate y) in
    ()
  in
  let f ~x ~y ~r rend =
    (*prerr_endline (Printf.sprintf "draw_circle x=%d, y=%d, r=%d" x y r);*
    let> (red,green,blue,alpha) = Sdl.get_render_draw_color rend in
    *)
    let cx = float x -. 0.5 in
    let cy = float y -. 0.5 in
    let r = float r in
    (*let set_alpha x y =
      let x = float (truncate x) +. 0.5 in
      let y = float (truncate y) +. 0.5 in
      let r' = hypot (x -. cx) (y -. cy) in
      let alpha' = truncate (float alpha *. ((r -. (40. *. abs_float (r -. r'))) /. r)) in
      prerr_endline (Printf.sprintf "r=%f, r'=%f, x=%f, y=%f, alpha=%d, alpha'=%d"
       r r' x y alpha alpha');
      Sdl.set_render_draw_color rend red green blue alpha'
    in
    *)
    (* translated from https://gist.github.com/derofim/912cfc9161269336f722
       with alpha computation added. *)
    (* if the first pixel in the screen is represented by (0,0) (which is in sdl)
       remember that the beginning of the circle is not in the middle of the pixel
       but to the left-top from it: *)
    let error = ref (-. r) in
    let x = ref (r -. 0.5) in
    let y = ref 0.5 in
    while (x >= y) do
      (*set_alpha (cx +. !x) (cy +. !y) ;*)
      draw_point rend (cx +. !x) (cy +. !y) ;
      draw_point rend (cx +. !y) (cy +. !x) ;

      if (!x <> 0.) then
        (
         draw_point rend (cx -. !x) (cy +. !y) ;
         draw_point rend (cx +. !y) (cy -. !x) ;
        );

      if (!y <> 0.) then
        (
         draw_point rend (cx +. !x) (cy -. !y) ;
         draw_point rend (cx -. !y) (cy +. !x) ;
        );

      if (!x <> 0. && !y <> 0.) then
        (
         draw_point rend (cx -. !x) (cy -. !y);
         draw_point rend (cx -. !y) (cy -. !x);
        );

      error := !error +. !y ;
      y := !y +. 1. ;
      error := !error +. !y;

      if (!error >= 0.) then
        (
         x := !x -. 1. ;
         error := !error -. !x;
         error := !error -. !x;
        );
    done;
	in
  fun rend ~x ~y ~r color -> with_color rend color (f ~x ~y ~r)

let draw_circle_in_rect rend r color =
  draw_circle rend ~x:(r.G.x + r.w/2) ~y:(r.y+r.h/2) ~r:(r.w/2) color

let fill_circle =
  let draw_line rend x1 y1 x2 y2 (red,green,blue,alpha) =
    (*prerr_endline (Printf.sprintf "draw line x1=%f, y1=%f, x2=%f, y2=%f"
     x1 y1 x2 y2);*)
    let x2 =
      let x = floor x2 in
      if x2 -. x <= 0.5 then x else ceil x2
    in
    (*prerr_endline (Printf.sprintf "=> draw line x1=%d, y1=%d, x2=%d, y2=%d"
     (truncate x1) (truncate y1) (truncate x2) (truncate y2));*)
(* draw_line gives strange results, with some pixels beyond x2
    let> () = Sdl.render_draw_line rend
      (truncate x1) (truncate y1)
      (truncate x2) (truncate y2)
    in
    ()
*)
    let y = truncate y1 in
    let x1 = truncate x1 in
    let x2 = truncate x2 in
    for x = x1 to x2 do
      if x = x1 || x = x2 then
        (let> () = Sdl.set_render_draw_color rend red green blue (truncate (float alpha *. 0.7)) in ());
      let> () = Sdl.render_draw_point rend x y in
      if x = x1 then
        let> () = Sdl.set_render_draw_color rend red green blue alpha in ()
    done
  in
  (* Note that there is more to altering the bitrate of this
	   method than just changing this value.  See how pixels are
	   altered at the following web page for tips:
	   http://www.libsdl.org/intro.en/usingvideo.html *)
	(*let bpp = 4 in*)
  let f ~x ~y ~r rend =
    let> color = Sdl.get_render_draw_color rend in
    let cx = float x -. 0.5 in
    let cy = float y -. 0.5 in
    let r = float r in

    let dy = ref 1. in
    while !dy <= r do
      (* This loop is unrolled a bit, only iterating through half of the
         height of the circle.  The result is used to draw a scan line and
         its mirror image below it. *)

      (* The following formula has been simplified from our original.  We
         are using half of the width of the circle because we are provided
         with a center and we need left/right coordinates. *)
      let dx = floor(sqrt((2.0 *. r *. !dy) -. (!dy *. !dy))) in
      (*let x = cx -. dx in*)
      let y1 = cy +. !dy -. r in
      let y2 = cy -. !dy +. r in
      let x1 = cx -. dx in
      let x2 = if y1 = y2 then cx +. dx -. 1. else cx +. dx in
      draw_line rend x1 y1 x2 y1 color;
      if y1 <> y2 then draw_line rend x1 y2 x2 y2 color;

      dy := !dy +. 1.
    done
  in
  fun rend ~x ~y ~r color -> with_color rend color (f ~x ~y ~r)

let fill_circle_in_rect rend r color =
  fill_circle rend ~x:(r.G.x + r.w/2) ~y:(r.y+r.h/2) ~r:(r.w/2) color

let with_clip rend clip f =
  let old_clip =
    if Sdl.render_is_clip_enabled rend then
      Some (Sdl.render_get_clip_rect rend)
    else
      None
  in
  let> () = Sdl.render_set_clip_rect rend (Some clip) in
  try
    let res = f rend in
    let> () = Sdl.render_set_clip_rect rend old_clip in
    res
  with e ->
    let> () = Sdl.render_set_clip_rect rend old_clip in
    raise e

let with_target rend f t =
  let old = Sdl.get_render_target rend in
  Sdl.set_render_target rend t ;
  match f rend with
  | exception e -> Sdl.set_render_target rend old; raise e
  | v -> Sdl.set_render_target rend old; v