Source file key.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                                          *)
(*                                                                               *)
(*********************************************************************************)

open Tsdl

let key_is_mod =
  let module I = Set.Make(Int) in
  let mod_keys = I.of_list
    Sdl.K.( [
       lctrl ; lshift ; lalt ; lgui ;
       rctrl ; rshift ; ralt ; rgui ;
       mode ])
  in
  fun k -> I.mem k mod_keys

type keystate = {
    key: Sdl.keycode ;
    mask: Sdl.keymod ;
    mods: Sdl.keymod ;
    pred: Sdl.keymod -> bool ;
  }

let compare_keystate k1 k2 =
  match Stdlib.compare k1.key k2.key with
  | 0 ->
      (match Stdlib.compare k1.mask k2.mask with
       | 0 -> Stdlib.compare k1.mods k2.mods
       | n -> n
      )
  | n -> n

let keystate_equal k1 k2 =
  k1.key = k2.key &&
  k1.mask = k2.mask &&
  k1.mods = k2.mods

let pp_keystate ppf k =
  Format.fprintf ppf "{key=%s, mask=%x, mods=%x}"
    Sdl.(get_key_name k.key) k.mask k.mods

(**/**)

let lr_mods = Sdl.Kmod.(gui + alt + shift + ctrl)

let lr_test left right kmod =
  let both = left lor right in
(*  prerr_endline (Printf.sprintf "lr_test: left=%x right=%x both=%x" left right both);*)
  let kmod_both = kmod land both in
(*  prerr_endline (Printf.sprintf "lr_test: kmod_both=%x" kmod_both);*)
  if kmod_both = both then
    (fun m ->
       let b = m land left > 0 || m land right > 0 in
(*       [%debug "fun m=%x -> m land %x > 0 || m land %x > 0 = %b"
         m left right b);*)
       b
    )
  else
    if kmod_both = 0 then
      (fun m -> m land both = 0)
    else
      if kmod_both = left then
        (fun m -> m land left > 0)
      else
        (fun m -> m land right > 0)

let mk_lr_tests =
  let open Sdl.Kmod in
  let l =
    [ lr_test lshift rshift ;
      lr_test lalt ralt ;
      lr_test lctrl rctrl ;
      lr_test lgui rgui ;
    ]
  in
  fun mods ->
    let l = List.map (fun f -> f mods) l in
    fun m -> List.for_all (fun f -> f m) l

let build_pred mods =
(*  prerr_endline (Printf.sprintf "build_pred: mods=%x" mods);*)
  let lr_pred = mk_lr_tests mods in
  let mods = mods land (lnot lr_mods) in
(*  prerr_endline (Printf.sprintf "build_pred: mods land (lnot lr_mods)=%x" mods);*)
  let eq m = m land mods = mods in
  fun m -> lr_pred m && eq m
(**/**)

let default_keymask = ref Sdl.Kmod.(reserved+mode)
let set_default_keymask n = default_keymask := n
let default_keymask () = !default_keymask

let default_keymods = ref Sdl.Kmod.none
let set_default_keymods n = default_keymods := n
let default_keymods () = !default_keymods

let keystate ?(mask=default_keymask())?(mods=default_keymods()) key =
  { key ; mask ; mods ; pred = build_pred mods }

let match_keys ks ~key ~kmod =
  [%debug "match_keys ks=%a key=%s kmod=%x lr_mods=%x"
    pp_keystate ks
    Sdl.(get_key_name key) kmod lr_mods];
  key = ks.key && ks.pred (kmod land lnot ks.mask)

module Lexer =
  struct
    let shift = [%sedlex.regexp? 'S']
    let lshift = [%sedlex.regexp? "lS"]
    let rshift = [%sedlex.regexp? "rS"]
    let ctrl = [%sedlex.regexp? 'C']
    let lctrl = [%sedlex.regexp? "lC"]
    let rctrl = [%sedlex.regexp? "rC"]
    let alt = [%sedlex.regexp? 'A']
    let lalt = [%sedlex.regexp? "lA"]
    let ralt = [%sedlex.regexp? "rA"]
    let gui = [%sedlex.regexp? 'G']
    let lgui = [%sedlex.regexp? "lG"]
    let rgui = [%sedlex.regexp? "rG"]
    let num = [%sedlex.regexp? 'N']
    let caps = [%sedlex.regexp? 'L']
    let mode = [%sedlex.regexp? 'M']

    let mods = [%sedlex.regexp? shift | lshift | rshift | ctrl | lctrl | rctrl
      | alt | lalt | ralt | gui | lgui | rgui | num | caps | mode ]
(*    let key = [%sedlex.regexp? Plus(alphabetic | 'a'..'z' | 'A'..'Z' | '0'..'9' |
      Chars(" _-#&*@^:$!>(<%+?'\").[]={},`"))]*)

    let key = [%sedlex.regexp? Plus(20 .. 65000) ]

    let keystate = [%sedlex.regexp? Opt(mods,'/'),Opt(Plus(mods),'-'),key]

