Require Import Coqlib Errors.
Require Import BinNums NPeano.
Require Import String.
Require Import Types.
Require Import Tree.
Require Import StringtoInt.

Local Open Scope string_scope.

(* full version with TConst Constructor*)
Definition typecheck_constant (envs : id_scope) (c : constant) : res ty :=
  match c with
  | Const_Identifier id => find_scope_id id envs
  | Const_Int x => OK (TConst TInt (StringtoInt.Decimal.to_Z (get_idname x)))
  | Const_Hex x => OK (TConst (THexes (pred (pred (length (get_idname x))))) (StringtoInt.Hex.to_Z (get_idname x)))
  | Const_Bit x => OK (TConst (TBits (length (get_idname x))) (StringtoInt.Binary.to_Z (get_idname x)))
  end.

(* Test constant *)
(*
Check typecheck_constant.
Check "123".

Compute typecheck_constant empty_id_env (Const_Int {| name:="-1234"; key:=3 |}).
Compute typecheck_constant empty_id_env (Const_Hex {| name:="-0x123afe"; key:=4 |}).
Compute typecheck_constant empty_id_env (Const_Bit {| name:="-0b101010101"; key:=5 |}).
Compute typecheck_constant (("id1",TConst TInt 5)::nil) (Const_Identifier {| name:="id1"; key:=6 |}).
 *)

(*only constexpr?*)
Definition typecheck_unary (u : unary_operator) (oty : res ty) :=
  match oty with
  | Error e => Error e
  | OK ty =>
               match u, ty with
               | Unary_Int, (TConst t val) => OK (TConst TInt val)
               | Unary_Not, TBool => OK TBool
               | Unary_Tilde, (TConst (TBits x) val) => OK (TConst (TBits x) (StringtoInt.Binary.neg x val))
               | uo, t => Error (msg "type error in unary expression.")
               end

  end.

(*Test unary *)

(*
Check typecheck_unary.
Compute typecheck_unary Unary_Int (Some (TConst TInt 123)).
Compute typecheck_unary Unary_Int (Some (TConst (TBits 4) 8)).
Compute typecheck_unary Unary_Int (Some (TConst (THexes 2) 16)).
Compute typecheck_unary Unary_Int (Some (TBool)).
Compute typecheck_unary Unary_Int None.
Compute typecheck_unary Unary_Not (Some TBool).
Compute typecheck_unary Unary_Not (Some (TConst TInt 123)).
Compute typecheck_unary Unary_Not None.
Compute typecheck_unary Unary_Tilde (Some (TConst (TBits 4) 8)).
Compute typecheck_unary Unary_Tilde (Some (TConst (TBits 4) (-2))).
Compute typecheck_unary Unary_Tilde (Some (TConst (TBits 1) 0)).
Compute typecheck_unary Unary_Tilde (Some (TConst (TBits 3) 0)).
Compute typecheck_unary Unary_Tilde (Some (TConst (TInt) 3)).
Compute typecheck_unary Unary_Tilde None.
*)
(* need to check both t1 and t2 are const types*)

Definition typecheck_binary (b : binary_operator) (ot1 ot2 : res ty) :=
  match ot1, ot2 with
  | OK t1, OK t2 =>
    match b, t1, t2 with
    (*a + b*)
    | Binary_Add, TConst _ val1, TConst _ val2 => OK (TConst TInt (val1 + val2)) (* const expr*)
    | Binary_Add, TX _, _ => Error (msg "type error in add expression")
    | Binary_Add, _, TX _ => Error (msg "type error in add expression")
    | Binary_Add, _, _ => OK TInt
    (*a - b*)
    | Binary_Sub, TConst _ val1, TConst _ val2 => OK (TConst TInt (val1 - val2)) (* const expr *)
    | Binary_Sub, TX _, _ => Error (msg "type error in sub expression")
    | Binary_Sub, _, TX _ => Error (msg "type error in sub expression")
    | Binary_Sub, _, _ => OK TInt
    (*a * b*)
    | Binary_Mul, TConst _ val1, TConst _ val2 => OK (TConst TInt (val1 * val2)) (* cosnt expr *)
    | Binary_Mul, TX _, _ => Error (msg "type error in mul expression")
    | Binary_Mul, _ ,TX _ => Error (msg "type error in mul expression")
    | Binary_Mul, _, _ => OK TInt
    (*a / b*)
    | Binary_Div, TConst _ val1, TConst _ val2 => OK (TConst TInt (Zdiv val1 val2)) (* const expr *)
    | Binary_Div, TX _, _ => Error (msg "type error in div expression")
    | Binary_Div, _, TX _ => Error (msg "type error in div expression")
    | Binary_Div, _, _ => OK TInt
    (*a % b*)
    | Binary_Mod, TConst _ val1, TConst _ val2 => OK (TConst TInt (Zmod val1 val2)) (* const expr *)
    | Binary_Mod, TX _, _ => Error (msg "type error in mod expression")
    | Binary_Mod, _, TX _ => Error (msg "type error in mod expression")
    | Binary_Mod, _, _ => OK TInt
    (*a && b*)
    | Binary_AndAnd, TBool, TBool => OK TBool
    (*a || b*)
    | Binary_OrOr, TBool, TBool => OK TBool
    (*a & b*)
    | Binary_And, TConst (TBits n1) val1, TConst (TBits n2) val2 => if Nat.eqb n1 n2 then OK (TConst (TBits n1) (StringtoInt.Binary.and n1 val1 val2)) else Error (msg "two bits type have different length during add operation")
    (*a | b*)
    | Binary_Or, TConst (TBits n1) val1, TConst (TBits n2) val2 => if Nat.eqb n1 n2 then OK (TConst (TBits n1) (StringtoInt.Binary.or val1 val2)) else Error (msg "two bits type have different length during or operation")
    (*a ^ b*)
    | Binary_Xor, TConst (TBits n1) val1, TConst (TBits n2) val2 => if Nat.eqb n1 n2 then OK (TConst (TBits n1) (StringtoInt.Binary.xor n1 val1 val2)) else Error (msg "two bits type have different length during xor operation")
    (*a == b*)
    | Binary_EqEq, _, _ => OK TBool
    (*a <> b*)
    | Binary_Neq, _, _ => OK TBool
    (*a < b*)
    | Binary_Les, _, _ => OK TBool
    (*a > b*)
    | Binary_Gre, _, _ => OK TBool
    (*a <= b*)
    | Binary_LesEq, _, _ => OK TBool
    (*a >= b*)
    | Binary_GreEq, _, _ => OK TBool
    (*a << b*)
    | Binary_LesLes, TConst t v1, TConst TInt v2 => OK (TConst TInt (Z.mul v1 (Z.pow 2 v2))) (*const expr*)
    | Binary_LesLes, TX _, _ => Error (msg "type error in left shift operation")
    | Binary_LesLes, _, TX _ => Error (msg "type error in left shift operation")
    | Binary_LesLes, _ , _ => OK TInt
    (*a >> b*)
    | Binary_GreGre, TConst t v1, TConst TInt v2 => OK (TConst TInt (Z.div v1 (Z.pow 2 v2))) (*const expr*)
    | Binary_GreGre, TX _, _ => Error (msg "type error in right shift operation")
    | Binary_GreGre, _, TX _ => Error (msg "type error in right shift operation")
    | Binary_GreGre, _, _ => OK TInt
    (*a ++ b*)
    | Binary_AddAdd, TConst (TBits n1) v1, TConst (TBits n2) v2 => OK (TConst (TBits (n1+n2)) (StringtoInt.Binary.bc n1 n2 v1 v2))
    | Binary_AddAdd, TConst (THexes n1) v1, TConst (THexes n2) v2 => OK (TConst (THexes (n1+n2)) (StringtoInt.Hex.bc n1 n2 v1 v2))
    | Binary_AddAdd, TRegAcc k1 n1 n2, TRegAcc k2 m1 m2 =>
      let test := Nat.eqb k1 k2 && Nat.eqb n2 (m1 + 1) && Nat.leb 0 m2 && Nat.leb m2 m1 && Nat.leb m1 n2 && Nat.leb n2 n1 && Nat.ltb n1 k1 in
      if test then OK (TRegAcc k1 n1 m2)
      else Error (msg "type error during register append")
    | Binary_AddAdd, TFieldAcc_cell id1 k1 n1 n2, TFieldAcc_cell id2 k2 m1 m2 =>
      let test := eqb_string (get_idname id1) (get_idname id2) && Nat.eqb k1 k2 && Nat.eqb m1 (n2 + 1) && Nat.leb 0 n1 && Nat.leb n1 n2 && Nat.leb n2 m1 && Nat.leb m1 m2 && Nat.ltb m2 k1 in
      if test then OK (TFieldAcc_cell id1 k1 n1 m2)
      else Error (msg "type error during field append in cell")
    | Binary_AddAdd, TFieldAcc_protocol k1 n1 n2, TFieldAcc_protocol k2 m1 m2 =>
      let test := Nat.eqb k1 k2 && Nat.eqb m1 (n2 + 1) && Nat.leb 0 n1 && Nat.leb n1 n2 && Nat.leb n2 m1 && Nat.leb m1 m2 && Nat.ltb m2 k1 in
      if test then OK (TFieldAcc_protocol k1 n1 m2)
      else Error (msg "type error during field append in protocol")
    (*hex(n) a*)
    | Binary_Hex, TConst t m, TConst TInt n => if (0 <=? m) && ((Z.of_nat ((length (StringtoInt.Hex.of_Z m)) - 2)) <=? n) then OK (TConst (THexes (N.to_nat (Z.to_N n))) m) else Error (msg "type error during cast to hex")
    (*bit(n) a*)
    | Binary_Bit, TConst t m, TConst TInt n => if (0 <=? m) && ((Z.of_nat ((length (StringtoInt.Binary.of_Z m)) - 2)) <=? n) then OK (TConst (TBits (N.to_nat (Z.to_N n))) m) else Error (msg "type error during cast to bit")
    | _,_,_ => Error (msg "binary operator was not matched to the type")
    end
  | Error e1, _ => Error e1
  | _, Error e2 => Error e2
  end.

