path: root/sheet.ml

module Option = Tools.Option

type cell = int * int

type search = [
  | `Pattern of ScTypes.result option
  | `Next
  | `Previous
]

module Raw = struct

  module Map = Map.Make(struct
    type t = cell
    let compare (x1, y1) (x2, y2) = Pervasives.compare (y1, x1) (y2, x2)
  end)

  type content = {
    expr    : Expression.t; (** The expression *)
    value   : ScTypes.result option; (** The content evaluated *)
    sink    : Cell.Set.t;   (** All the cell which references this one *)
  }

  (** The sheet is a map which always contains evaluated values. When a cell is
      updated, all the cell which references this value are also updated.
    *)
  and t = content Map.t

  (** An empty cell which does contains nothing *)
  let empty_cell = {
    expr = Expression.Undefined;
    value = None;
    sink = Cell.Set.empty;
  }

  let create = Map.empty

  let get_value id t = begin
    try (Map.find id t).value
    with Not_found ->  None
  end

  let get_expr id t = begin
    try (Map.find id t).expr
    with Not_found -> empty_cell.expr
  end

  (** Extract a value from a reference.
      This function is given to the evaluator for getting the values from a reference.
   *)
  let get_ref from t ref : ScTypes.types option ScTypes.Refs.range = begin

    let extract_values = begin function
      | ScTypes.Result v -> v
      | ScTypes.Error e -> raise e
    end in

    ScTypes.Refs.collect ref
      |> ScTypes.Refs.map (fun coord -> Option.map extract_values (get_value coord t))

  end

  (** Update the value for the given cell.
      Evaluate the new expression and compare it with the previous value.
      @return Some map if the map has been updated
   *)
  let update cell content t = begin
    let new_val = Expression.eval content.expr (get_ref cell t) in
    match content.value with
    | None ->
      (* If the previous value wasn't defined, update the map *)
      Some (Map.add cell { content with value = Some new_val } t)
    | Some old_value ->
      (* If the previous value was defined, update only if result differs *)
      if not (ScTypes.Result.(=) new_val old_value) then
        Some (Map.add cell { content with value = Some new_val } t)
      else
        (* If there is no changes, do not update the map *)
        None
  end


  (** Parse all the successors from an element, apply a function to each of
      them, and return them *)
  let rec traverse (f:(cell -> content -> t -> t option)) source (init, t) = begin

    let rec successors element (parents, succ, t) = begin

      let content = Map.find element t in

      if Cell.Set.mem element parents then (
        (* if the cell has already been visited, mark it in error, and all the
           descendant *)
        let cycle_error = Some (ScTypes.Error Errors.Cycle) in

        if content.value = cycle_error then
          (* The content has already been update, do not process it again *)
          (Cell.Set.empty, succ, t)
        else
          let t = Map.add element { content with value = cycle_error} t
          and set_error cell content t =
            if content.value = cycle_error then
              None
            else
              Some (Map.add cell { content with value = cycle_error} t)
          and succ = Cell.Set.add element succ in
          let succ, t = traverse set_error content (succ, t) in
          (Cell.Set.empty, succ, t)
      ) else (
        begin match f element content t with
        | None ->
          (* The content does not change, we do not update the successors *)
          (Cell.Set.empty, succ, t)
        | Some t' ->
          let parents' = Cell.Set.add element parents in
          let succ' = Cell.Set.add element succ in
          if (Cell.Set.is_empty content.sink) then
            (Cell.Set.empty, succ', t')
          else
            Cell.Set.fold successors content.sink (parents', succ', t')
        end
      )
    end in
    let _, succ, t = Cell.Set.fold successors source.sink (init, init, t) in
    succ, t
  end

  (** Remove the cell from the sheet *)
  let remove_element (id:cell) t : t * content option = begin

    (** Remove the references from each sources.
        If the sources is not referenced anywhere, and is Undefined, remove it
    *)
    let remove_ref cell t = begin
      try let c = Map.find cell t in

        (* Remove all the refs which points to the removed cell *)
        let sink' = Cell.Set.filter ((<>) id) c.sink in
        if Cell.Set.is_empty sink' && not (Expression.is_defined c.expr) then (
          Map.remove cell t )
        else
          Map.add cell {c with sink = sink'} t
      with Not_found -> t
    end in

    begin try
      let c = Map.find id t in
      let t' =
        (** Remove the references from each sources *)
        let sources = Expression.collect_sources c.expr in
        Cell.Set.fold remove_ref sources t in

      (** If there is no references on the cell, remove it *)
      if Cell.Set.is_empty c.sink then (
        Map.remove id t', None)
      else (
        let c = { empty_cell with sink = c.sink } in
        Map.add id c t', (Some c)
      )
    with Not_found -> t, None
    end
  end

  let remove id t = begin
    match remove_element id t with
    | t, None -> Cell.Set.empty, t
    | t, Some content ->
        (** Update all the successors *)
        traverse update content (Cell.Set.singleton id, t)
  end

  let add_element id f t = begin

    (** Add the references in each sources.
        If the sources does not exists, create it.
    *)
    let add_ref cell t = begin
      let c =
        try Map.find cell t
        with Not_found -> empty_cell in
      let c' = { c with sink = Cell.Set.add id c.sink} in
      Map.add cell c' t
    end in

    let t', cell = remove_element id t in
    let cell' = match cell with
    | None -> empty_cell
    | Some x -> x in

    let content = f cell' t' in

    let sources = Expression.collect_sources content.expr in
    let updated = Map.add id content t'
    |> Cell.Set.fold add_ref sources
    in

    (** Update the value for each sink already evaluated *)
    traverse update content (Cell.Set.singleton id, updated)
  end

  let add id expression t = begin
    if not (Expression.is_defined expression) then
      (Cell.Set.empty, t)
    else
      let f cell t = { cell with
        expr = expression ;
        value = Some (Expression.eval expression (get_ref id t))
      } in
      add_element id f t
  end

  let paste id shift content t = begin
    let expr = Expression.shift shift content.expr in
    let f cell t =
      { cell with
        expr = expr ;
        value = Some (Expression.eval expr (get_ref id t))
      } in
    add_element id f t
  end

  exception Found of (int * int)

  let search pattern t = begin

    let _search key content = if content.value = pattern then raise (Found key) in
    try
      Map.iter _search t;
      None
    with Found key -> Some key
  end

  let get_sink id t =
    try (Map.find id t).sink
    with Not_found -> Cell.Set.empty

  (** Fold over each defined value *)
  let fold f a t = begin
    Map.fold (fun key content a ->
      match content.value with
      | None -> a
      | Some x ->
        f a key (content.expr, x)
    ) t a
  end

end

type yank =cell * Raw.content

type t = {
  selected: Selection.t;    (* The selected cell *)
  data: Raw.t;
  history: t list;          (* Unlimited history *)
  yank: (cell * Raw.content) list
}

let undo t = begin match t.history with
  | [] -> None
  | hd::tl -> Some { hd with selected = t.selected }
end

let move direction t =
  let position = Selection.extract t.selected in
  let position' = begin match direction with
  | Actions.Left quant ->  Tools.Tuple2.replace1 (max 1 ((fst position) - quant)) position
  | Actions.Right quant -> Tools.Tuple2.replace1 ((fst position) + quant) position
  | Actions.Up quant ->    Tools.Tuple2.replace2 (max 1 ((snd position) - quant)) position
  | Actions.Down quant ->  Tools.Tuple2.replace2 ((snd position) + quant) position
  | Actions.Absolute (x, y)-> (x, y)
  end in
  if position = position' then
    None
  else
    Some {t with selected = Selection.create position'}

let delete t = begin
  let count, data' = Selection.fold (fun (count, c) t ->
    (count + 1, snd @@ Raw.remove t c)) (0, t.data) t.selected in
  let t' = { t with
    data = data';
    history = t::t.history
  } in
  t', count
end

let yank t = begin

  let shift = Selection.shift t.selected in
  let origin = shift (0, 0) in
  let _yank (count, extracted) cell = begin
    let content =
    try let content = (Raw.Map.find cell t.data) in
    { content with Raw.expr = Expression.shift origin content.Raw.expr }
    with Not_found ->  Raw.empty_cell in

    count + 1, (shift cell,content)::extracted
  end in

  let count, yanked = Selection.fold _yank (0, []) t.selected in
  let t' = { t with yank = List.rev yanked; } in
  t', count
end

let paste t = begin
  (* Origin of first cell *)
  let (shift_x, shift_y) as shift = Selection.extract t.selected in

  let _paste (count, t) ((x, y), content) = begin
    count + 1, snd @@ Raw.paste (shift_x + x, shift_y + y) shift content t
  end in

  let count, data' = List.fold_left _paste (0, t.data) t.yank in
  let t' = { t with data = data'; history = t::t.history } in
  t', count
end

let add expression t = begin
  let id = Selection.extract t.selected in
  let cells, data' = Raw.add id expression t.data in
  cells, { t with data = data'; history = t::t.history}
end

let search action t = begin match action with
  | `Pattern pattern ->
    begin match Raw.search pattern t.data with
    | None -> None
    | Some x -> Some {t with selected = Selection.create x}
    end
  | _ -> None
end

let create data = {
  data = data;
  selected = Selection.create (1, 1);
  history = [];
  yank = [];
}