(*
    let mod_of_string =
      let open Sdl.Kmod in
      function
      | "S" -> shift
      | "lS" -> lshift
      | "rS" -> rshift
      | "C" -> ctrl
      | "lC" -> lctrl
      | "rC" -> rctrl
      | "A" -> alt
      | "lA" -> lalt
      | "rA" -> ralt
      | "G" -> gui
      | "lG" -> lgui
      | "rG" -> rgui
      | "N" -> num
      | "L" -> caps
      | "M" -> mode
      | _ -> assert false

*)
    let rec parse_mods acc lb =
      let module K = Sdl.Kmod in
      match
        match%sedlex lb with
        | shift -> Some K.shift
        | lshift -> Some K.lshift
        | rshift -> Some K.rshift
        | ctrl -> Some K.ctrl
        | lctrl -> Some K.lctrl
        | rctrl -> Some K.rctrl
        | alt -> Some K.alt
        | lalt -> Some K.lalt
        | ralt -> Some K.ralt
        | gui -> Some K.gui
        | lgui -> Some K.lgui
        | rgui -> Some K.rgui
        | num -> Some K.num
        | caps -> Some K.caps
        | mode -> Some K.mode
        | eof -> None
        | any -> None
        | _ -> None
      with
      | Some m -> parse_mods (acc lor m) lb
      | None -> acc

    let parse spec =
      let lb = Sedlexing.Utf8.from_string spec in
      let m = parse_mods 0 lb in
      let str = Sedlexing.Utf8.lexeme lb in
      let (mask, mods, lb) =
        match str with
        | "/" -> (* parsed a mask *)
            (
             let p = Sedlexing.lexeme_end lb in
             let mo = parse_mods 0 lb in
             match Sedlexing.Utf8.lexeme lb with
             | "-" -> (* parsed a modifier *)
                 (Some m, Some mo, lb)
             | _ -> (* parsed a key identifier or eof, rollback *)
                 let lb = Sedlexing.Utf8.from_string
                   (String.sub spec p (String.length spec - p))
                 in
                 (Some m, None, lb)
            )
        | "-" -> (* parsed a mod *)
            (None, Some m, lb)
        | _ -> (* parsed key identifier or eof, rollback *)
            let lb = Sedlexing.Utf8.from_string spec in
            (None, None, lb)
      in
      match%sedlex lb with
      | key ->
          (
           let str = Sedlexing.Utf8.lexeme lb in
           match Sdl.get_key_from_name str with
           | k when k = Sdl.K.unknown ->
               Ocf.json_error (Printf.sprintf
                "Unknown key name %S in keystate %S" str spec)
           | k -> keystate ?mask ?mods k
          )
      | any ->
          let lexeme = Sedlexing.Utf8.lexeme lb in
          Ocf.json_error (Printf.sprintf
           "Invalid character %s at %d in keystate %S" lexeme
             (Sedlexing.lexeme_start lb) spec)
      | eof ->
          Ocf.json_error (Printf.sprintf
           "Unexpected end of string at character %d in keystate %S"
             (Sedlexing.lexeme_start lb) spec)
      | _ -> assert false

  end

let lr_spec =
  let open Sdl.Kmod in
  [
    'S', (shift, lshift, rshift) ;
    'A', (alt, lalt, ralt) ;
    'C', (ctrl, lctrl, ctrl) ;
    'G', (gui, lgui, rgui) ;
  ]
let simple_spec =
  let open Sdl.Kmod in
  [ 'N', num ; 'L', caps ;'M', mode]

let keystate_of_string = Lexer.parse

let string_of_mods mods =
  let b = Buffer.create 25 in
  List.iter
    (fun (c, (both,left,right)) ->
       if mods land both > 0 then
         Buffer.add_char b c
       else
         if mods land left > 0 then
           Printf.bprintf b "l%c" c
         else if mods land right > 0 then
             Printf.bprintf b "r%c" c
    )
    lr_spec;
  List.iter (fun (c, m) ->
     if mods land m > 0 then Buffer.add_char b c)
    simple_spec;
  Buffer.contents b

let string_of_keystate t =
  let mods =
    if t.mods = Sdl.Kmod.none then
      ""
    else
      Printf.sprintf "%s-" (string_of_mods t.mods)
  in
  let mask =
    if t.mask <> default_keymask () then
      (Printf.sprintf "%s/" (string_of_mods t.mask))
    else
      ""
  in
  let key = Sdl.get_key_name t.key in
  Printf.sprintf "%s%s%s" mask mods key

let keystate_ocf_wrapper =
  let to_j ?with_doc t = `String (string_of_keystate t) in
  let from_j ?def = function
  | `String str -> keystate_of_string str
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_j from_j

let keystate_list_ocf_wrapper =
  let from_j ?def json =
    let l =
      match  json with
      | `String s -> [keystate_of_string s]
      | `List l ->
          List.fold_left (fun acc json ->
             (keystate_ocf_wrapper.from_json json :: acc))
            [] l
      | json -> Ocf.invalid_value json
    in
    List.rev l
  in
  let to_j ?with_doc = function
  | [ks] -> keystate_ocf_wrapper.to_json ks
  | l -> `List (List.map (keystate_ocf_wrapper.to_json ?with_doc) l)
  in
  Ocf.Wrapper.make to_j from_j

let keystate_list_of_string str =
  let json = Yojson.Safe.from_string str in
  keystate_list_ocf_wrapper.from_json json

let string_of_keystate_list l =
  Yojson.Safe.to_string (keystate_list_ocf_wrapper.to_json l)

let is_mod_pressed kmod =
  let m = Sdl.get_mod_state () in
  m land kmod <> 0

let shift_pressed () =
  Sdl.Kmod.(is_mod_pressed (lshift lor rshift))

let ctrl_pressed () =
  Sdl.Kmod.(is_mod_pressed (lctrl lor rctrl))

let css_keystate_parser ctx =
 let open Angstrom in
  (Css.Vp.string ctx >>= fun s -> Css.U.ws ctx *>
    take_while1 (fun c -> not (Css.U.is_ws c)) >>= fun s ->
    return (keystate_of_string s)
  ) <?> "keystate"