(* Test binary*)
(* Todo *)

Fixpoint efield_sum (flds : list (string * nat)) (sum_n : nat) :=
  match flds with
  | nil => sum_n
  | (fid_i, n_i) :: t => efield_sum t (Nat.add sum_n n_i)
  end.

Fixpoint efield_find (fid : string) (flds : list (string * nat)) (sum_n : nat):=
  match flds with
  | nil => Error (msg (String.append fid " was not found in protocol"))
  | (fid_i, n_i) :: t => if (eqb_string fid fid_i) then OK (sum_n, n_i)
                       else efield_find fid t (Nat.add sum_n n_i)
  end.

Definition compare_ofid (ofid : optional_field) (fid : identifier) :=
  match ofid with
  | Optional_Field ofid c => eqb_string (get_idname ofid) (get_idname fid)
  | No_Optional_Field => false
  end.

Definition typecheck_field_expression (pid_envs : pid_scope)
           (id_envs : id_scope) (t : res ty) (fid : identifier) :=
  match t with
  | OK (TX pid) =>
    let protocol := find_scope_id pid pid_envs in
    match protocol with
    | OK (Protocol_Symbol flds ofid statements) =>
      if compare_ofid ofid fid then OK TInt
      else
        let ef := efield_find (get_idname fid) flds 0 in
        match ef with
        | OK (sum_n, n_i) => let n := efield_sum flds 0 in
                            OK (TFieldAcc_cell pid n sum_n (Nat.sub (Nat.add sum_n n_i) 1))
        | Error e' => Error e'
        end
    | Error e'' => Error e''
    end
  | OK _ => Error (msg "expression not support '.' operator")
  | Error e''' => Error e'''
  end.

(*Test field*)
(*Todo*)

