(** Interpréteur BF pur *)

(* On repart de la même base qu'avant *)

type memory_command =
  | MoveLeft  (* caractère '<' *)
  | MoveRight (* caractère '>' *)
  | Increment (* caractère '+' *)
  | Decrement (* caractère '-' *)

type io_command =
  | Write (* caractère '.' *)
  | Read  (* caractère ',' *)

type control_command =
  | LoopBegin (* caractère '[' *)
  | LoopEnd   (* caractère ']' *)

type command =
  | Memory of memory_command
  | IO of io_command
  | Control of control_command

let command_to_string : command -> string = function
  | Memory MoveLeft -> "<"
  | Memory MoveRight -> ">"
  | Memory Increment -> "+"
  | Memory Decrement -> "-"
  | IO Write -> "."
  | IO Read -> ","
  | Control LoopBegin -> "["
  | Control LoopEnd -> "]"

type 'a list_and_pointer = {
  before : 'a list;
  after : 'a list;
}

type data_state = char list_and_pointer

type code_state = command list_and_pointer

(* On maintient en plus de ce qu'on avait initialement dans l'état :
   - l'entrée restante à traiter
   - la sortie qui a été produite (représentée à l'envers par simplicité, pour ajouter les caractères en devant de la liste) *)
type state = {
  code : code_state;
  data : data_state;
  input : char list;
  output : char list;
}

let memory_size : int = 256

let initial_data_state : data_state = {
  before = [];
  after = List.init memory_size (fun _ -> Char.chr 0);
}

type program = command list

let initial_control_state (program : program) : code_state = {
  before = [];
  after = program
}

(* L'état initial prendra une chaîne de caractère d'entrée, correspondant à l'entrée utilisateur *)
let initial_state (program : program) (input : char list) : state = {
  code = initial_control_state program;
  data = initial_data_state;
  input;
  output = [];
}

exception OutsideMemory

let move_right (l : 'a list_and_pointer) : 'a list_and_pointer =
  match l.after with
  | [] -> raise OutsideMemory
  | cell :: after -> { before = cell :: l.before; after = after }

let move_left (l : 'a list_and_pointer) : 'a list_and_pointer =
  match l.before with
  | [] -> raise OutsideMemory
  | cell :: before -> { before = before; after = cell :: l.after }

let read_cell (l : 'a list_and_pointer) : 'a =
  match l.after with
  | [] -> raise OutsideMemory
  | cell :: _ -> cell

let write_cell (new_cell : char) (state : data_state) : data_state =
  match state.after with
  | [] -> raise OutsideMemory
  | _ :: after -> { state with after = new_cell :: after }

let increment_cell (state : data_state) : data_state =
  write_cell (Char.chr (Char.code (read_cell state) + 1)) state

let decrement_cell (state : data_state) : data_state =
  write_cell (Char.chr (Char.code (read_cell state) - 1)) state

let eval_memory_command (command : memory_command) (state : data_state) : data_state =
  match command with
  | MoveLeft -> move_left state
  | MoveRight -> move_right state
  | Increment -> increment_cell state
  | Decrement -> decrement_cell state

exception End_of_input (* erreur qui sera levée si on lit plus loin que ce qui est disponible *)

(* Afficher un caractère revient à le stocker dans l'output *)
let print_char (c : char) (state : state) : state =
  { state with output = c :: state.output }

(* Lire un caractère revient à le lire depuis l'input *)
let read_char (state : state) : (char * state) =
  match state.input with
  | [] -> raise End_of_input
  | c :: rest -> (c, { state with input = rest })

let eval_io_command (command : io_command) (state : state) : state =
  match command with
  | Write ->
    let c = read_cell state.data in
    print_char c state
  | Read ->
    let c, state' = read_char state in
    write_cell c state'

let rec do_until_matching
    (c_open : control_command)
    (c_close : control_command)
    (action : code_state -> code_state)
    (state : code_state) : code_state =
  let rec helper (cur_state : code_state) (count : int) : code_state =
    let cell = read_cell cur_state in
    match cell with
    | Control c when c = c_close && count = 0 ->
      cur_state
    | Control c when c = c_close ->
      helper (action cur_state) (count - 1)
    | Control c when c = c_open ->
      helper (action cur_state) (count + 1)
    | _ ->
      helper (action cur_state) count
  in
  helper (action state) 0

let eval_control_command (command : control_command) (state : state) : code_state =
  match (command, read_cell state.data)  with
  | LoopBegin, '\000' -> do_until_matching LoopBegin LoopEnd move_right state.code
  | LoopBegin, _ -> state.code
  | LoopEnd, '\000' -> state.code
  | LoopEnd, _ -> do_until_matching LoopEnd LoopBegin move_left state.code

let step_command (command : command) (state : state) : state =
  match command with
  | Memory c ->
    { state with data = eval_memory_command c state.data }
  | IO c ->
    eval_io_command c state
  | Control c ->
    { state with code = eval_control_command c state }

let step (state : state) : state =
  step_command (read_cell state.code) state

let at_end (state : state) : bool =
  state.code.after = []

let rec eval_commands (state : state) : state =
  if at_end state then
    state
  else
    let state' = step state in
    eval_commands { state' with code = move_right state'.code }

let explode (s : string) : char list = List.init (String.length s) (String.get s)
let implode (l : char list) : string = String.of_seq (List.to_seq l)

let eval (program : command list) (input : string) : string =
  let final_state = eval_commands (initial_state program (explode input)) in
  implode (List.rev final_state.output)

let parse (program : string) : command list =
  let parse_char = function
    | '[' -> Some (Control LoopBegin)
    | ']' -> Some (Control LoopEnd)
    | '.' -> Some (IO Write)
    | ',' -> Some (IO Read)
    | '+' -> Some (Memory Increment)
    | '-' -> Some (Memory Decrement)
    | '>' -> Some (Memory MoveRight)
    | '<' -> Some (Memory MoveLeft)
    | _ ->  None in
  program |> String.to_seq |> List.of_seq |> List.filter_map parse_char

let run (program : string) (input : string) : string =
  eval (parse program input)