script.it/shapes/bspline.mli


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

type t

type err = 
  [ `InvalidPath (* Too few points in the path for building the curve *)
  ]

(** Convert a list of points into a beziers curves. 

    At least 4 points are required for building the path.

    [to_bezier ~connexion points] create a list of beziers segments joining all
    the points together. 

    [connexion0] add a virtual point in the begining for helping to get the
    appropriate tangent when connecting path together

    [connexion1] does the same at the end

*)
val to_bezier
  :  ?connexion0:Gg.v2
  -> ?connexion1:Gg.v2
  -> Gg.v2 list 
  -> (Bezier.t array, [> err]) Result.t
open StdLabels

module Helper = struct
  type t = Integer | Bool | String | Any
  [@@deriving show { with_path = false }]

  type argument_repr = { pos : S.pos; t : t }

  type dyn_type = t -> t
  (** Dynamic type is a type unknown during the code.

      For example, the equality operator accept either Integer or String, but
      we expect that both sides of the equality uses the same type.*)

  (** Build a new dynamic type *)
  let dyn_type : unit -> dyn_type =
   fun () ->
    let stored = ref None in
    fun t ->
      match !stored with
      | None ->
          stored := Some t;
          t
      | Some t -> t

  (** Declare an argument for a function. 

 - Either we already know the type and we just have to compare.
 - Either the type shall constrained by another one 
 - Or we have a variable number of arguments. *)
  type argument = Fixed of t | Dynamic of dyn_type | Variable of argument

  let compare :
      ?strict:bool ->
      ?level:Report.level ->
      t ->
      argument_repr ->
      Report.t list ->
      Report.t list =
   fun ?(strict = false) ?(level = Report.Warn) expected actual report ->
    let equal =
      match (expected, actual.t) with
      | _, Any -> true
      | Any, _ -> true
      | String, String -> true
      | Integer, Integer -> true
      | Bool, Bool -> true
      | Bool, Integer when not strict -> true
      | Integer, Bool -> true
      | String, Integer when not strict -> true
      | String, Bool when not strict -> true
      | _, _ -> false
    in
    if equal then report
    else
      let message =
        Format.asprintf "The type %a is expected but got %a" pp expected pp
          actual.t
      in
      Report.message level actual.pos message :: report

  let rec compare_parameter :
      ?strict:bool ->
      ?level:Report.level ->
      argument ->
      argument_repr ->
      Report.t list ->
      Report.t list =
   fun ?(strict = false) ?(level = Report.Warn) expected param report ->
    match expected with
    | Fixed t -> compare ~level t param report
    | Dynamic d ->
        let type_ = d param.t in
        compare ~strict ~level type_ param report
    | Variable c -> compare_parameter ~level c param report

  (** Compare the arguments one by one *)
  let compare_args :
      ?strict:bool ->
      ?level:Report.level ->
      S.pos ->
      argument list ->
      argument_repr list ->
      Report.t list ->
      Report.t list =
   fun ?(strict = false) ?(level = Report.Warn) pos expected actuals report ->
    let tl, report =
      List.fold_left actuals ~init:(expected, report)
        ~f:(fun (expected, report) param ->
          match expected with
          | (Variable _ as hd) :: _ ->
              let check = compare_parameter ~strict ~level hd param report in
              (expected, check)
          | hd :: tl ->
              let check = compare_parameter ~strict ~level hd param report in
              (tl, check)
          | [] ->
              let msg = Report.error param.pos "Unexpected argument" in
              ([], msg :: report))
    in
    match tl with
    | [] | Variable _ :: _ -> report
    | _ ->
        let msg = Report.error pos "Not enougth arguments given" in
        msg :: report
end

module Expression = struct
  type t = { result : Helper.t; pos : S.pos; empty : bool }
  type t' = t

  let v t = t

  let arg_of_repr : t -> Helper.argument_repr =
   fun { result; pos; empty } ->
    ignore empty;
    { pos; t = result }

  (** The variable has type string when starting with a '$' *)
  let ident : (S.pos, t S.repr) S.variable -> t S.repr =
   fun var report ->
    let empty = false in
    match var.name.[0] with
    | '$' -> ({ result = String; pos = var.pos; empty }, report)
    | _ -> ({ result = Integer; pos = var.pos; empty }, report)

  let integer : S.pos -> string -> t S.repr =
   fun pos value report ->
    let int_value = int_of_string_opt value in

    let empty, report =
      match int_value with
      | Some 0 -> (true, report)
      | Some _ -> (false, report)
      | None -> (false, Report.error pos "Invalid integer value" :: report)
    in

    ({ result = Integer; pos; empty }, report)

  let literal : S.pos -> string -> t S.repr =
   fun pos value report ->
    let empty = String.equal String.empty value in
    ({ result = String; pos; empty }, report)

  let function_ : S.pos -> T.function_ -> t S.repr list -> t S.repr =
   fun pos function_ params _acc ->
    (* Accumulate the expressions and get the results, the report is given in
       the differents arguments, and we build a list with the type of the
       parameters. *)
    let types, report =
      List.fold_left params ~init:([], _acc) ~f:(fun (types, report) param ->
          let t, report = param report in
          let arg = arg_of_repr t in
          (arg :: types, report))
    in
    let types = List.rev types
    and default = { result = Any; pos; empty = false } in

    match function_ with
    | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Dyneval | Func | Getobj
    | Instr | Isplay ->
        ({ default with result = Integer }, report)
    | Desc' | Dyneval' | Func' | Getobj' ->
        ({ default with result = String }, report)
    | Iif | Iif' ->
        let d = Helper.dyn_type () in
        let expected = Helper.[ Fixed Bool; Dynamic d; Dynamic d ] in
        let report = Helper.compare_args pos expected types report in
        (* Extract the type for the expression *)
        let result = d Helper.Bool in
        ({ result; pos; empty = false }, report)
    | Input | Input' ->
        (* Input should check the result if the variable is a num and raise a
           message in this case.*)
        let expected = Helper.[ Fixed String ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = String; pos; empty = false }, report)
    | Isnum ->
        let expected = Helper.[ Fixed String ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = Bool; pos; empty = false }, report)
    | Lcase | Lcase' | Ucase | Ucase' ->
        let expected = Helper.[ Fixed String ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = String; pos; empty = false }, report)
    | Len ->
        let expected = Helper.[ Fixed Any ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = Integer; pos; empty = false }, report)
    | Loc ->
        let expected = Helper.[ Fixed String ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = Bool; pos; empty = false }, report)
    | Max | Max' | Min | Min' ->
        let d = Helper.dyn_type () in
        (* All the arguments must have the same type *)
        let expected = Helper.[ Variable (Dynamic d) ] in
        let report = Helper.compare_args pos expected types report in
        let result = d Helper.Bool in
        ({ result; pos; empty = false }, report)
    | Mid | Mid' ->
        let expected = Helper.[ Fixed String; Variable (Fixed Integer) ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = String; pos; empty = false }, report)
    | Msecscount -> ({ result = Integer; pos; empty = false }, report)
    | Rand ->
        let expected = Helper.[ Variable (Fixed Integer) ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = Integer; pos; empty = false }, report)
    | Replace -> ({ result = Integer; pos; empty = false }, report)
    | Replace' -> ({ result = String; pos; empty = false }, report)
    | Rgb -> ({ result = Integer; pos; empty = false }, report)
    | Qspver | Qspver' | Rnd ->
        (* No arg *)
        let report = Helper.compare_args pos [] types report in
        ({ result = Integer; pos; empty = false }, report)
    | Selact -> ({ result = Integer; pos; empty = false }, report)
    | Stattxt -> ({ result = Integer; pos; empty = false }, report)
    | Stattxt' -> ({ result = String; pos; empty = false }, report)
    | Str | Str' ->
        let expected = Helper.[ Variable (Fixed Integer) ] in
        let report = Helper.compare_args pos expected types report in
        ({ default with result = String }, report)
    | Strcomp -> ({ result = Integer; pos; empty = false }, report)
    | Strfind -> ({ result = Integer; pos; empty = false }, report)
    | Strfind' -> ({ result = String; pos; empty = false }, report)
    | Strpos -> ({ result = Integer; pos; empty = false }, report)
    | Trim -> ({ result = Integer; pos; empty = false }, report)
    | Trim' -> ({ result = String; pos; empty = false }, report)
    | Val ->
        let expected = Helper.[ Fixed Any ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = Integer; pos; empty = false }, report)

  (** Unary operator like [-123] or [+'Text']*)
  let uoperator : S.pos -> T.uoperator -> t S.repr -> t S.repr =
   fun pos operator t1 report ->
    let t, report = t1 report in
    match operator with
    | Add -> (t, report)
    | Neg | No ->
        let types = [ arg_of_repr t ] in
        let expected = Helper.[ Fixed Integer ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = Integer; pos; empty = false }, report)

  let boperator : S.pos -> T.boperator -> t S.repr -> t S.repr -> t S.repr =
   fun pos operator t1 t2 report ->
    let t1, report = t1 report in
    let t2, report = t2 report in
    let types = [ arg_of_repr t1; arg_of_repr t2 ] in
    match operator with
    | T.Plus ->
        (* Operation over number *)
        let d = Helper.(dyn_type ()) in
        let expected = Helper.[ Dynamic d; Dynamic d ] in
        let report = Helper.compare_args pos expected types report in
        let result = d Helper.Integer in
        ({ result; pos; empty = false }, report)
    | T.Eq | T.Neq ->
        (* If the expression is '' or 0, we accept the comparaison as if
            instead of raising a warning *)
        if t1.empty || t2.empty then
          ({ result = Bool; pos; empty = false }, report)
        else
          let d = Helper.(Dynamic (dyn_type ())) in
          let expected = [ d; d ] in
          let report =
            Helper.compare_args ~strict:true pos expected (List.rev types)
              report
          in
          ({ result = Bool; pos; empty = false }, report)
    | Lt | Gte | Lte | Gt ->
        let d = Helper.(Dynamic (dyn_type ())) in
        let expected = [ d; d ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = Bool; pos; empty = false }, report)
    | T.Mod | T.Minus | T.Product | T.Div ->
        (* Operation over number *)
        let expected = Helper.[ Fixed Integer; Fixed Integer ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = Integer; pos; empty = false }, report)
    | T.And | T.Or ->
        (* Operation over booleans *)
        let expected = Helper.[ Fixed Bool; Fixed Bool ] in
        let report = Helper.compare_args pos expected types report in
        ({ result = Bool; pos; empty = false }, report)
end

module Instruction = struct
  type t = unit
  type t' = unit

  let v = Fun.id

  type expression = Expression.t' S.repr

  (** Call for an instruction like [GT] or [*CLR] *)
  let call : S.pos -> T.keywords -> expression list -> t S.repr =
   fun _pos _ expressions report ->
    List.fold_left expressions ~init:((), report)
      ~f:(fun ((), report) expression ->
        let result, report = expression report in
        ignore result;
        ((), report))

  let location : S.pos -> string -> t S.repr = fun _pos _ report -> ((), report)

  (** Comment *)
  let comment : S.pos -> t S.repr = fun _pos report -> ((), report)

  (** Raw expression *)
  let expression : expression -> t S.repr =
   fun expression report -> ((), snd (expression report))

  let if_ :
      S.pos ->
      (expression, t) S.clause ->
      elifs:(expression, t) S.clause list ->
      else_:t S.repr list ->
      t S.repr =
   fun _pos clause ~elifs ~else_ report ->
    (* Helper function *)
    let fold_clause :
        t * Report.t list -> (expression, t) S.clause -> t * Report.t list =
     fun ((), report) (_pos, expr, instructions) ->
      let result, report = expr report in
      let report =
        Helper.compare Helper.Bool (Expression.arg_of_repr result) report
      in
      List.fold_left instructions ~init:((), report)
        ~f:(fun ((), report) instruction -> instruction report)
    in

    (* Traverse the whole block recursively *)
    let report = fold_clause ((), report) clause in
    let report = List.fold_left elifs ~f:fold_clause ~init:report in
    List.fold_left else_ ~init:report ~f:(fun ((), report) instruction ->
        instruction report)

  let act : S.pos -> label:expression -> t S.repr list -> t S.repr =
   fun _pos ~label instructions report ->
    let result, report = label report in
    let report =
      Helper.compare Helper.String (Expression.arg_of_repr result) report
    in
    List.fold_left instructions ~init:((), report)
      ~f:(fun ((), report) instruction -> instruction report)

  let assign :
      S.pos ->
      (S.pos, expression) S.variable ->
      T.assignation_operator ->
      expression ->
      t S.repr =
   fun pos variable _ expression report ->
    let right_expression, report = expression report in
    match right_expression.empty with
    | true -> ((), report)
    | false ->
        let expr1, report = Expression.ident variable report in
        let op1 = Expression.arg_of_repr expr1 in
        let op2 = Expression.arg_of_repr right_expression in

        let d = Helper.dyn_type () in
        (* Every part of the assignation should be the same type *)
        let expected = Helper.[ Dynamic d; Dynamic d ] in
        ( (),
          Helper.compare_args ~level:Report.Debug pos expected [ op1; op2 ]
            report )
end

module Location = struct
  type repr = Report.t list -> Report.t list
  type instruction = Instruction.t S.repr

  let location : S.pos -> instruction list -> repr =
   fun _pos instructions report ->
    let (), report =
      List.fold_left instructions ~init:((), report)
        ~f:(fun ((), report) instruction -> instruction report)
    in
    report
end