Definition typecheck_section_expression (g_envs : g_scope) (envs : id_scope) (tp t1 t2: res ty) :=
  match tp, t1, t2 with
  | OK e1, OK e2, OK e3 =>
    match e1, e2, e3 with
    | TRegAcc n n1 n2, TConst TInt n', TConst TInt n'' =>
      let sn := (find_scope_id Creglen g_envs) in
      match sn with
        | Error e' => Error e'
        | OK n =>
          if (Nat.leb 0 n2) && (Nat.leb n2 n1) && (Nat.ltb n1 n) && (Z.leb 0 n'') && (Z.leb n'' n') && (Z.leb n' (Z.of_N (N.of_nat (n1 - n2)))) then OK (TRegAcc n (n2 + (N.to_nat (Z.to_N n''))) (n2 + (N.to_nat (Z.to_N n')))) else Error (msg "type error in register section expression")
      end
    | TFieldAcc_cell id n n1 n2, TConst TInt n', TConst TInt n'' =>
      if (Nat.leb 0 n1) && (Nat.leb n1 n2) && (Nat.ltb n2 n) && (0 <=? n'') && (n'' <=? n') && (n' <=? (Z.of_N (N.of_nat (Nat.sub n2 n1)))) then OK (TFieldAcc_cell id n (n1 + (N.to_nat (Z.to_N n''))) (n1 + (N.to_nat (Z.to_N n')))) else Error (msg "type error in field section expression in cell")
    | TFieldAcc_protocol n n1 n2, TConst TInt n' , TConst TInt n'' =>
      if (Nat.leb 0 n1) && (Nat.leb n1 n2) && (Nat.ltb n2 n) && (0 <=? n'') && (n'' <=? n') && (n' <=? (Z.of_N (N.of_nat (Nat.sub n2 n1)))) then OK (TFieldAcc_protocol n (n1 + (N.to_nat (Z.to_N n''))) (n1 + (N.to_nat (Z.to_N n')))) else Error (msg "type error in field section expression in protocol")
    | _, _, _ => Error (msg "types were not matched in section expression")
    end
  | Error e1', _, _ => Error e1'
  | _, Error e2', _ => Error e2'
  | _, _, Error e3' => Error e3'
  end.
(*Test section*)
(*Todo*)

Definition typecheck_length_expression (envs : id_scope) (pid_envs : pid_scope) (id : identifier) :=
  let pid := find_scope_id id envs in
  match pid with
  | OK (TX i) => let protocol := find_scope_id i pid_envs in
           match protocol with
           | OK _ => OK TInt
           | Error e' => Error e'
           end
  | OK _ => Error (msg (String.append (get_idname id) " cannot apply length expression"))
  | Error e'' => Error e''
  end.
(*Test length*)
(*Todo*)

Fixpoint typecheck_expression (g_envs: g_scope) (pid_envs: pid_scope)
         (id_envs : id_scope) (e : expression) : res ty:=
  let te:= typecheck_expression g_envs pid_envs id_envs in
  match e with
  | Constant_Expression c =>
    typecheck_constant id_envs c
  | Unary_Expression u e =>
    typecheck_unary u (te e)
  | Binary_Expression b e1 e2 =>
    typecheck_binary b (te e1) (te e2)
  | Field_Expression e fid => typecheck_field_expression pid_envs id_envs (te e) fid
  | Bit_Expression e1 e2 => typecheck_section_expression g_envs id_envs (te e1) (te e2) (te e2)
  | Section_Expression e1 e2 e3 => typecheck_section_expression g_envs id_envs (te e1) (te e2) (te e3)
  | Length_Expression id => typecheck_length_expression id_envs pid_envs id
  | Parentheses_Expression e => te e
  end.

(*-----------statement----------*)

(*Todo*)
Definition get_const_val := fun (c : constant) (id_envs : id_scope) => match typecheck_constant (id_envs) c with
                                          | OK (TConst t' v') => OK v'
                                          | _ => Error (msg "cannot calculate a common expression during type checking")
                                          end.

(*Initialization of L enviorment: p symbol table*)
Fixpoint field_find_id (id : identifier) (index : nat) (flds : list field):=
  match index with
  | O => false
  | S i' =>
    match flds with
    | nil => false
    | (Field id' c) :: t => if eqb_string (get_idname id) (get_idname id') then true
                          else field_find_id id i' t
    end
  end.

Fixpoint trans_fields_raw (flds : list field) (index : nat) (id_envs : id_scope) (whole_flds : list field) :=
  match flds with
  | nil => (true,nil)
  | h :: t => match h with
            | Field id c => if field_find_id id index whole_flds then (false,nil)
                           else let (ok, trans_list) := trans_fields_raw t (S index) id_envs whole_flds in
                                let cval := get_const_val c id_envs in
                                match cval with
                                  | OK v' =>
                                    if (v' >? 0) && ok then (true,((get_idname id),N.to_nat (Z.to_N v')) :: trans_list)
                                    else (false,nil)
                                  | Error _ => (false,nil)
                                end
            end
  end.

Definition trans_protocol_to_symbol (p : protocol) (id_envs : id_scope) : res protocol_symbol :=
  match p with
  | Protocol (Fields flds ofld) statements =>
    let (ok, trans_list) := trans_fields_raw flds 0 id_envs flds in
    if ok then OK (Protocol_Symbol trans_list ofld statements)
    else Error (msg "protocol field error in definition")
  end.
(*Test protocol_to_symbol*)
(*Todo*)

Fixpoint check_reg_overlap (n n1 n2 : nat) (id_envs : id_scope) : bool :=
  match id_envs with
  | nil => true
  | (str, r) :: t => match r with
                   | TRegAcc n' n1' n2' => if (negb (Nat.eqb n' n)) || ((Nat.ltb n1' n2) || (Nat.ltb n1 n2')) then
                                            check_reg_overlap n n1 n2 t
                                          else false
                   | _ => check_reg_overlap n n1 n2 t
                   end
  end.

Definition trans_reg_to_symbol (reg_acc_set : register_access_set) (g_envs : g_scope)
           (g_arg : identifier) (pid_envs : pid_scope) (id_envs : id_scope) (local_envs : id_scope) :=
  match find_scope_id g_arg g_envs with
  | Error e' => Error e'
  | OK n =>
    match reg_acc_set with
    | Register_Access_Set_Section id e1 e2 =>
      match find_scope_id id local_envs with
      | OK _ => Error (msg (String.append (get_idname id) " has been repeatedly defined in current enviorment"))
      | _ => match typecheck_expression g_envs pid_envs id_envs e1, typecheck_expression g_envs pid_envs id_envs e2 with
               | OK (TConst TInt n1), OK (TConst TInt n2) => if (0 <=? n2) && (n2 <=? n1) && (n1 <? (Z.of_N (N.of_nat n))) && (check_reg_overlap n (N.to_nat (Z.to_N n1)) (N.to_nat (Z.to_N n2)) id_envs) then OK (id,TRegAcc n (N.to_nat (Z.to_N n1)) (N.to_nat (Z.to_N n2)))  else Error (msg "register section invalid")
               | _, _ => Error (msg "register index invalid")
               end
      end
    | Register_Access_Set_Bit id e =>
      match find_scope_id id local_envs with
      | OK _ => Error (msg (String.append (get_idname id) " has been repeatedly defined in current enviorment"))
      | _ => match typecheck_expression g_envs pid_envs id_envs e with
               | OK (TConst TInt n') => if (0 <=? n') && (n' <? (Z.of_N (N.of_nat n))) && (check_reg_overlap  n (N.to_nat (Z.to_N n')) (N.to_nat (Z.to_N n')) id_envs) then OK (id,TRegAcc n (N.to_nat (Z.to_N n')) (N.to_nat (Z.to_N n'))) else Error (msg "register bit invalid")
               | _ => Error (msg "register index invalid")
               end
      end
    end
  end.
(*Test trans_reg_to_symbol*)
(*Todo*)

Fixpoint initialization_of_CR (g_envs : g_scope) (list_declaration : list declaration)
         (c_envs r_envs : id_scope) (pid_envs : pid_scope): res (id_scope * id_scope * pid_scope) :=
  match list_declaration with
  | nil => OK (c_envs,r_envs,pid_envs)
  | h :: t =>
    match h with
    | As_Constant (Constant_Declaration cid e) => (*C envs*)
      let ev := match (typecheck_constant c_envs e) with
                | OK (TConst ty' val') => update_id_without_same cid (TConst ty' val') c_envs
                | _ => Error (msg "type error in const declaration")
                end in
      match ev with
      | OK new_c_envs => initialization_of_CR g_envs t new_c_envs r_envs pid_envs
      | Error e' => Error e'
      end
    | As_Protocol (Protocol_Declaration pid p) => (*pid envs*)
      let p_symbol := trans_protocol_to_symbol p c_envs in
      match p_symbol with
      | OK p' => let pv := update_id_without_same pid p' pid_envs in
                  match pv with
                  | OK new_pid_envs => initialization_of_CR g_envs t c_envs r_envs new_pid_envs
                  | Error e'' => Error e''
                  end
      | Error e''' => Error e'''
      end
    | As_Register_Access reg_acc_set => (*R envs*)
      let reg_symbol := trans_reg_to_symbol reg_acc_set g_envs Lreglen pid_envs c_envs r_envs in
      match reg_symbol with
      | OK (id',r') => let pr := update_id_without_same id' r' r_envs in
                        match pr with
                        | OK new_r_envs => initialization_of_CR g_envs t c_envs new_r_envs pid_envs
                        | Error e'''' => Error e''''
                        end
      | Error ee => Error ee
      end
    | As_Layer _ => initialization_of_CR g_envs t c_envs r_envs pid_envs
    end
  end.
(*Test Initialization_of_CR*)
(*Todo*)

Fixpoint update_Lc (n nk : nat) (Lc : id_scope) :=
  match Lc with
  | nil => nil
  | (st,type) :: t =>
    match type with
    | TRegAcc k' n1 n2 =>
      (st,TRegAcc n (Nat.add n1 nk) (Nat.add n2 nk)) :: (update_Lc n nk t)
    | _ => update_Lc n nk t
    end
  end.

Definition update_r_envs (g_envs : g_scope) (La Lb0 Lb1 : id_scope) :=
  let sn := find_scope_id Lreglen g_envs in
  let sk := find_scope_id Creglen g_envs in
  match sn, sk with
  | OK n, OK k =>
    if (Nat.eqb n (Nat.mul k 3)) then
      let new_La := update_Lc n (Nat.mul k 2) La in
      let new_Lb0 := update_Lc n k Lb0 in
      let new_Lb1 := update_Lc n 0 Lb1 in
      OK (List.app (List.app new_La new_Lb0) new_Lb1)
    else
      Error (msg "layer length is not equal to 3 times cell length")
  | _, _ => Error (msg "lack of Lreglen and Creglen definitions")
  end.

Fixpoint initialization_of_CRL (id_envs : id_scope) (pid_envs : pid_scope)
         (list_layer_decl : list layer_declaration) (l_envs : id_scope) := (*CR and local L ?*)
  match list_layer_decl with
  | nil => OK (List.app l_envs id_envs)
  | h :: t => match h with
            | Layer_As_Protocol pid ids =>
              match find_scope_id pid pid_envs with
              | OK protocol_symbol =>
                let snew := update_ids_without_same ids (TX pid) l_envs in
                match snew with
                | OK new_l_envs => initialization_of_CRL id_envs pid_envs t new_l_envs
                | Error e' => Error e'
                end
              | Error e'' => Error e''
              end
            end
  end.
(*Test initialization_of_CRL*)
(*Todo*)

Fixpoint initialization_of_list_reg (g_envs : g_scope) (id_envs : id_scope) (pid_envs : pid_scope) (lc_envs : id_scope)
         (list_reg_acc_set : list register_access_set) :=
  match list_reg_acc_set with
  | nil => OK lc_envs
  | reg_acc_set :: t =>
    let reg_symbol := trans_reg_to_symbol reg_acc_set g_envs Creglen pid_envs id_envs lc_envs in
      match reg_symbol with
      | OK (id',r') => let pr := update_id_without_same id' r' lc_envs in
                        match pr with
                        | OK new_lc_envs => initialization_of_list_reg g_envs id_envs pid_envs new_lc_envs t
                        | Error e' => Error e'
                        end
      | Error e'' => Error e''
      end
  end.

Definition initialization_of_La (g_envs : g_scope) (id_envs : id_scope) (pid_envs : pid_scope)
           (reg_cella : cell_a_register) :=
  match reg_cella with
  | Cell_A_Register list_reg_acc_set => initialization_of_list_reg g_envs id_envs pid_envs empty_id_env list_reg_acc_set
  end.

Definition initialization_of_Lb0 (g_envs : g_scope) (id_envs : id_scope) (pid_envs : pid_scope)
           (reg_cellb0 : cell_b0_register) :=
  match reg_cellb0 with
  | Cell_B0_Register list_reg_acc_set => initialization_of_list_reg g_envs id_envs pid_envs empty_id_env list_reg_acc_set
  end.

Definition initialization_of_Lb1 (g_envs : g_scope) (id_envs : id_scope) (pid_envs : pid_scope)
           (reg_cellb1 : cell_b1_register) :=
  match reg_cellb1 with
  | Cell_B1_Register list_reg_acc_set => initialization_of_list_reg g_envs id_envs pid_envs empty_id_env list_reg_acc_set
  end.

Definition initialization_of_Lc (g_envs : g_scope) (id_envs : id_scope) (pid_envs : pid_scope)
         (local_reg_decl : local_register_declaration) :=
  match local_reg_decl with
  | Local_Register_Declaration reg_cella reg_cellb0 reg_cellb1 =>
    let sla := initialization_of_La g_envs id_envs pid_envs reg_cella in
    let slb0 := initialization_of_Lb0 g_envs id_envs pid_envs reg_cellb0 in
    let slb1 := initialization_of_Lb1 g_envs id_envs pid_envs reg_cellb1 in
    (sla, slb0, slb1)
  end.
(*Test initialization_of_CRLLc*)
(*Todo*)

Fixpoint sum_of_flds (flds : list (string * nat)) (n : nat) :=
  match flds with
  | nil => n
  | (st, v) :: t => sum_of_flds t (Nat.add v n)
  end.

Fixpoint initialization_of_fields (g_envs : g_scope) (id_envs : id_scope)
         (pid_envs : pid_scope) (flds : list (string * nat)) (p_envs : id_scope) (sum_ni : nat) (n : nat) :=
  match flds with
  | nil => OK p_envs
  | (st, v) :: t =>
    let np := update_str_without_same st (TFieldAcc_protocol n sum_ni (Nat.sub (Nat.add sum_ni v) 1)) p_envs in
    match np with
    | OK new_p_envs => initialization_of_fields g_envs id_envs pid_envs t new_p_envs (Nat.add sum_ni v) n
    | Error e' => Error e'
    end
  end.

Definition initialization_of_P (g_envs : g_scope) (id_envs : id_scope)
           (pid_envs : pid_scope) (flds : list (string * nat)) (ofld : optional_field) :=
  let sf := initialization_of_fields g_envs id_envs pid_envs flds empty_id_env 0 (sum_of_flds flds 0) in
  match sf with
  | OK p_envs =>
    match ofld with
    | Optional_Field ofid oconst => update_id_without_same ofid TInt p_envs
    | No_Optional_Field => OK p_envs
    end
  | Error e' => Error e'
  end.
(*Test initialization_of_CRLLcP*)
(*Todo*)

Fixpoint typecheck_target_register_access_name (g_envs : g_scope) (id_envs : id_scope)
         (pid_envs : pid_scope) (tra : target_register_access_name) :=
  match tra with
  | Target_Register_Id id =>
    match find_scope_id id id_envs with
    | OK (TRegAcc n n1 n2) => OK (TRegAcc n n1 n2)
    | OK _ => Error (msg (String.append (get_idname id) " is not register access type"))
    | Error e' => Error e'
    end
  | Target_Register_Section tra' e1 e2 =>
    let srt := typecheck_target_register_access_name g_envs id_envs pid_envs tra' in
    let st1 := typecheck_expression g_envs pid_envs id_envs e1 in
    let st2 := typecheck_expression g_envs pid_envs id_envs e2 in
    match srt, st1, st2 with
    | OK (TRegAcc n m1 m2), OK (TConst TInt k1), OK (TConst TInt k2) =>
      if (0 <=? k2) && (k2 <=? k1) && (k1 <=? (Z.of_N (N.of_nat m1)) - (Z.of_N (N.of_nat m2))) then
        OK (TRegAcc n (Nat.add m2 (N.to_nat (Z.to_N k1))) (Nat.add m2 (N.to_nat (Z.to_N k2))))
      else
        Error (msg "Target Register Section invalid")
    | _, _, _ => Error (msg "Target Register Section invalid")
    end
  | Target_Register_Bit tra' e =>
    let srt := typecheck_target_register_access_name g_envs id_envs pid_envs tra' in
    let st := typecheck_expression g_envs pid_envs id_envs e in
    match srt, st with
    | OK (TRegAcc n m1 m2), OK (TConst TInt k) =>
      if (0 <=? k) && (k <=? (Z.of_N (N.of_nat m1)) - (Z.of_N (N.of_nat m2))) then
        OK (TRegAcc n (Nat.add m2 (N.to_nat (Z.to_N k))) (Nat.add m2 (N.to_nat (Z.to_N k))))
      else
        Error (msg "Target Register Bit invalid")
    | _, _ => Error (msg "Target Register Bit invalid")
    end
  end.

Fixpoint typecheck_move_register_access_name (g_envs : g_scope) (id_envs : id_scope)
         (pid_envs : pid_scope) (mra : move_register_access_name) :=
  match mra with
  | Move_Register_Single tra => typecheck_target_register_access_name g_envs id_envs pid_envs tra
  | Move_Register_Double mra' tra =>
    let smrt := typecheck_move_register_access_name g_envs id_envs pid_envs mra' in
    let strt := typecheck_target_register_access_name g_envs id_envs pid_envs tra in
    match smrt, strt with
    | OK (TRegAcc n m1 m2), OK (TRegAcc n' n1 n2) =>
      if (Nat.eqb n n') && (Nat.eqb m2 (S n1)) then OK (TRegAcc n m1 n2)
      else Error (msg "Move Register invalid")
    | _, _ => Error (msg "Move Register invalid")
    end
  end.

Fixpoint typecheck_instructions (g_envs : g_scope) (id_envs : id_scope)
         (pid_envs : pid_scope) (ins : list instruction) :=
  match ins with
  | nil => OK true
  | h :: t =>
    let test :=
        match h with
        | Set_Instruction tra e =>
          let srt := typecheck_target_register_access_name g_envs id_envs pid_envs tra in
          let st := typecheck_expression g_envs pid_envs id_envs e in
          match srt, st with
          | OK (TRegAcc n' n1 n2), OK (TConst t' m) =>
            let len := length_of_Z m in
            if Nat.leb len (S (Nat.sub n1 n2)) then
              OK true else Error (msg "length not match in set instruction")
          | _, _ => Error (msg "type error in set instruction")
          end
        | Mov_Instruction mra e =>
          let smt := typecheck_move_register_access_name g_envs id_envs pid_envs mra in
          let st := typecheck_expression g_envs pid_envs id_envs e in
          match smt with
          | OK (TRegAcc n' n1 n2) =>
            match st with
            | OK (TRegAcc n_r r' r'') => if Nat.eqb (Nat.sub n1 n2) (Nat.sub r' r'') then OK true
                                        else Error (msg "length not match in move instruction")
            | OK (TFieldAcc_cell id' n_f f' f'') => if Nat.eqb (Nat.sub n1 n2) (Nat.sub f'' f') then OK true
                                                   else Error (msg "length not match in move instruction")
            | OK (TFieldAcc_protocol n_f f' f'') => if Nat.eqb (Nat.sub n1 n2) (Nat.sub f'' f') then OK true
                                                   else Error (msg "length not match in move instruction")
            | OK _ => Error (msg "type error in move instruction")
            | Error e'' => Error e''
            end
          | OK _ => Error (msg "type error in move instruction")
          | Error e''' => Error e'''
          end
        | Lg_Instruction tra e1 e2 =>
          let srt := typecheck_target_register_access_name g_envs id_envs pid_envs tra in
          let st1 := typecheck_expression g_envs pid_envs id_envs e1 in
          let st2 := typecheck_expression g_envs pid_envs id_envs e2 in
          match srt, st1, st2 with
          | OK (TRegAcc n' n1 n2), OK _, OK _ => OK true
          | _, _, _ => Error (msg "type error in lg instruction")
          end
        | Eq_Instruction tra e1 e2 =>
          let srt := typecheck_target_register_access_name g_envs id_envs pid_envs tra in
          let st1 := typecheck_expression g_envs pid_envs id_envs e1 in
          let st2 := typecheck_expression g_envs pid_envs id_envs e2 in
          match srt, st1, st2 with
          | OK (TRegAcc n' n1 n2), OK _, OK _ => OK true
          | _, _, _ => Error (msg "type error in eq instruction")
          end
        end
    in
    match test with
    | OK _ => typecheck_instructions g_envs id_envs pid_envs t
    | Error e' => Error e'
    end
  end.

Definition typecheck_action_statement (g_envs : g_scope) (id_envs : id_scope)
           (pid_envs : pid_scope) (act : action_statement) :=
  match act with
  | Act_Statement list_instruction =>
    typecheck_instructions g_envs id_envs pid_envs list_instruction
  end.

Definition typecheck_statement (g_envs : g_scope) (id_envs : id_scope)
           (pid_envs : pid_scope) (op : statement_position) (s : statement) : res bool :=
  let test_support :=
      let test_cell := match op with
                       | In_Protocol _ => true
                       | In_Layer cell => eqb_string cell "A"
                       end in
      match s with
      | Action_Statement _ => true
      | _ => test_cell
      end in
  if test_support then
    match s with
    | Next_Header_Statement id =>
      match find_scope_id id pid_envs with
      | OK _ => OK true
      | Error e' => Error e'
      end
    | Length_Statement e =>
      match op with
      | In_Protocol len =>
        match typecheck_expression g_envs pid_envs id_envs e with
        | OK (TConst TInt n) => if (n * 8 >=? (Z.of_N (N.of_nat len))) then OK true
                               else Error (msg "length not match in protocol fields")
        | OK _ => Error (msg "type error in protocol length statement")
        | Error e'' => Error e''
        end
      | In_Layer cell =>
        match typecheck_expression g_envs pid_envs id_envs e with
        | OK (TConst TInt n) => OK true
        | OK TInt => OK true
        | OK _ => Error (msg "type error in layer length statement")
        | Error e'' => Error e''
        end
      end
    | Bypass_Statement c =>
      match typecheck_constant id_envs c with
      | OK (TConst TInt n) => let test := if (n =? 0) || (n =? 1) || (n =? 2) then true else false in
                             if test then OK true else Error (msg "error value in bypass statement")
      | OK _ => Error (msg "type error in bypass statement")
      | Error e'' => Error e''
      end
    | Action_Statement ac => typecheck_action_statement g_envs id_envs pid_envs ac
    end
  else Error (msg "unsupport keyword in current cell").

Fixpoint typecheck_list_statement (g_envs : g_scope) (id_envs : id_scope)
         (pid_envs : pid_scope) (op : statement_position) (ls : list statement) : res bool :=
  match ls with
  | nil => OK true
  | h :: t =>
    match typecheck_statement g_envs id_envs pid_envs op h with
    | OK _ => typecheck_list_statement g_envs id_envs pid_envs op t
    | Error e' => Error e'
    end
  end.

Definition typecheck_if_branch (g_envs : g_scope) (id_envs : id_scope)
         (pid_envs : pid_scope) (op : statement_position) (ib : if_branch) : res bool :=
  match ib with
  | If_Branch e ls =>
    match typecheck_expression g_envs pid_envs id_envs e with
    | OK TBool => typecheck_list_statement g_envs id_envs pid_envs op ls
    | OK _ => Error (msg "error type in if_branch expression")
    | Error e' => Error e'
    end
  end.

Fixpoint typecheck_list_if_branch (g_envs : g_scope) (id_envs : id_scope)
         (pid_envs : pid_scope) (op : statement_position) (lib : list if_branch) : res bool :=
  match lib with
  | nil => OK true
  | h :: t =>
    match typecheck_if_branch g_envs id_envs pid_envs op h with
      | OK _ => typecheck_list_if_branch g_envs id_envs pid_envs op t
      | Error e' => Error e'
    end
  end.

Definition typecheck_else_branch (g_envs : g_scope) (id_envs : id_scope)
           (pid_envs : pid_scope) (op : statement_position) (eb : else_branch) : res bool :=
  match eb with
  | Else_Branch ls => typecheck_list_statement g_envs id_envs pid_envs op ls
  end.

Definition typecheck_if_statement (g_envs : g_scope) (id_envs : id_scope)
           (pid_envs : pid_scope) (op : statement_position) (iss : if_statement) : res bool :=
  match iss with
  | If_Statement lib eb =>
    match typecheck_list_if_branch g_envs id_envs pid_envs op lib with
    | OK _ => typecheck_else_branch g_envs id_envs pid_envs op eb
    | Error e' => Error e'
    end
  end.

Definition typecheck_select_statement (g_envs : g_scope) (id_envs : id_scope)
           (pid_envs : pid_scope) (op : statement_position) (ss : select_statement) : res bool :=
  match ss with
  | As_If iss => typecheck_if_statement g_envs id_envs pid_envs op iss
  | As_Simple s => typecheck_statement g_envs id_envs pid_envs op s
  end.

Fixpoint typecheck_list_select_statement (g_envs : g_scope) (id_envs : id_scope)
         (pid_envs : pid_scope) (op : statement_position) (lss : list select_statement) : res bool :=
  match lss with
  | nil => OK true
  | h :: t =>
    match typecheck_select_statement g_envs id_envs pid_envs op h with
    | OK _ => typecheck_list_select_statement g_envs id_envs pid_envs op t
    | Error e => Error e
    end
  end.

Definition typecheck_protocol_statement (g_envs : g_scope) (id_envs : id_scope)
         (pid_envs : pid_scope) (len : nat) (ps : protocol_statement) : res bool :=
  match ps with
  | Protocol_Statement lss =>
    typecheck_list_select_statement g_envs id_envs pid_envs (In_Protocol len) lss
  end.

Fixpoint typecheck_protocols_statement (g_envs : g_scope) (id_envs : id_scope)
         (pid_envs : pid_scope) (list_layer_decl : list layer_declaration) :=
  match list_layer_decl with
  | nil => OK true
  | h :: t =>
    match h with
    | Layer_As_Protocol pid ids => match find_scope_id pid pid_envs with
                                  | OK ps =>
                                    match ps with
                                    | Protocol_Symbol flds ofld statements =>
                                      let sp := initialization_of_P g_envs id_envs pid_envs flds ofld in
                                      let len := sum_of_flds flds 0 in
                                      match sp with
                                      | OK p_envs =>
                                        let new_id_envs := List.app p_envs id_envs in (*CRLLaP*)
                                        match typecheck_protocol_statement g_envs new_id_envs pid_envs len statements with
                                          | OK _ => typecheck_protocols_statement g_envs id_envs pid_envs t
                                          | Error e' => Error e'
                                        end
                                      | Error e'' => Error e''
                                      end
                                    end
                                  | Error e''' => Error e'''
                                  end
    end
  end.

Fixpoint typecheck_layer_statement (g_envs : g_scope) (id_envs : id_scope)
         (pid_envs : pid_scope) (cell : string) (statement : layer_statement) :=
  match statement with
  | Layer_Statement lss =>
    typecheck_list_select_statement g_envs id_envs pid_envs (In_Layer cell) lss
  end.

Definition typecheck_cell_a_action (g_envs : g_scope) (id_envs : id_scope)
           (pid_envs : pid_scope) (cell_a_act : cell_a_action) :=
  match cell_a_act with
  | Cell_A_Action statements =>
    typecheck_layer_statement g_envs id_envs pid_envs "A" statements
  end.

Definition typecheck_cell_b0_action (g_envs : g_scope) (id_envs : id_scope)
           (pid_envs : pid_scope) (cell_b0_act : cell_b0_action) :=
  match cell_b0_act with
  | Cell_B0_Action statements =>
    typecheck_layer_statement g_envs id_envs pid_envs "B0" statements
  end.

Definition typecheck_cell_b1_action (g_envs : g_scope) (id_envs : id_scope)
           (pid_envs : pid_scope) (cell_b1_act : cell_b1_action) :=
  match cell_b1_act with
  | Cell_B1_Action statements =>
    typecheck_layer_statement g_envs id_envs pid_envs "B1" statements
  end.

Definition typecheck_local_action (g_envs : g_scope) (CRLLa CRLLb0 CRLLb1 : id_scope)
         (pid_envs : pid_scope) (local_act : local_action) :=
  match local_act with
  | Local_Action cell_a_act cell_b0_act cell_b1_act =>
    let t1 := typecheck_cell_a_action g_envs CRLLa pid_envs cell_a_act in
    let t2 := typecheck_cell_b0_action g_envs CRLLb0 pid_envs cell_b0_act in
    let t3 := typecheck_cell_b1_action g_envs CRLLb1 pid_envs cell_b1_act in
    match t1 with
    | OK _ =>
      match t2 with
      | OK _ => t3
      | Error e' => Error e'
      end
    | Error e'' => Error e''
    end
  end.

Fixpoint typecheck_layer (g_envs : g_scope) (c_envs r_envs : id_scope)
         (pid_envs : pid_scope) (list_declaration : list declaration) : res bool :=
  match list_declaration with
  | nil => OK true
  | h :: t =>
    match h with
    | As_Layer (Layer_Action lid local_reg_decl list_layer_decl local_act) =>
      let id_envs := List.app r_envs c_envs in (*CR*)
      let sl := initialization_of_CRL id_envs pid_envs list_layer_decl empty_id_env in
      match sl with
      | OK new_id_envs => (*CRL*)
        let sa_sb0_sb1 := initialization_of_Lc g_envs new_id_envs pid_envs local_reg_decl in
          match sa_sb0_sb1 with
          | (OK new_id_envs_La, OK new_id_envs_Lb0, OK new_id_envs_Lb1) => (*L_A L_B0 L_B1*)
            let new_id_envs_CRLLa := List.app new_id_envs_La new_id_envs in      (*CRLL_A*)
            let new_id_envs_CRLLb0 := List.app new_id_envs_Lb0 new_id_envs in    (*CRLL_B0*)
            let new_id_envs_CRLLb1 := List.app new_id_envs_Lb1 new_id_envs in    (*CRLL_B1*)
            let t1 := typecheck_protocols_statement g_envs new_id_envs_CRLLa pid_envs list_layer_decl in
            let t2 := typecheck_local_action g_envs new_id_envs_CRLLa new_id_envs_CRLLb0 new_id_envs_CRLLb1 pid_envs local_act in
            match t1, t2 with
              | OK _, OK _ =>
                match update_r_envs g_envs new_id_envs_La new_id_envs_Lb0 new_id_envs_Lb1 with
                | OK new_r_envs =>
                  typecheck_layer g_envs c_envs new_r_envs pid_envs t
                | Error e' => Error e'
                end
              | Error e1, _ => Error e1
              | _, Error e2 => Error e2
            end
          | (Error ea, _, _) => Error ea
          | (_, Error eb0, _) => Error eb0
          | (_, _, Error eb1) => Error eb1
          end
      | Error e'' => Error e''
      end
    | _ => typecheck_layer g_envs c_envs r_envs pid_envs t
    end
  end.

Definition typecheck_program (p : program) : res bool :=
  match p with
  | Program (Layer_Register_Length c1) (Cell_Register_Length c2)  pset lset list_declaration =>
    match (get_const_val c1 empty_id_env), (get_const_val c2 empty_id_env) with
    | OK v1, OK v2 =>
      if (v1 >? 0) && (v2 >? 0) then
        let g_envs : g_scope := ("Lreglen", N.to_nat (Z.to_N (Z.mul v1 8))) :: ("Creglen", N.to_nat (Z.to_N (Z.mul v2 8))) :: nil in
        let CR_Env := initialization_of_CR g_envs list_declaration empty_id_env empty_id_env empty_pid_env in
        match CR_Env with
        | OK (c_envs, r_envs, pid_envs) =>
          typecheck_layer g_envs c_envs r_envs pid_envs list_declaration
        | Error e' => Error e'
        end
      else
        Error (msg "layer and cell length must be positive")
    | _, _ => Error (msg "invalid layer/cell value")
    end
  end.

(*Test Program*)
(*Todo*)

Definition typechecker (p : program) :=
  match typecheck_program p with
  | OK _ => OK p
  | Error e => Error e
  end.


Add LoadPath "." as CoqDirectory.
Load partie2.

(* Cette partie met quelques notions en place, rien de très extravagant *)

(* Question 2 *)
(* NB : on a remplacé les blocs d(instruction par des listes chaînées directement
embedded dans les termes car Coq refusait de définir certains opérateurs de point fixe
car il n'arrivait pas à prouver leur terminaison *)
Inductive Instruction :=
    | Access : nat -> Instruction
    | Grab : Instruction -> Instruction
    | Push : Instruction -> Instruction -> Instruction
.
Inductive Stack_type : Type :=
    | Nil : Stack_type
    | Stack : (Instruction * Stack_type) -> Stack_type -> Stack_type
.

Definition Environment : Type := Stack_type.

Definition State : Type := (Instruction * Environment * Stack_type).

Inductive StateOption :=
    | None : StateOption
    | Some : State -> StateOption
.

(* Question 3 *)
Definition step_krivine (state: State) : StateOption :=
    match state with
    | ((Access 0), Stack (c0, e0) _, s) => Some ((c0, e0, s))
    | ((Access (S n)), Stack (_, _) e, s) => Some (((Access n), e, s))
    | ((Push cp c), e, s) => Some ((c, e, Stack (cp, e) s))
    | (Grab c, e, Stack (c0, e0) s) => Some (c, Stack (c0, e0) e, s)
    | _ => None
    end
.

Definition is_state (s: StateOption) :=
    match s with
    | None => False
    | Some _ => True
    end
.

(* Encore le même genre de lemme... *)
Lemma some_truc : forall (s1 s2: State),
    Some s1 = Some s2 <-> s1 = s2
.
Proof.
    move => s1 s2.
    split.
    case. trivial.
    move => H.
    rewrite H. reflexivity.
Qed.


(**  A notation system for finite ordinals *)
(** Pierre Castéran, Univ. Bordeaux and LaBRI *)

From Coq Require Import Arith Relations Lia Logic.Eqdep_dec Ensembles
        Wellfounded.Inverse_Image Wellfounded.Inclusion
        RelationClasses.
From hydras Require Import ON_Generic.

Require Wf_nat.

Coercion is_true: bool >-> Sortclass.

(* begin snippet Defs *)

Definition t (n:nat) := {i:nat | Nat.ltb i  n}.

Definition lt {n:nat} : relation (t n) :=
  fun alpha beta => Nat.ltb (proj1_sig alpha) (proj1_sig beta).

(* end snippet Defs *)

Open Scope ON_scope.

(* begin snippet t0Empty:: no-out *)

Lemma t0_empty (alpha: t 0): False.
Proof.
  destruct alpha ; discriminate.
Qed.

(* end snippet t0Empty *)

(* begin snippet bad10  *)
Definition bad :  t 10. (* .no-out *)
exists 10.
Abort.
(* end snippet bad10  *)

(* begin snippet compareDef:: no-out *)

#[global] Instance compare_t {n:nat} : Compare (t n) :=
  fun (alpha beta : t n) => Nat.compare (proj1_sig alpha) (proj1_sig beta).

Lemma compare_correct {n} (alpha beta : t n) :
  CompSpec eq lt alpha beta (compare alpha beta).
(* end snippet compareDef *)

Proof.
  destruct n.
  - assert False by (now apply t0_empty); contradiction.
  - destruct alpha, beta; cbn;  case_eq (x ?= x0); unfold lt; cbn.
    + rewrite Nat.compare_eq_iff; intro; subst; f_equal.
(* begin snippet compareCorrectb:: no-in unfold *)
      constructor 1.
(* end snippet compareCorrectb *)
(* begin snippet compareCorrectc *)
      f_equal.
(* end snippet compareCorrectc *)
(* begin snippet compareCorrectd *)
      apply eq_proofs_unicity_on; decide equality.
    (* ... *)
(* end snippet compareCorrectd *)
    + rewrite Nat.compare_lt_iff;  constructor 2.
      simpl; destruct x0; [  lia |  apply leb_correct; lia].
    + rewrite Nat.compare_gt_iff; constructor 3.
      simpl; destruct x; [lia | apply leb_correct; lia].
Qed.

Lemma compare_reflect {n:nat} (alpha beta : t  n) :
  match (compare alpha beta)
  with
    Lt => lt alpha  beta
  | Eq => alpha = beta
  | Gt => lt beta  alpha
  end.
Proof.
 now destruct (compare_correct alpha beta).
Qed.

(* begin snippet ltWf *)

Lemma lt_wf (n:nat) : well_founded (@lt n). (* .no-out *)
(* end snippet ltWf *)

Proof.
  intro x; apply Acc_incl with (fun alpha beta =>
                                  proj1_sig alpha < proj1_sig beta)%nat.
 - intros  [y Hy] [z Hz]; unfold lt; cbn; intro H.
   destruct z.
   + discriminate.
   +  apply leb_complete in H; lia.
  -  apply Acc_inverse_image, Wf_nat.lt_wf.
Qed.

(* begin snippet ONInstance *)

#[global] Instance sto n : StrictOrder (@lt n). (* .no-out *)
(*|
.. coq:: none
|*)
Proof.
  split.
   - intro x; red;  unfold lt; destruct x; cbn.
     destruct x.
     + discriminate.
     +  destruct (Nat.leb_spec0 (S x) x).
      *  lia.
      *  discriminate.
  - intros x y z; destruct x,y,z; cbn; destruct n.
    +   cbn; red in i1.
        assert (x1 < 0)%nat by (now rewrite <- Nat.ltb_lt); lia.
    +   unfold lt; simpl; unfold is_true; repeat rewrite Nat.ltb_lt;  lia.
Qed.

(*||*)

#[global] Instance comp n: Comparable (@lt n) compare. (* .no-out *)
(*|
.. coq:: none
|*)
Proof.
  split.
   - apply sto.
   - apply compare_correct.
Qed.
(*||*)

#[global] Instance FinOrd n : ON (@lt n) compare. (* .no-out *)
(*|
.. coq:: none
|*)
Proof.
  split.
  - exact (comp n).
  - apply lt_wf.
Qed.
(*||*)

(* end snippet ONInstance *)

Definition Zero_limit_succ_dec (n:nat) : ZeroLimitSucc_dec (on := FinOrd n).
Proof.
  - intros [i Hi]; destruct n.
    + discriminate.
    + destruct i.
      * left;left;red; destruct y; destruct x.
       --  replace Hi with i.
        ++ right.
        ++ apply eq_proofs_unicity_on; decide equality.
       -- left; red; cbn; trivial.
      * right; refine (exist _ (exist _ i _) _).
        split.
        -- cbn; unfold lt; cbn;  apply Nat.leb_refl.
        -- intros z H H0; destruct z.
           unfold lt in H, H0; cbn in H, H0.
           destruct x.
           ++ discriminate.
           ++ red in H, H0; apply leb_complete in H .
              apply leb_complete in H0; lia.
              Unshelve.
              red; red in Hi; rewrite Nat.ltb_lt in *; lia.
Defined.

Lemma sig_eq_intro {n:nat} (x y : t n) :
  proj1_sig x = proj1_sig y -> x = y.
Proof.
  destruct x, y; simpl; f_equal; intro; subst.
  f_equal; apply eq_proofs_unicity_on.
  destruct y, (x0 <? n); auto.
  right; discriminate.
Qed.

(* begin snippet InclIJ:: no-out *)

Section Inclusion_ij.

  Variables i j : nat.
  Hypothesis Hij : i < j.

  Remark Ltb_ij : Nat.ltb i j.
(* end snippet InclIJ:: no-out *)

  Proof.
    red; now rewrite Nat.ltb_lt.
  Defined.

  (* begin snippet InclIJa:: no-out *)
  #[program] Definition iota_ij  (alpha: t i) : t j :=  alpha.
  (* end snippet InclIJa *)

  Next Obligation.
    destruct alpha; cbn; red in i0;rewrite  Nat.ltb_lt  in i0.
    destruct j; [lia | apply leb_correct;  lia].
  Defined.

  (* begin snippet InclIJb:: no-out *)
   Let b : t j := exist _ i Ltb_ij.

  #[global]
   Instance F_incl_ij: SubON (FinOrd i) (FinOrd j) b iota_ij.
  (* end snippet InclIJb *)
  Proof.
    split.
    - intros; cbn.
      reflexivity.
    -  unfold lt; simpl. intro x;  destruct x; assumption.
    -  intro y; destruct y as [x Hx].
       unfold b, lt;simpl.
       intros H; exists (exist _ x H); apply sig_eq_intro; reflexivity.
  Qed.

  (* begin snippet InclIJc:: no-out *)
  Lemma iota_compare_commute alpha beta:
    compare alpha beta =
    compare (iota_ij alpha) (iota_ij beta).
  (* end snippet InclIJc *)

  Proof. reflexivity. Qed.

  (* begin snippet InclIJd:: no-out *)
  Lemma iota_mono  : forall alpha beta,
      lt alpha beta <->
      lt (iota_ij alpha) (iota_ij beta).
 (* end snippet InclIJd *)

  Proof.
    split; unfold lt; cbn; auto.
  Qed.

  (* begin snippet InclIJz *)
End Inclusion_ij.
  (* end snippet InclIJz *)

Arguments iota_ij {i j}.

(* begin snippet Example1 *)

Program Example alpha1 : t 7 := 2.

Program Example beta1 : t 7 := 5.

Example i1 : lt  alpha1 beta1. (* .no-out *)
Proof. (* .no-out *) reflexivity.  Qed.

(* end snippet Example1 *)

(* begin snippet Example2 *)

Program Example gamma1 : t 8 := 7.

Fail Goal alpha1 o< gamma1.

(* end snippet Example2 *)

Example i2 : lt (iota_ij  (le_n 8) alpha1) gamma1.
Proof. reflexivity. Qed.

Example Ex1 : In  (bigO beta1) alpha1.
Proof. reflexivity. Qed.


Require Import Coq.Lists.List.
Require Import Coq.NArith.BinNat.

Open Scope list_scope.
Open Scope N_scope.

Import ListNotations.

Definition test_input := [ 3 ; 4 ; 3 ; 1 ; 2 ].

Definition input := [ 4 ; 3 ; 3 ; 5 ; 4 ; 1 ; 2 ; 1 ; 3 ; 1 ; 1 ; 1 ; 1 ; 1 ; 2 ; 4 ; 1 ; 3 ; 3 ; 1 ; 1 ; 1 ; 1 ; 2 ; 3 ; 1 ; 1 ; 1 ; 4 ; 1 ; 1 ; 2 ; 1 ; 2 ; 2 ; 1 ; 1 ; 1 ; 1 ; 1 ; 5 ; 1 ; 1 ; 2 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 3 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 5 ; 1 ; 4 ; 2 ; 1 ; 1 ; 2 ; 1 ; 3 ; 1 ; 1 ; 2 ; 2 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 4 ; 1 ; 3 ; 2 ; 2 ; 3 ; 1 ; 1 ; 1 ; 4 ; 1 ; 1 ; 1 ; 1 ; 5 ; 1 ; 1 ; 1 ; 5 ; 1 ; 1 ; 3 ; 1 ; 1 ; 2 ; 4 ; 1 ; 1 ; 3 ; 2 ; 4 ; 1 ; 1 ; 1 ; 1 ; 1 ; 5 ; 5 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 4 ; 1 ; 1 ; 1 ; 3 ; 2 ; 1 ; 1 ; 5 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 5 ; 4 ; 1 ; 5 ; 1 ; 3 ; 4 ; 1 ; 1 ; 1 ; 1 ; 2 ; 1 ; 2 ; 1 ; 1 ; 1 ; 2 ; 2 ; 1 ; 2 ; 3 ; 5 ; 1 ; 1 ; 1 ; 1 ; 3 ; 5 ; 1 ; 1 ; 1 ; 2 ; 1 ; 1 ; 4 ; 1 ; 1 ; 5 ; 1 ; 4 ; 1 ; 2 ; 1 ; 3 ; 1 ; 5 ; 1 ; 4 ; 3 ; 1 ; 3 ; 2 ; 1 ; 1 ; 1 ; 2 ; 2 ; 1 ; 1 ; 1 ; 1 ; 4 ; 5 ; 1 ; 1 ; 1 ; 1 ; 1 ; 3 ; 1 ; 3 ; 4 ; 1 ; 1 ; 4 ; 1 ; 1 ; 3 ; 1 ; 3 ; 1 ; 1 ; 4 ; 5 ; 4 ; 3 ; 2 ; 5 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 2 ; 1 ; 5 ; 2 ; 5 ; 3 ; 1 ; 1 ; 1 ; 1 ; 1 ; 3 ; 1 ; 1 ; 1 ; 1 ; 5 ; 1 ; 2 ; 1 ; 2 ; 1 ; 1 ; 1 ; 1 ; 2 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 1 ; 3 ; 3 ; 1 ; 1 ; 5 ; 1 ; 3 ; 5 ; 5 ; 1 ; 1 ; 1 ; 2 ; 1 ; 2 ; 1 ; 5 ; 1 ; 1 ; 1 ; 1 ; 2 ; 1 ; 1 ; 1 ; 2 ; 1 ].

Inductive LanternFish :=
    | Populations (zero one two three four five six seven eight : N)
    .

Definition default_pops := Populations 0 0 0 0 0 0 0 0 0.

Fixpoint processData (input : list N) (dataSoFar : LanternFish) :=
    match input with
    | x :: xs => processData xs (match dataSoFar with
        | Populations a b c d e f g h i => match x with
            | 0 => Populations (a+1) b c d e f g h i
            | 1 => Populations a (b+1) c d e f g h i
            | 2 => Populations a b (c+1) d e f g h i
            | 3 => Populations a b c (d+1) e f g h i
            | 4 => Populations a b c d (e+1) f g h i
            | 5 => Populations a b c d e (f+1) g h i
            | 6 => Populations a b c d e f (g+1) h i
            | 7 => Populations a b c d e f g (h+1) i
            | 8 => Populations a b c d e f g h (i+1)
            | _ => dataSoFar
            end
        end
    )
    | [] => dataSoFar
    end.

Definition data := processData input default_pops.

Definition population (data : LanternFish) :=
    match data with
    | Populations a b c d e f g h i => a+b+c+d+e+f+g+h+i
    end.

Fixpoint step (n : nat) (data : LanternFish) :=
    match n with
    | 0%nat => population data
    | S n' => step n' (match data with
        | Populations a b c d e f g h i => Populations b c d e f g (h + a) i a
        end)
    end.

Definition simulate (n : nat) := step n (processData input default_pops).

Definition part1 := simulate 80%nat.
Definition part2 := simulate 256%nat.

Compute part1.
Compute part2.


(*
 - Identity pseudofunctor
From 'UniMath/Bicategories/PseudoFunctors/Examples/Identity.v'
*)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.

Require Import Integers.Prebicategories.Invertible_2cells.
Require Import Integers.Prebicategories.PseudoFunctor.
Import PseudoFunctor.Notations.

Local Open Scope cat.
(*Local Open Scope mor_disp_scope.*)
Local Open Scope bicategory_scope.

Section IdentityPseudofunctor.
  Variable (C : prebicat).

  Definition id_pseudofunctor_data : pseudofunctor_data C C.
  Proof.
    use make_pseudofunctor_data.
    - exact (λ a, a).
    - exact (λ a b f, f).
    - exact (λ a b f g θ, θ).
    - exact (λ a, id2 (identity a)).
    - exact (λ a b c f g, id2 (f · g)).
  Defined.

  Definition id_pseudofunctor_laws : pseudofunctor_laws id_pseudofunctor_data.
  Proof.
    repeat split.
    - intros a b c f g h θ.
      exact (id2_left _ @ !id2_right _).
    - intros a b c f g h θ.
      exact (id2_left _ @ !id2_right _).
    - intros a b f. cbn.
      rewrite id2_rwhisker.
      rewrite !id2_left.
      reflexivity.
    - intros a b f ; cbn in *.
      rewrite lwhisker_id2.
      rewrite !id2_left.
      reflexivity.
    - intros a b c d f g h ; cbn in *.
      rewrite lwhisker_id2, id2_rwhisker.
      rewrite !id2_left, !id2_right.
      reflexivity.
  Qed.

  Definition id_pseudofunctor : pseudofunctor C C.
  Proof.
    use make_pseudofunctor.
    - exact id_pseudofunctor_data.
    - exact id_pseudofunctor_laws.
    - split ; cbn ; intros ; is_iso.
  Defined.
End IdentityPseudofunctor.


Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
(* for ufgraph *)
Require Import CertiGraph.graph.path_lemmas.
(*for unionfind*)
Require Export CertiGraph.graph.UnionFind.
Require Import CertiGraph.msl_application.ArrayGraph.
Require Import CertiGraph.unionfind.env_unionfind_arr.
(*spanning tree definition*)
Require Import CertiGraph.graph.undirected_graph.

Local Coercion pg_lg: LabeledGraph >-> PreGraph.
Local Coercion lg_gg: GeneralGraph >-> LabeledGraph.

Lemma reachable_uf_equiv_connected:
  forall (g1 g2: UFGraph) u v,
    uf_equiv g1 g2 ->
    reachable g1 u v ->
    connected g2 u v.
Proof.
  intros.
  pose proof (reachable_foot_valid _ _ _ H0).
  pose proof (reachable_head_valid _ _ _ H0).
  destruct H.
  assert (EnumEnsembles.EnumCovered Z (evalid g2)). {
    apply EnumEnsembles.Enumerable_is_EnumCovered, finiteE.
  }
  assert (EnumEnsembles.EnumCovered Z (evalid g1)). {
    apply EnumEnsembles.Enumerable_is_EnumCovered, finiteE.
  }
  assert (vvalid g2 u). {
    apply H; trivial.
  }
  assert (vvalid g2 v). {
    apply H; trivial.
  }
  pose proof (uf_root_always_exists g1 (liGraph g1) u X0 H2).
  pose proof (uf_root_always_exists g1 (liGraph g1) v X0 H1).
  pose proof (uf_root_always_exists g2 (liGraph g2) u X H4).
  pose proof (uf_root_always_exists g2 (liGraph g2) v X H5).
  destruct H6 as [ur1 ?].
  destruct H7 as [vr1 ?].
  destruct H8 as [ur2 ?].
  destruct H9 as [vr2 ?].
  pose proof (H3 _ _ _ H6 H8).
  pose proof (H3 _ _ _ H7 H9).
  pose proof (uf_root_reachable _ _ _ _ H0 H7).
  pose proof (uf_root_unique _ _ _ _ _ H6 H12).
  subst ur1. subst vr1. subst vr2.
  clear H6 H7.
  destruct H8 as [? _].
  destruct H9 as [? _].
  apply reachable_implies_connected in H6.
  apply reachable_implies_connected in H7.
  apply connected_symm in H7.
  apply (connected_trans _ _ _ _ H6 H7).
Qed.

Lemma uf_equiv_adjacent_connected:
  forall (g1 g2 : UFGraph) u v,
    uf_equiv g1 g2 ->
    adjacent g1 u v ->
    connected g2 u v.
Proof.
  intros.
  apply adjacent_reachable in H0.
  destruct H0.
  - apply (reachable_uf_equiv_connected g1); trivial.
  - apply connected_symm.
    apply (reachable_uf_equiv_connected g1); trivial.
Qed.

Lemma uf_equiv_connected':
  forall (g1 g2: UFGraph) u v,
    uf_equiv g1 g2 ->
    connected g1 u v ->
    connected g2 u v.
Proof.
  intros.
  rewrite connected_exists_path in H0.
  destruct H0 as [p [? [? ?]]].
  generalize dependent u.
  induction p.
  - intros. inversion H1.
  - destruct p.
    + intros. simpl in H1, H2.
      inversion H1. inversion H2.
      subst.
      apply connected_refl; trivial.
      simpl in H0. destruct H. apply H; trivial.
    + destruct H0.
      rewrite last_error_cons in H2.
      2: unfold not; inversion 1.
      specialize (IHp H1 H2).
      intros.
      simpl in H3. inversion H3; subst a; clear H3.
      assert (connected g2 z v). {
        apply adjacent_requires_vvalid in H0.
        destruct H0.
        apply IHp; trivial.
      }
      apply (uf_equiv_adjacent_connected _ g2) in H0; trivial.
      apply (connected_trans _ _ _ _ H0 H3).
Qed.

Lemma uf_equiv_connected:
  forall (g1 g2: UFGraph) u v,
    uf_equiv g1 g2 ->
    connected g1 u v <-> connected g2 u v.
Proof.
  intros. split; intros.
  - apply (uf_equiv_connected' g1); trivial.
  - apply uf_equiv_sym in H.
    apply (uf_equiv_connected' g2); trivial.
Qed.

Lemma adjacent_ufroot_same:
  forall (g: UFGraph) u v,
    adjacent g u v ->
    ufroot_same g u v.
Proof.
  intros.
  apply adjacent_reachable in H.
  destruct H.
  - apply (reachable_ufroot_same _ (liGraph g)); trivial.
  - apply ufroot_same_symm, (reachable_ufroot_same _ (liGraph g)); trivial.
Qed.

Lemma connected_ufroot_same:
  forall (g: UFGraph) u v,
    connected g u v ->
    ufroot_same g u v.
Proof.
  intros.
  rewrite connected_exists_path in H.
  destruct H as [p [? [? ?]]].
  generalize dependent u.
  induction p.
  - intros. inversion H1.
  - destruct p.
    + intros. simpl in H1, H0.
      inversion H1. inversion H0.
      subst. apply (ufroot_same_refl _ (liGraph g)).
      simpl in H; trivial.
    + destruct H.
      rewrite last_error_cons in H1.
      2: unfold not; inversion 1.
      specialize (IHp H0 H1).
      intros.
      simpl in H2. inversion H2; subst a; clear H2.
      apply adjacent_ufroot_same in H.
      apply (ufroot_same_trans _ (liGraph g) _ z); trivial.
      apply IHp. trivial.
Qed.

Lemma ufroot_same_connected:
  forall (g: UFGraph) u v,
    ufroot_same g u v ->
    connected g u v.
Proof.
  intros.
  destruct H as [r [[? _] [? _]]].
  apply reachable_implies_connected in H.
  apply reachable_implies_connected in H0.
  apply connected_symm in H0.
  apply (connected_trans _ _ _ _ H H0).
Qed.

Lemma connected_ufroot_same_iff:
  forall (g: UFGraph) u v,
    connected g u v <-> ufroot_same g u v.
Proof.
  intros. split; intros.
  apply connected_ufroot_same; trivial.
  apply ufroot_same_connected; trivial.
Qed.

Lemma uf_equiv_ufroot_same:
  forall (g1 g2: UFGraph) u v,
    uf_equiv g1 g2 ->
    ufroot_same g1 u v <-> ufroot_same g2 u v.
Proof.
intros. do 2 rewrite <- connected_ufroot_same_iff. apply uf_equiv_connected. auto.
Qed.