(*
abhishek@brixpro:~/parametricity/reflective-paramcoq/test-suite$ ./coqid.sh indFunArg
*)

Require Import SquiggleEq.terms.

Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ReflParam.PIWNew.

Require Import Template.Template.

Require Import ReflParam.matchR. (* shadows Coq.Init.Datatypes.list *)
Require Import List.
Require Import Top.nat.
Run TemplateProgram (mkIndEnv "indTransEnv" ["ReflParam.matchR.Vec"]).

Check vcons.

Open Scope N_scope.
(* Arguments existT {A} {P} x p. *)

(*
Arguments existT : clear implicits.

Arguments eq_refl : clear implicits.
*)

(*
fix
ReflParam_matchR_Vec_RR0 (C C₂ : Set) (C_R : C -> C₂ -> Prop) (m m₂ : nat)
                         (m_R : nat_RR m m₂) (H : Vec C m) (H0 : Vec C₂ m₂) {struct H} :
  Prop :=
  match H in (Vec _ m0) return (nat_RR m0 m₂ -> Prop) with
  | vnil _ =>
      match H0 in (Vec _ m₂0) return (nat_RR 0 m₂0 -> Prop) with
      | vnil _ =>
          fun m_R0 : nat_RR 0 0 =>
          existT (nat_RR 0 0) (fun _ : nat_RR 0 0 => True) m_R0 I =
          existT (nat_RR 0 0) (fun _ : nat_RR 0 0 => True) O_RR I
      | vcons _ n₂ _ _ => fun _ : nat_RR 0 (S n₂) => False
      end
  | vcons _ n c vc =>
      match H0 in (Vec _ m₂0) return (nat_RR (S n) m₂0 -> Prop) with
      | vnil _ => fun _ : nat_RR (S n) 0 => False
      | vcons _ n₂ c₂ vc₂ =>
          fun m_R0 : nat_RR (S n) (S n₂) =>
          {n_R : nat_RR n n₂ &
          {_ : C_R c c₂ &
          {_ : ReflParam_matchR_Vec_RR0 C C₂ C_R n n₂ n_R vc vc₂ &
          existT (nat_RR (S n) (S n₂)) (fun _ : nat_RR (S n) (S n₂) => True) m_R0 I =
          existT (nat_RR (S n) (S n₂)) (fun _ : nat_RR (S n) (S n₂) => True)
            (S_RR n n₂ n_R) I}}}
      end
  end m_R

ReflParam_matchR_Vec_RR0 is defined

*)
Run TemplateProgram (genParamInd [] true true "ReflParam.matchR.Vec").

(*
Arguments eq_refl : clear implicits.
Definition vapp :=
(let
   fix
   vAppend (C : Set) (n m : nat) (vl : Vec C n) (vr : Vec C m) {struct vl} :
     Vec C (n + m) :=
     match vl in (Vec _ n0) return (Vec C (n0 + m)) with
     | vnil _ => vr
     | vcons _ n' hl tl => vcons C (n' + m) hl (vAppend C n' m tl vr)
     end in
 let
   fix
   vAppend₂ (C₂ : Set) (n₂ m₂ : nat) (vl₂ : Vec C₂ n₂)
            (vr₂ : Vec C₂ m₂) {struct vl₂} : Vec C₂ (n₂ + m₂) :=
     match vl₂ in (Vec _ n₂0) return (Vec C₂ (n₂0 + m₂)) with
     | vnil _ => vr₂
     | vcons _ n'₂ hl₂ tl₂ =>
         vcons C₂ (n'₂ + m₂) hl₂ (vAppend₂ C₂ n'₂ m₂ tl₂ vr₂)
     end in
 fun (C : Set) (n m : nat) (vl : Vec C n) (vr : Vec C m) =>
 match
   vl as vl0 in (Vec _ n0)
   return
     (match vl0 in (Vec _ n1) return (Vec C (n1 + m)) with
      | vnil _ => vr
      | vcons _ n' hl tl => vcons C (n' + m) hl (vAppend C n' m tl vr)
      end = vAppend C n0 m vl0 vr)
 with
 | vnil _ =>
     eq_refl (Vec C (0 + m))
       match vnil C in (Vec _ n0) return (Vec C (n0 + m)) with
       | vnil _ => vr
       | vcons _ n' hl tl => vcons C (n' + m) hl (vAppend C n' m tl vr)
       end
 | vcons _ n0 c vc =>
     eq_refl (Vec C ((S n0) + m))
       match vcons C n0 c vc in (Vec _ n1) return (Vec C (n1 + m)) with
       | vnil _ => vr
       | vcons _ n' hl tl => vcons C (n' + m) hl (vAppend C n' m tl vr)
       end
 end).
*)

(*
(fix
 ReflParam_matchR_Vec_pmtcty_RR0 (C C₂ : Set) (C_R : C -> C₂ -> Prop)
                                 (m m₂ : nat) (m_R : nat_RR m m₂)
                                 (H : Vec C m) (H0 : Vec C₂ m₂) {struct H} : Prop :=
   match H in (Vec _ m0) return (nat_RR m0 m₂ -> Prop) with
   | vnil _ =>
       match H0 in (Vec _ m₂0) return (nat_RR 0 m₂0 -> Prop) with
       | vnil _ =>
           fun m_R0 : nat_RR 0 0 =>
           ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R 0 0
             Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0 m_R0
       | vcons _ n₂ _ _ => fun _ : nat_RR 0 (S n₂) => False
       end
   | vcons _ n c vc =>
       match H0 in (Vec _ m₂0) return (nat_RR (S n) m₂0 -> Prop) with
       | vnil _ => fun _ : nat_RR (S n) 0 => False
       | vcons _ n₂ c₂ vc₂ =>
           fun m_R0 : nat_RR (S n) (S n₂) =>
           {n_R : nat_RR n n₂ &
           {_ : C_R c c₂ &
           {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ &
           ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R (S n)
             (S n₂) (O_RR n n₂ n_R) m_R0}}}
       end
   end m_R)
(fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) (n n₂ : nat) (c : C) (c₂ : C₂)
   (vc : Vec C n) (vc₂ : Vec C₂ n₂) (m_R : nat_RR (S n) (S n₂))
   (sigt_R : {n_R : nat_RR n n₂ &
             {_ : C_R c c₂ &
             {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ &
             ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R (S n)
               (S n₂) (O_RR n n₂ n_R) m_R}}})
   (retTyp_R : forall m_R0 : nat_RR (S n) (S n₂),
               {n_R : nat_RR n n₂ &
               {_ : C_R c c₂ &
               {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ &
               ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                 (S n) (S n₂) (O_RR n n₂ n_R) m_R0}}} -> Set)
   (rett_R : forall (n_R : nat_RR n n₂) (c_R : C_R c c₂)
               (vc_R : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂),
             retTyp_R (O_RR n n₂ n_R)
               (existT (nat_RR n n₂)
                  (fun n_R0 : nat_RR n n₂ =>
                   {_ : C_R c c₂ &
                   {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R0 vc vc₂ &
                   ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                     (S n) (S n₂) (O_RR n n₂ n_R0) (O_RR n n₂ n_R)}}) n_R
                  (existT (C_R c c₂)
                     (fun _ : C_R c c₂ =>
                      {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ &
                      ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                        (S n) (S n₂) (O_RR n n₂ n_R) (O_RR n n₂ n_R)}) c_R
                     (existT (ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂)
                        (fun _ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ =>
                         ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                           (S n) (S n₂) (O_RR n n₂ n_R) (O_RR n n₂ n_R)) vc_R
                        (ReflParam_matchR_Vec_pmtcty_RR0_indicesc C C₂ C_R
                           (S n) (S n₂) (O_RR n n₂ n_R)))))) =>
 sigT_rec
   (fun
      sigt_R0 : {n_R : nat_RR n n₂ &
                {_ : C_R c c₂ &
                {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ &
                ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                  (S n) (S n₂) (O_RR n n₂ n_R) m_R}}} => retTyp_R m_R sigt_R0)
   (fun n_R : nat_RR n n₂ =>
    sigT_rec
      (fun
         sigt_R0 : {_ : C_R c c₂ &
                   {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ &
                   ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                     (S n) (S n₂) (O_RR n n₂ n_R) m_R}} =>
       retTyp_R m_R
         (existT (nat_RR n n₂)
            (fun n_R0 : nat_RR n n₂ =>
             {_ : C_R c c₂ &
             {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R0 vc vc₂ &
             ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R (S n)
               (S n₂) (O_RR n n₂ n_R0) m_R}}) n_R sigt_R0))
      (fun c_R : C_R c c₂ =>
       sigT_rec
         (fun
            sigt_R0 : {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ &
                      ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                        (S n) (S n₂) (O_RR n n₂ n_R) m_R} =>
          retTyp_R m_R
            (existT (nat_RR n n₂)
               (fun n_R0 : nat_RR n n₂ =>
                {_ : C_R c c₂ &
                {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R0 vc vc₂ &
                ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                  (S n) (S n₂) (O_RR n n₂ n_R0) m_R}}) n_R
               (existT (C_R c c₂)
                  (fun _ : C_R c c₂ =>
                   {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ &
                   ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                     (S n) (S n₂) (O_RR n n₂ n_R) m_R}) c_R sigt_R0)))
         (fun (vc_R : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂)
            (sigt_R0 : ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                         (S n) (S n₂) (O_RR n n₂ n_R) m_R) =>
          match
            sigt_R0 as sigt_R1 in (ReflParam_matchR_Vec_pmtcty_RR0_indices _ _ _ _ _ _ m_R0)
            return
              (retTyp_R m_R0
                 (existT (nat_RR n n₂)
                    (fun n_R0 : nat_RR n n₂ =>
                     {_ : C_R c c₂ &
                     {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R0 vc vc₂ &
                     ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                       (S n) (S n₂) (O_RR n n₂ n_R0) m_R0}}) n_R
                    (existT (C_R c c₂)
                       (fun _ : C_R c c₂ =>
                        {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ &
                        ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                          (S n) (S n₂) (O_RR n n₂ n_R) m_R0}) c_R
                       (existT (ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂)
                          (fun _ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂
                           =>
                           ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R
                             (S n) (S n₂) (O_RR n n₂ n_R) m_R0) vc_R sigt_R1))))
          with
          | ReflParam_matchR_Vec_pmtcty_RR0_indicesc _ _ _ _ _ _ => rett_R n_R c_R vc_R
          end))) sigt_R)
(fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) (n n₂ : nat) (n_R : nat_RR n n₂)
   (c : C) (c₂ : C₂) (c_R : C_R c c₂) (vc : Vec C n) (vc₂ : Vec C₂ n₂)
   (vc_R : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂) =>
 existT (nat_RR n n₂)
   (fun n_R0 : nat_RR n n₂ =>
    {_ : C_R c c₂ &
    {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R0 vc vc₂ &
    ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R (S n) (S n₂)
      (O_RR n n₂ n_R0) (O_RR n n₂ n_R)}}) n_R
   (existT (C_R c c₂)
      (fun _ : C_R c c₂ =>
       {_ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ &
       ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R (S n) (S n₂)
         (O_RR n n₂ n_R) (O_RR n n₂ n_R)}) c_R
      (existT (ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂)
         (fun _ : ReflParam_matchR_Vec_pmtcty_RR0 C C₂ C_R n n₂ n_R vc vc₂ =>
          ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R (S n)
            (S n₂) (O_RR n n₂ n_R) (O_RR n n₂ n_R)) vc_R
         (ReflParam_matchR_Vec_pmtcty_RR0_indicesc C C₂ C_R (S n) (S n₂) (O_RR n n₂ n_R)))))
(fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) (m_R : nat_RR 0 0)
   (sigt_R : ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R 0 0
               Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0 m_R)
   (retTyp_R : forall m_R0 : nat_RR 0 0,
               ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R 0 0
                 Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0 m_R0 -> Set)
   (rett_R : retTyp_R Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0
               (ReflParam_matchR_Vec_pmtcty_RR0_indicesc C C₂ C_R 0 0
                  Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0)) =>
 (fun
    sigt_R0 : ReflParam_matchR_Vec_pmtcty_RR0_indices C C₂ C_R 0 0
                Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0 m_R =>
  match
    sigt_R0 as sigt_R1 in (ReflParam_matchR_Vec_pmtcty_RR0_indices _ _ _ _ _ _ m_R0)
    return (retTyp_R m_R0 sigt_R1)
  with
  | ReflParam_matchR_Vec_pmtcty_RR0_indicesc _ _ _ _ _ _ => rett_R
  end) sigt_R)
(fun (C C₂ : Set) (C_R : C -> C₂ -> Prop) =>
 ReflParam_matchR_Vec_pmtcty_RR0_indicesc C C₂ C_R 0 0
   Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0)
*)
Definition vapp :=
(let
   fix
   vAppend (C : Set) (n m : nat) (vl : Vec C n) (vr : Vec C m) {struct vl} :
     Vec C (n + m) :=
     match vl in (Vec _ n0) return (Vec C (n0 + m)) with
     | vnil _ => vr
     | vcons _ n' hl tl => vcons C (n' + m) hl (vAppend C n' m tl vr)
     end in
 let
   fix
   vAppend₂ (C₂ : Set) (n₂ m₂ : nat) (vl₂ : Vec C₂ n₂)
            (vr₂ : Vec C₂ m₂) {struct vl₂} : Vec C₂ (n₂ + m₂) :=
     match vl₂ in (Vec _ n₂0) return (Vec C₂ (n₂0 + m₂)) with
     | vnil _ => vr₂
     | vcons _ n'₂ hl₂ tl₂ =>
         vcons C₂ (n'₂ + m₂) hl₂ (vAppend₂ C₂ n'₂ m₂ tl₂ vr₂)
     end in
 fun (C : Set) (n m : nat) (vl : Vec C n) (vr : Vec C m) =>
 match
   vl as vl0 in (Vec _ n0)
   return
     (match vl0 in (Vec _ n1) return (Vec C (n1 + m)) with
      | vnil _ => vr
      | vcons _ n' hl tl => vcons C (n' + m) hl (vAppend C n' m tl vr)
      end = vAppend C n0 m vl0 vr)
 with
 | vnil _ => eq_refl
 | vcons _ n0 c vc => eq_refl
 end).

Notation Vec_RR := ReflParam_matchR_Vec_pmtcty_RR0.

Definition vcons_RR  : forall (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (n₁ n₂ : nat) (n_R : nat_RR n₁ n₂)
  (H : C₁) (H0 : C₂) (c_R : C_R H H0) (H1 : Vec C₁ n₁) (H2 : Vec C₂ n₂)
  (v_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R H1 H2),
  Vec_RR C₁ C₂ C_R (S n₁) (S n₂) (S_RR n₁ n₂ n_R)
         (vcons C₁ n₁ H H1) (vcons C₂ n₂ H0 H2):=
         ReflParam_matchR_Vec_pmtcty_RR0_constr_1.

Run TemplateProgram (genParam indTransEnv false true "vAppend").

Open Scope nat_scope.
Require Import SquiggleEq.UsefulTypes.
Definition ReflParam_matchR_vAppend_pmtcty_RR :
forall (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (n₁ n₂ : nat)
   (n_R : nat_RR n₁ n₂) (m₁ m₂ : nat) (m_R : nat_RR m₁ m₂)
   (vl₁ : Vec C₁ n₁) (vl₂ : Vec C₂ n₂)
   (vl_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R vl₁ vl₂)
   (vr₁ : Vec C₁ m₁) (vr₂ : Vec C₂ m₂)
   (vr_R : Vec_RR C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂) ,
    Vec_RR C₁ C₂ C_R (n₁ + m₁) (n₂ + m₂) (add_RR n₁ n₂ n_R m₁ m₂ m_R)
         (vAppend vl₁ vr₁) (vAppend vl₂ vr₂)
:= vAppend_pmtcty_RR.

Lemma typesMatc :
forall (C₁ C₂ : Set) (C_R : C₁ -> C₂ -> Prop) (n₁ n₂ : nat)
   (n_R : nat_RR n₁ n₂) (m₁ m₂ : nat) (m_R : nat_RR m₁ m₂)
   (vl₁ : Vec C₁ n₁) (vl₂ : Vec C₂ n₂)
   (vl_R : Vec_RR C₁ C₂ C_R n₁ n₂ n_R vl₁ vl₂)
   (vr₁ : Vec C₁ m₁) (vr₂ : Vec C₂ m₂)
   (vr_R : Vec_RR C₁ C₂ C_R m₁ m₂ m_R vr₁ vr₂) ,

    Vec_RR C₁ C₂ C_R (n₁ + m₁) (n₂ + m₂) (add_RR n₁ n₂ n_R m₁ m₂ m_R)
         (vAppend vl₁ vr₁) (vAppend vl₂ vr₂)
         =
       Vec_RR C₁ C₂ C_R (n₁ + m₁) (n₂ + m₂) (Coq_Init_Nat_add_pmtcty_RR n₁ n₂ n_R m₁ m₂ m_R)
         ((fix
           vAppend (C0 : Set) (n0 m0 : nat) (vl0 : Vec C0 n0) (vr0 : Vec C0 m0) {struct vl0} :
             Vec C0 (n0 + m0) :=
             match vl0 in (Vec _ n1) return (Vec C0 (n1 + m0)) with
             | vnil _ => vr0
             | vcons _ n' hl tl => vcons C0 (n' + m0) hl (vAppend C0 n' m0 tl vr0)
             end) C₁ n₁ m₁ vl₁ vr₁)
         ((fix
           vAppend₂ (C₂0 : Set) (n₂0 m₂0 : nat) (vl₂0 : Vec C₂0 n₂0)
                    (vr₂0 : Vec C₂0 m₂0) {struct vl₂0} : Vec C₂0 (n₂0 + m₂0) :=
             match vl₂0 in (Vec _ n₂1) return (Vec C₂0 (n₂1 + m₂0)) with
             | vnil _ => vr₂0
             | vcons _ n'₂ hl₂ tl₂ =>
                 vcons C₂0 (n'₂ + m₂0) hl₂ (vAppend₂ C₂0 n'₂ m₂0 tl₂ vr₂0)
             end) C₂ n₂ m₂ vl₂ vr₂).
Proof.
  reflexivity.
Qed.

Definition Vec_rect_type :=
forall (C : Set) (P : forall n : nat, Vec C n -> Set),
       P 0 (vnil C) ->
       (forall (n : nat) (c : C) (v : Vec C n), P n v -> P (S n) (vcons C n c v)) ->
       forall (n : nat) (v : Vec C n), P n v.

Require Import SquiggleEq.tactics.

Arguments eq_refl:clear implicits.

Print vAppend_RR.
(*
vAppend_RR =
let
  fix vAppend (C : Set) (n m : nat) (vl : Vec C n) (vr : Vec C m) {struct vl} :
    Vec C (n + m) :=
    match vl in (Vec _ n0) return (Vec C (n0 + m)) with
    | vnil _ => vr
    | vcons _ n' hl tl => vcons C (n' + m) hl (vAppend C n' m tl vr)
    end in
let
  fix vAppend₂ (C₂ : Set) (n₂ m₂ : nat) (vl₂ : Vec C₂ n₂) (vr₂ : Vec C₂ m₂) {struct vl₂} :
    Vec C₂ (n₂ + m₂) :=
    match vl₂ in (Vec _ n₂0) return (Vec C₂ (n₂0 + m₂)) with
    | vnil _ => vr₂
    | vcons _ n'₂ hl₂ tl₂ => vcons C₂ (n'₂ + m₂) hl₂ (vAppend₂ C₂ n'₂ m₂ tl₂ vr₂)
    end in
fun (C : Set) (n m : nat) (vl : Vec C n) (vr : Vec C m) =>
match
  vl as vl0 in (Vec _ n0)
  return
    (match vl0 in (Vec _ n1) return (Vec C (n1 + m)) with
     | vnil _ => vr
     | vcons _ n' hl tl => vcons C (n' + m) hl (vAppend C n' m tl vr)
     end = vAppend C n0 m vl0 vr)
with
| vnil _ =>
    eq_refl (Vec C (0 + m))
      match vnil C in (Vec _ n0) return (Vec C (n0 + m)) with
      | vnil _ => vr
      | vcons _ n' hl tl => vcons C (n' + m) hl (vAppend C n' m tl vr)
      end
| vcons _ n0 c vc =>
    eq_refl (Vec C (S n0 + m))
      match vcons C n0 c vc in (Vec _ n1) return (Vec C (n1 + m)) with
      | vnil _ => vr
      | vcons _ n' hl tl => vcons C (n' + m) hl (vAppend C n' m tl vr)
      end
end
     : forall (C : Set) (n m : nat) (vl : Vec C n) (vr : Vec C m),
       match vl in (Vec _ n0) return (Vec C (n0 + m)) with
       | vnil _ => vr
       | vcons _ n' hl tl =>
           vcons C (n' + m) hl
             ((fix
               vAppend (C0 : Set) (n0 m0 : nat) (vl0 : Vec C0 n0)
                       (vr0 : Vec C0 m0) {struct vl0} : Vec C0 (n0 + m0) :=
                 match vl0 in (Vec _ n1) return (Vec C0 (n1 + m0)) with
                 | vnil _ => vr0
                 | vcons _ n'0 hl0 tl0 =>
                     vcons C0 (n'0 + m0) hl0 (vAppend C0 n'0 m0 tl0 vr0)
                 end) C n' m tl vr)
       end =
       (fix
        vAppend (C0 : Set) (n0 m0 : nat) (vl0 : Vec C0 n0) (vr0 : Vec C0 m0) {struct vl0} :
          Vec C0 (n0 + m0) :=
          match vl0 in (Vec _ n1) return (Vec C0 (n1 + m0)) with
          | vnil _ => vr0
          | vcons _ n' hl tl => vcons C0 (n' + m0) hl (vAppend C0 n' m0 tl vr0)
          end) C n m vl vr

Argument scopes are [type_scope nat_scope nat_scope _ _]

*)

(* Notation vAppend_RR := ReflParam_matchR_vAppend_pmtcty_RR. *)

Print sigT_rect.

Print indTransEnv.
Open Scope N_scope.
Run TemplateProgram (genParam indTransEnv false true "vAppend2").
 (* success!*)
(* Print vAppend2_RR. *)


Require Import Coqlib.
Require Import Asm.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

Definition peep_mov_nop_example : code :=
  Pmov_rr EAX EAX :: Pmov_rr EBX EBX :: nil.

Section MOV_NOP.

  Variable concrete : code.

  Variable r1 : ireg.
  Variable r2 : ireg.
  Hypothesis r1_r2_neq: r1 <> r2.

  Definition peep_mov_nop_defs : rewrite_defs :=
    {|
      fnd :=
        Pmov_rr r1 r1 ::
                Pmov_rr r2 r2 :: nil
      ; rpl :=
          Pnop :: Pnop :: nil
      ; lv_in := IR r1 :: IR r2 :: PC :: nil
      ; lv_out := IR r1 :: IR r2 :: PC :: nil
      ; clobbered := nil
    |}.

  Lemma peep_mov_nop_selr :
    StepEquiv.step_through_equiv_live (fnd peep_mov_nop_defs) (rpl peep_mov_nop_defs) (lv_in peep_mov_nop_defs) (lv_out peep_mov_nop_defs).
  Proof.
    prep_l.
    step_l.
    step_l.
    prep_r.
    step_r.
    step_r.
    finish_r.
    prep_eq'.
    subst_max.
    preg_simpl.
    assumption.
    subst_max.
    preg_simpl.
    assumption.
    simpl.
    preg_simpl.
    repeat find_rewrite_goal.
    reflexivity.
  Qed.

  Definition peep_mov_nop_proofs : rewrite_proofs :=
    {|
      defs := peep_mov_nop_defs
      ; selr := peep_mov_nop_selr
    |}.

  Definition peep_mov_nop :
    concrete = fnd peep_mov_nop_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite peep_mov_nop_defs peep_mov_nop_proofs.
  Qed.

End MOV_NOP.

Definition peep_mov_nop_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_mov_nop p.
  unfold peep_mov_nop_defs in p.
  simpl in p.
  specialize (p c).
  do 2 set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat peep_mov_nop_example.
  set_instr_eq i0 1%nat peep_mov_nop_example.
  set_ireg_eq rd r1.
  set_ireg_eq rd0 r0.
  set_ireg_neq r1 r0.
  specialize (p _ _ n eq_refl). exact (Some p).
Defined.

Definition mov_nop (c : code) : list StepEquiv.rewrite :=
  collect (map peep_mov_nop_rewrite (ParamSplit.matched_pat peep_mov_nop_example c)).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O B C Bprime Cprime X Y B0 C0 : Universe, ((wd_ Cprime O /\ (wd_ Bprime O /\ (wd_ B O /\ (wd_ B C /\ (wd_ C O /\ (wd_ X Y /\ (wd_ B0 O /\ (wd_ C0 O /\ (wd_ X C0 /\ (wd_ Y C /\ (wd_ X C /\ (wd_ Y B /\ (wd_ X B /\ (wd_ B Bprime /\ (wd_ C C0 /\ (wd_ B B0 /\ (wd_ C Bprime /\ (wd_ B Cprime /\ (wd_ Cprime C /\ (wd_ Cprime Bprime /\ (col_ O Bprime Cprime /\ (col_ B O C /\ (col_ O X Y /\ (col_ X Y B0 /\ col_ X Y C0)))))))))))))))))))))))) -> col_ C0 X O)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ A Bprime /\ (wd_ A Aprime /\ (wd_ O Aprime /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ (col_ O Aprime Cprime /\ col_ O C Bprime)))))))))))))) -> col_ O A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D Aprime Bprime Cprime Dprime X Y : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A B /\ (wd_ Aprime Bprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ X Y /\ (wd_ X B /\ (wd_ A Y /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ A D /\ (wd_ Aprime Dprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ col_ Y B Dprime))))))))))))))))))))))))) -> col_ X Aprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1 A2 B1 B2 C1 C2 P : Universe, ((wd_ A1 A2 /\ (wd_ C1 C2 /\ (wd_ B1 B2 /\ (col_ P B1 B2 /\ (col_ P C1 C2 /\ (col_ A1 A2 P /\ (col_ A1 B1 B2 /\ (col_ A2 B1 B2 /\ (col_ A1 C1 C2 /\ col_ A2 C1 C2))))))))) -> col_ C1 B1 B2)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Events.
Require Import TraceModel.
Require Import Properties.
Require Import CommonST.
Require Import Robustdef.
Require Import Criteria.
Require Import Setoid.
Require Import ClassicalExtras.
Require Import Logic.ClassicalFacts.
Require Import TechnicalLemmas.

(** This file proves that R2RTP implies RTEP *)

(** *our assumptions *)
(**********************************************************)
Hypothesis input_totality_tgt : input_totality tgt.
Hypothesis determinacy_src    : determinacy src.
Hypothesis tgt_sem            : semantics_safety_like tgt.
(**********************************************************)

Theorem R2rTP_RTIP : R2rTP -> RTIP.
Proof.
  intros r2rpp. unfold RTIP. apply NNPP.
  intros hf. rewrite not_forall_ex_not in hf. destruct hf as [P1 hf].
  rewrite not_forall_ex_not in hf. destruct hf as [P2 hf].
  rewrite not_imp in hf. destruct hf as [H1 hf].
  unfold "⊆" in *.
  rewrite not_forall_ex_not in hf. destruct hf as [Ct hf].
  rewrite not_forall_ex_not in hf. destruct hf as [t hf].
  rewrite not_imp in hf. destruct hf as [k1 k2].
  specialize (r2rpp P1 P2 traces_match).
  assert (Hsat : rsat2 P1 P2 traces_match).
  { intros C b1 b2 Hb1 Hb2. apply (H1 C b1) in Hb1.
    unfold beh in Hb1.
    now apply (determinacy_src (C [P2])). }
  specialize (r2rpp Hsat Ct t); clear Hsat.
  assert (H : forall t2, sem tgt (Ct [P2 ↓]) t2 -> traces_match t t2).
  { intros t2 H. now apply r2rpp. } clear r2rpp H1.
  destruct (longest_in_psem tgt_sem (Ct [P2 ↓]) t k2) as [l [Hmt [Hpsem_m Hmax_m]]].
  destruct Hpsem_m as [t2 [Hmt2 Hsem_t2]].
  specialize (H t2 Hsem_t2). destruct H; try now subst.
  destruct H as [ll [i1 [i2 [Hi1 [Hi2 [Hdiffi [Hpref1 Hpref2]]]]]]].
  assert (psem (Ct [P2 ↓]) (ftbd (snoc ll i1))).
  { apply (input_totality_tgt (Ct [P2 ↓]) ll i2 i1); auto. now exists t2. }
  assert (fpr (ftbd (snoc ll i1)) l) by now apply Hmax_m.
  apply (fpr_pref_pref _ _ t2) in H0; auto.
  destruct (same_ext (ftbd (snoc ll i1)) (ftbd (snoc ll i2)) t2); auto;
    simpl in H1.
  ++ apply (list_snoc_pointwise ll ll i1 i2 i2 i2) in H1; auto.
     inversion H1. congruence. now apply list_list_prefix_ref.
  ++ apply (list_snoc_pointwise ll ll i2 i1 i1 i1) in H1; auto.
     inversion H1. congruence. now apply list_list_prefix_ref.
Qed.

Theorem R2rTP_RTEP : R2rTP -> RTEP.
Proof.  intros H. apply RTIP_RTEP. exact (R2rTP_RTIP H). Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B X Y M Aprime Bprime : Universe, ((wd_ X Y /\ (wd_ A M /\ (wd_ Aprime M /\ (wd_ B M /\ (wd_ Bprime M /\ (wd_ B X /\ (wd_ B Y /\ (wd_ A X /\ (wd_ A Y /\ (wd_ B Bprime /\ (col_ X Y M /\ (col_ A M Aprime /\ (col_ Aprime X Y /\ col_ M B Bprime))))))))))))) -> col_ M Aprime X)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export Static.

Require Import SyntaxProp.
Require Import MapProp.
Require Import Shared.

Lemma hasType_ctx :
  forall Gamma e t ctx,
    is_econtext ctx ->
    Gamma |- ctx e \in t ->
    exists t', Gamma |- e \in t'.
Proof with eauto.
  introv Hctx hasType.
  inv Hctx; inv hasType...
Qed.

Lemma free_in_env :
  forall Gamma x e t,
   In x (freeVars e) ->
   Gamma |- e \in t ->
   exists t', Gamma x = Some t'.
Proof with eauto.
  introv HIn hasType. gen t. gen Gamma.
  expr_cases(induction e) Case; intros;
    simpls; try inv HIn; inv hasType...
  + inv H.
  + apply in_app_or in HIn. inv HIn...
  + apply in_app_or in HIn. inv HIn...
    destruct (id_eq_dec x v).
    - subst. assert (~ In v (remove Nat.eq_dec v (freeVars e2))).
      eapply remove_in_eq... contradiction.
    - eapply remove_in in H...
      eapply IHe2 with (Gamma := extend (activeEnv Gamma) v TPas) in H as [t' Heq]...
      unfold extend in Heq. case_if...
      unfold activeEnv in Heq.
      destruct (Gamma x). case_if... inv Heq.
  + destruct (id_eq_dec x v).
    - subst. assert (~ In v (remove Nat.eq_dec v (freeVars e))).
      eapply remove_in_eq... contradiction.
    - eapply remove_in in HIn...
      eapply IHe with (Gamma := extend Gamma v t) in bodyHasType as [t' Heq]...
      unfold extend in Heq. case_if...
Qed.

Lemma hasType_closed :
  forall e t,
    empty |- e \in t ->
    freeVars e = nil.
Proof with eauto.
  introv hasType.
  assert (forall x, In x (freeVars e) -> exists T' : ty, empty x = Some T') as Hex.
    intros. eapply free_in_env...
  assert (forall x, ~ In x (freeVars e)) as HnIn.
    introv HIn. apply Hex in HIn as [contra].
    inv H.
  destruct (freeVars e)...
  assert (In v (v :: l)) as HIn
      by (constructors; eauto)...
  contradict HIn...
Qed.

Lemma hasType_subsumption :
  forall Gamma Gamma' e t,
    Gamma |- e \in t ->
    (forall x, In x (freeVars e) -> Gamma x = Gamma' x) ->
    Gamma' |- e \in t.
Proof with eauto using hasType.
  introv hasType Hsub. gen Gamma'.
  hasType_cases(induction hasType) Case;
    intros; simpls...
  + Case "T_Var".
    constructors...
    inv Hlookup... symmetry...
  + Case "T_Mutate".
    constructors...
  + Case "T_Lam".
    constructors...
    eapply IHhasType...
    intros. case_extend.
    apply Hsub...
    apply remove_in_neq...
  + Case "T_Apply".
    assert (forall x : var, In x (freeVars e1) -> Gamma x = Gamma' x).
      introv HIn. apply Hsub. apply in_app_iff...
    assert (forall x : var, In x (freeVars e2) -> Gamma x = Gamma' x).
      introv HIn. apply Hsub. apply in_app_iff...
    constructors...
  + Case "T_Send".
    constructors...
    - eapply IHhasType1...
      intros.
      apply Hsub...
      apply in_app_iff...
    - eapply IHhasType2...
      intros. case_extend.
      assert (Gamma x0 = Gamma' x0) as Heq.
        apply Hsub. apply in_app_iff.
        right. apply remove_in_neq...
      unfold activeEnv.
      rewrite Heq...
Qed.

Corollary hasType_flip :
  forall Gamma x y e t t1 t2,
    extend (extend Gamma x t1) y t2 |- e \in t ->
    x <> y ->
    extend (extend Gamma y t2) x t1 |- e \in t.
Proof with eauto using hasType_subsumption.
  introv hasType Hneq.
  eapply hasType_subsumption
  with (Gamma := (extend (extend Gamma x t1) y t2))...
Qed.

Corollary hasType_shadow :
  forall Gamma x y e t t1 t2,
    extend (extend Gamma x t1) y t2 |- e \in t ->
    x = y ->
    extend Gamma y t2 |- e \in t.
Proof with eauto with env.
  introv hasType Hneq.
  eapply hasType_subsumption
  with (Gamma' := extend Gamma y t2)
  in hasType; eauto 2 with env.
Qed.

Corollary hasType_empty :
  forall Gamma e t,
    empty |- e \in t ->
    Gamma |- e \in t.
Proof with eauto.
  introv hasType.
  eapply hasType_subsumption
  with (Gamma' := Gamma)...
  introv HIn. apply hasType_closed in hasType...
  rewrite hasType in *. inv HIn.
Qed.

Lemma freeLocs_active_val :
  forall Gamma v t,
    Gamma |- v \in t ->
    is_active t = true ->
    is_val v ->
    freeLocs v = nil.
Proof with eauto.
  introv hasType Hact Hval.
  unfolds is_active.
  inv Hval; inv hasType; inv Hact...
Qed.

Lemma hasType_subst :
  forall Gamma e x v t1 t2,
    extend Gamma x t2 |- e \in t1 ->
    empty |- v \in t2 ->
    is_val v ->
    Gamma |- subst x v e \in t1.
Proof with eauto using hasType, hasType_empty, hasType_flip, hasType_shadow with env.
  introv hasType vHasType Hval.
  gen vHasType. gen v. gen t1. gen t2. gen x. gen Gamma.
  expr_cases(induction e) Case;
    intros; inv hasType; simpl...
  + Case "EVar".
    case_if...
    subst. simpl_extend_hyp...
    inv Hlookup...
  + Case "ESend".
    case_if.
    - subst. constructors...
      eapply hasType_subsumption...
      introv HIn. case_extend...
      unfold activeEnv. case_if...
    - constructors...
      * eapply IHe2... eapply hasType_flip...
        eapply hasType_subsumption...
        introv HIn.
        case_extend.
        ++ unfold activeEnv.
           cases_if. cases_if...
           eapply free_in_env in HIn as [t Heq]...
           rewrite extend_neq in Heq...
           unfolds activeEnv. rewrite extend_eq in Heq...
           case_if...
        ++ unfold activeEnv.
           cases_if. destruct (Gamma x0)...
      * assert (Halt : {In x (freeVars e2)} + {~ In x (freeVars e2)})
            by (apply in_dec; apply id_eq_dec).
        inv Halt as [HIn | HnIn].
        ++ eapply free_in_env in HIn as [t Heq]...
           rewrite extend_neq in Heq...
           unfolds activeEnv. rewrite extend_eq in Heq...
           case_if...
           assert (freeLocs v0 = nil)
               by eauto using freeLocs_active_val.
           apply freeLocs_subst...
        ++ rewrite subst_not_in...
  + case_if...
Qed.


Require Import VST.floyd.proofauto.
Require Import pile.
Require Import spec_stdlib.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Global Open Scope funspec_scope.

Definition tlist := Tstruct _list noattr.
Definition tpile := Tstruct _pile noattr.

Fixpoint listrep (sigma: list Z) (x: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
       !! (0 <= h <=  Int.max_signed) &&
      data_at Ews tlist (Vint (Int.repr h), y) x
     * malloc_token Ews tlist x
     *  listrep hs y
 | nil =>
    !! (x = nullval) && emp
 end.

Lemma listrep_local_facts:
  forall sigma p,
   listrep sigma p |--
   !! (is_pointer_or_null p
      /\ (p=nullval <-> sigma=nil)
       /\ Forall (Z.le 0) sigma).
Proof.
intros.
revert p; induction sigma;
  unfold listrep; fold listrep; intros.
  entailer!; intuition.
Intros y. entailer!.
split.
split; intro. subst p. destruct H0; contradiction. discriminate.
constructor; auto. lia.
Qed.

Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep sigma p |-- valid_pointer p.
Proof.
 destruct sigma; unfold listrep; fold listrep;
 intros; entailer!; auto with valid_pointer.
Qed.

Hint Resolve listrep_valid_pointer : valid_pointer.

Definition pilerep (sigma: list Z) (p: val) : mpred :=
  EX x:val, data_at Ews tpile x p
             * listrep sigma x.

Definition pile_freeable (p: val) : mpred :=
            malloc_token Ews tpile p.

Lemma pilerep_local_facts:
  forall sigma p,
   pilerep sigma p |-- !! (isptr p /\ Forall (Z.le 0) sigma).
Proof.
intros.
unfold pilerep.
Intros q.
entailer!.
Qed.

Hint Resolve pilerep_local_facts : saturate_local.

Lemma pilerep_valid_pointer:
  forall sigma p,
   pilerep sigma p |-- valid_pointer p.
Proof.
 intros.
 unfold pilerep. Intros x.
 entailer!; auto with valid_pointer.
Qed.
Hint Resolve pilerep_valid_pointer : valid_pointer.

Local Open Scope assert.

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH t:type, gv: globals
   PRE [ tuint ]
       PROP (0 <= sizeof t <= Int.max_unsigned;
                complete_legal_cosu_type t = true;
                natural_aligned natural_alignment t = true)
       PARAMS (Vint (Int.repr (sizeof t))) GLOBALS(gv)
       SEP (mem_mgr gv)
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       RETURN (p)
       SEP (mem_mgr gv; malloc_token Ews t p * data_at_ Ews t p).

Definition Pile_new_spec :=
 DECLARE _Pile_new
 WITH gv: globals
 PRE [ ] PROP() PARAMS() GLOBALS(gv) SEP(mem_mgr gv)
 POST[ tptr tpile ]
   EX p: val,
      PROP() RETURN(p)
      SEP(pilerep nil p; pile_freeable p; mem_mgr gv).

Definition Pile_add_spec :=
 DECLARE _Pile_add
 WITH p: val, n: Z, sigma: list Z, gv: globals
 PRE [ tptr tpile, tint  ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (p; Vint (Int.repr n)) GLOBALS(gv)
    (SEP(pilerep sigma p; mem_mgr gv))
 POST[ tvoid ]
    PROP() RETURN()
    SEP(pilerep (n::sigma) p; mem_mgr gv).

Definition sumlist : list Z -> Z := List.fold_right Z.add 0.

Definition Pile_count_spec :=
 DECLARE _Pile_count
 WITH p: val, sigma: list Z
 PRE [ tptr tpile  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    PARAMS (p)
    SEP (pilerep sigma p)
 POST[ tint ]
      PROP()
      RETURN (Vint (Int.repr (sumlist sigma)))
      SEP(pilerep sigma p).

Definition Pile_free_spec :=
 DECLARE _Pile_free
 WITH p: val, sigma: list Z, gv: globals
 PRE [ tptr tpile  ]
    PROP()
    PARAMS(p) GLOBALS(gv)
    (SEP(pilerep sigma p; pile_freeable p; mem_mgr gv))
 POST[ tvoid ]
     PROP() RETURN() SEP(mem_mgr gv).

Definition ispecs := [surely_malloc_spec].
Definition specs := [Pile_new_spec; Pile_add_spec; Pile_count_spec; Pile_free_spec].

(*
(*Clients -- apile.v and onepile.v -- also need these lemmas:*)
Lemma pile_new_aux gx x ret:
(EX p : val, PROP ( )  RETURN (p)  SEP (pilerep [] p; pile_freeable p; mem_mgr x))%assert (make_ext_rval gx ret)
  |-- !! is_pointer_or_null (force_val ret).
Proof.
 rewrite exp_unfold. Intros p.
 rewrite <- insert_local.
 rewrite lower_andp.
 apply derives_extract_prop; intro.
 destruct H; unfold_lift in H. rewrite retval_ext_rval in *.
 subst p. renormalize. entailer!.
Qed.

Lemma pile_count_aux gx l v ret:
  (PROP ( )  LOCAL (temp ret_temp (Vint (Int.repr (sumlist l))))  SEP (pilerep l v)) (make_ext_rval gx ret)
  |-- !! is_int I32 Signed (force_val ret).
Proof.
 rewrite <- insert_local.
 rewrite lower_andp.
 apply derives_extract_prop; intro.
 destruct H; unfold_lift in H. rewrite retval_ext_rval in *.
 rewrite <- H. renormalize.
Qed.
*)


From CoreErlang.BigStep Require Export Induction.
Require Export Lia.
From Coq Require Classes.EquivDec.

Import ListNotations.
Export Arith.PeanoNat.
Import Classes.EquivDec.

Section Basic_Eq_Dec.
(** Decidable equality for product and sum types *)
  Context {A B : Type}.

  Hypothesis A_eq_dec : forall a1 a2 : A, {a1 = a2} + {a1 <> a2}.
  Hypothesis B_eq_dec : forall b1 b2 : B, {b1 = b2} + {b1 <> b2}.

  Proposition prod_eq_dec : forall p1 p2 : A * B, {p1 = p2} + {p1 <> p2}.
  Proof.
    set (eq1 := A_eq_dec).
    set (eq2 := B_eq_dec).
    decide equality.
  Defined.

  Proposition sum_eq_dec : forall p1 p2 : A + B, {p1 = p2} + {p1 <> p2}.
  Proof.
    set (eq1 := A_eq_dec).
    set (eq2 := B_eq_dec).
    decide equality.
  Defined.

  Definition prod_eqb {A B : Type} (eqx : A -> A -> bool) (eqy : B -> B -> bool) (p1 p2 : A * B) :=
  match p1, p2 with
  | (x, y), (x', y') => andb (eqx x x') (eqy y y')
  end.

  Theorem prod_eqb_refl eqx eqy p :
    (forall p1, eqx p1 p1 = true) ->
    (forall p2, eqy p2 p2 = true) ->
    @prod_eqb A B eqx eqy p p = true.
  Proof.
    intros. destruct p. simpl.
    rewrite (H a), (H0 b). auto.
  Qed.

  Theorem prod_eqb_eq :
    forall p1 p2 eqx eqy,
    (forall e1 e2, e1 = e2 <-> eqx e1 e2 = true) ->
    (forall e1 e2, e1 = e2 <-> eqy e1 e2 = true) ->
    p1 = p2
  <->
    @prod_eqb A B eqx eqy p1 p2 = true.
  Proof.
    split.
    * intros. subst. apply prod_eqb_refl.
      intros. apply H. auto. intros. apply H0. auto.
    * intros. destruct p1, p2. pose (H a a0). pose (H0 b b0).
      simpl in H1. apply andb_prop in H1. destruct H1.
      rewrite <- i in H1. rewrite <- i0 in H2. subst. auto.
  Qed.

End Basic_Eq_Dec.

Section list_eqb.

  Context {A : Type}.

  Fixpoint list_eqb (eq : A -> A -> bool) (l1 l2 : list A) : bool :=
  match l1, l2 with
  | [], [] => true
  | x::xs, y::ys => eq x y && list_eqb eq xs ys
  | _, _ => false
  end.

  Proposition list_eqb_refl {f : A -> A -> bool} (l : list A) :
    (forall a, f a a = true)
  ->
    list_eqb f l l = true.
  Proof.
    induction l.
    * simpl. reflexivity.
    * simpl. intros. rewrite (H a), (IHl H). auto.
  Qed.

  Theorem list_eqb_eq :
    forall (l1 l2 : list A) eqf,
    (forall e1 e2, e1 = e2 <-> eqf e1 e2 = true) ->
    l1 = l2
  <->
    list_eqb eqf l1 l2 = true.
  Proof.
    split.
    * intros. subst. apply list_eqb_refl.
      intros. apply H. auto.
    * generalize dependent l2. induction l1; intros.
      - destruct l2; try inversion H0. auto.
      - destruct l2; try inversion H0.
        apply andb_prop in H2. destruct H2. apply H in H1.
        apply IHl1 in H2. subst. auto.
  Qed.

End list_eqb.

Section Equalities.
  (** Decidable and boolean equality for the syntax *)

  Scheme Equality for Literal.

  Fixpoint Pattern_eq_dec (p1 p2 : Pattern) : {p1 = p2} + {p1 <> p2}.
  Proof.
    set (Pattern_list_eq_dec := list_eq_dec Pattern_eq_dec).
    set (Pattern_var_eq_dec := string_dec).
    set (Pattern_literal_eq_dec := Literal_eq_dec).
    set (list_eq_dec (prod_eqdec Pattern_eq_dec Pattern_eq_dec)).
    decide equality.
  Qed.

(** Boolean equalities: *)

  (* The equality of function signatures *)
  Definition funid_eqb (v1 v2 : FunctionIdentifier) : bool :=
  match v1, v2 with
  | (fid1, num1), (fid2, num2) => eqb fid1 fid2 && Nat.eqb num1 num2
  end.

  (* Extended equality between functions and vars *)
  Definition var_funid_eqb (v1 v2 : Var + FunctionIdentifier) : bool :=
  match v1, v2 with
  | inl s1, inl s2 => eqb s1 s2
  | inr f1, inr f2 => funid_eqb f1 f2
  | _, _ => false
  end.

  Definition Literal_eqb (l1 l2 : Literal) : bool :=
  match l1, l2 with
   | Atom s1, Atom s2 => eqb s1 s2
   | Integer x1, Integer x2 => Z.eqb x1 x2
   | _, _ => false
  end.

  Fixpoint Pattern_eqb (p1 p2 : Pattern) {struct p1} : bool :=
  match p1, p2 with
   | PVar v1, PVar v2 => eqb v1 v2
   | PLit l1, PLit l2 => Literal_eqb l1 l2
   | PCons hd tl, PCons hd' tl' => Pattern_eqb hd hd' && Pattern_eqb tl tl'
   | PTuple l, PTuple l' => (fix blist_eq l l' := match l, l' with
                                         | [], [] => true
                                         | x::xs, x'::xs' => andb (Pattern_eqb x x') (blist_eq xs xs')
                                         | _, _ => false
                                         end) l l'
   | PNil, PNil => true
   | PMap l, PMap l' => (fix blist_eq l l' := match l, l' with
                                         | [], [] => true
                                         | (x, y)::xs, (x', y')::xs' =>
                       andb (andb (Pattern_eqb x x') (Pattern_eqb y y')) (blist_eq xs xs')
                                         | _, _ => false
                                         end) l l'
   | _, _ => false
  end.

  Fixpoint Expression_eqb (e1 e2 : Expression) : bool :=
  match e1, e2 with
   | EValues l, EValues l' => (fix blist l l' := match l, l' with
                                        | [], [] => true
                                        | x::xs, x'::xs' => andb (Expression_eqb x x')
                                                                 (blist xs xs')
                                        | _, _ => false
                                        end) l l'
 (*   | ESingle e, ESingle e' => SingleExpression_eqb e e'
   | _, _ => false
  end
  with SingleExpression_eqb (e1 e2 : SingleExpression) : bool :=
  match e1, e2 with *)
   | ENil, ENil => true
   | ELit l, ELit l' => Literal_eqb l l'
   | EVar v, EVar v' => eqb v v'
   | EFunId f, EFunId f' => funid_eqb f f'
   | EFun vl e, EFun vl' e' => list_eqb eqb vl vl' && Expression_eqb e e'
   | ECons hd tl, ECons hd' tl' => Expression_eqb hd hd' && Expression_eqb tl tl'
   | ETuple l, ETuple l' => (fix blist l l' := match l, l' with
                                                 | [], [] => true
                                                 | x::xs, x'::xs' => andb (Expression_eqb x x') (blist xs xs')
                                                 | _, _ => false
                                                 end) l l'
   | ECall m f l, ECall m' f' l' => Expression_eqb f f' && Expression_eqb m m' && (fix blist l l' := match l, l' with
                                                 | [], [] => true
                                                 | x::xs, x'::xs' => andb (Expression_eqb x x') (blist xs xs')
                                                 | _, _ => false
                                                 end) l l'
   | EPrimOp f l, EPrimOp f' l' => eqb f f' && (fix blist l l' := match l, l' with
                                                 | [], [] => true
                                                 | x::xs, x'::xs' => andb (Expression_eqb x x') (blist xs xs')
                                                 | _, _ => false
                                                 end) l l'
   | EApp exp l, EApp exp' l' => Expression_eqb exp exp' && (fix blist l l' := match l, l' with
                                                 | [], [] => true
                                                 | x::xs, x'::xs' => andb (Expression_eqb x x') (blist xs xs')
                                                 | _, _ => false
                                                 end) l l'
   | ECase e l, ECase e' l' => Expression_eqb e e'
    && Nat.eqb (length l) (length l') &&
         (fix blist l l' := match l, l' with
             | [], [] => true
             | (pl,y,z)::xs, (pl',y',z')::xs' => andb (
               (fix blist l l' := match l, l' with
               | [], [] => true
               | x::xs, x'::xs' => andb (Pattern_eqb x x') (blist xs xs')
               | _, _ => false
               end) pl pl')
               (andb (Expression_eqb y y') (andb (Expression_eqb z z') (blist xs xs')))
                                                 | _, _ => false
                                                 end) l l'
   | ELet l e1 e2, ELet l' e1' e2' => list_eqb eqb l l' && Expression_eqb e1 e1' && Expression_eqb e2 e2'
   | ESeq e1 e2, ESeq e1' e2' => andb (Expression_eqb e1 e1') (Expression_eqb e2 e2')
   | ELetRec l e, ELetRec l' e' =>
                                               (fix blist l l' := match l, l' with
                                                 | [], [] => true
                                                 | (x,(y,z))::xs, (x',(y',z'))::xs' => andb (funid_eqb x x') (andb (
                                                     list_eqb eqb
                                                 y y') (andb (Expression_eqb z z') (blist xs xs')))
                                                 | _, _ => false
                                                 end) l l' &&
                                               Expression_eqb e e'
   | EMap l, EMap l' => (fix blist l l' := match l, l' with
                                                 | [], [] => true
                                                 | (x,y)::xs, (x',y')::xs' => andb (Expression_eqb x x') (andb (Expression_eqb y y') (blist xs xs'))
                                                 | _, _ => false
                                                 end) l l'
   | ETry e1 vl1 e2 vl2 e3, ETry e1' vl1' e2' vl2' e3' => list_eqb eqb vl1 vl1' && list_eqb eqb vl2 vl2' &&
                                                          Expression_eqb e1 e1' && Expression_eqb e2 e2' &&
                                                          Expression_eqb e3 e3'
   | _, _ => false
  end.

  Fixpoint Value_eqb (e1 e2 : Value) : bool :=
  match e1, e2 with
  | VNil, VNil => true
  | VLit l, VLit l' => Literal_eqb l l'
  | VClos env ext id p b, VClos env' ext' id' p' b' => Nat.eqb id id'
  | VCons hd tl, VCons hd' tl' => Value_eqb hd hd' && Value_eqb tl tl'
  | VTuple l, VTuple l' => (fix blist l l' := match l, l' with
                                             | [], [] => true
                                             | x::xs, x'::xs' => andb (Value_eqb x x') (blist xs xs')
                                             | _, _ => false
                                             end) l l'
  | VMap l, VMap l' => (fix blist l l' := match l, l' with
                                                   | [], [] => true
                                                   | (x,y)::xs, (x',y')::xs' => andb (Value_eqb x x') (andb (Value_eqb y y') (blist xs xs'))
                                                   | _, _ => false
                                                   end) l l'
  | _, _ => false
  end.

(** Properties of var_funid_eqb *)
  Proposition var_funid_eqb_eq (v0 v : Var + FunctionIdentifier):
    var_funid_eqb v0 v = true <-> v0 = v.
  Proof.
    intros. split; intros.
    { destruct v0, v.
      * inversion H. apply eqb_eq in H1. subst. reflexivity.
      * inversion H.
      * inversion H.
      * inversion H. destruct f, f0. inversion H1. apply Bool.andb_true_iff in H2. inversion H2.
        apply eqb_eq in H0. apply Nat.eqb_eq in H3. subst. reflexivity.
    }
    { destruct v, v0.
      * inversion H. subst. simpl. apply eqb_refl.
      * inversion H.
      * inversion H.
      * inversion H. simpl. destruct f. simpl. rewrite eqb_refl, Nat.eqb_refl. simpl. reflexivity.
    }
  Qed.

  Proposition var_funid_eqb_neq (v0 v : Var + FunctionIdentifier):
    var_funid_eqb v0 v = false <-> v0 <> v.
  Proof.
    split; intros.
    { destruct v0, v.
      * simpl in *. apply eqb_neq in H. unfold not in *. intros. apply H. inversion H0. reflexivity.
      * unfold not. intro. inversion H0.
      * unfold not. intro. inversion H0.
      * destruct f, f0. simpl in H. apply Bool.andb_false_iff in H. inversion H.
        - apply eqb_neq in H0. unfold not in *. intro. apply H0. inversion H1. reflexivity.
        - apply Nat.eqb_neq in H0. unfold not in *. intro. apply H0. inversion H1. reflexivity.
    }
    { destruct v0, v.
      * simpl in *. apply eqb_neq. unfold not in *. intro. apply H. subst. reflexivity.
      * simpl. reflexivity.
      * simpl. reflexivity.
      * simpl. destruct f, f0. simpl. apply Bool.andb_false_iff.
        unfold not in H. case_eq ((s =? s0)%string); intros.
        - right. apply eqb_eq in H0. apply Nat.eqb_neq. unfold not. intro. apply H. subst. reflexivity.
        - left. reflexivity.
    }
  Qed.

  Proposition var_funid_eqb_refl (var : Var + FunctionIdentifier) :
  var_funid_eqb var var = true.
  Proof.
    destruct var.
    * simpl. apply eqb_refl.
    * destruct f. simpl. rewrite eqb_refl, Nat.eqb_refl. simpl. reflexivity.
  Qed.

  Proposition var_funid_eqb_sym (v1 v2 : Var + FunctionIdentifier) :
    var_funid_eqb v1 v2 = var_funid_eqb v2 v1.
  Proof.
    destruct v1, v2.
    * simpl. rewrite eqb_sym. reflexivity.
    * simpl. reflexivity.
    * simpl. reflexivity.
    * simpl. destruct f, f0. simpl. rewrite eqb_sym, Nat.eqb_sym. reflexivity.
  Qed.

  Fixpoint Expression_eq_dec (e1 e2 : Expression) : {e1 = e2} + {e1 <> e2}
  (* with SingleExpression_eq_dec (e1 e2 : SingleExpression) : {e1 = e2} + {e1 <> e2} *).
  Proof.
   (*  * set (list_eq_dec SingleExpression_eq_dec).
      decide equality. *)

    * set (Literal_eq_dec).
      set (string_dec).
      set (OrderedTypeEx.Z_as_OT.eq_dec).
      set (prod_eqdec string_dec Nat.eq_dec).
      set (list_eq_dec string_dec).
      set (list_eq_dec Expression_eq_dec).
      set (list_eq_dec (prod_eqdec (prod_eqdec (list_eq_dec Pattern_eq_dec) Expression_eq_dec) Expression_eq_dec)).
      decide equality.
      - decide equality. decide equality.
      - repeat (decide equality).
      - repeat decide equality.
  Defined.

  Fixpoint Value_eq_dec (v1 v2 : Value) : {v1 = v2} + {v1 <> v2}.
  Proof.
    intros. decide equality.
    * apply Literal_eq_dec.
    * apply Expression_eq_dec.
    * apply list_eq_dec. apply string_dec.
    * apply Nat.eq_dec.
    * apply list_eq_dec. intros.
      apply prod_eq_dec.
      - apply prod_eq_dec.
        + apply Nat.eq_dec.
        + apply prod_eq_dec.
          ** apply string_dec.
          ** apply Nat.eq_dec.
      - apply prod_eq_dec.
        + apply list_eq_dec. apply string_dec.
        + apply Expression_eq_dec.
    * apply list_eq_dec.
      apply prod_eq_dec.
      - apply sum_eq_dec.
        + apply string_dec.
        + apply prod_eq_dec.
          ** apply string_dec.
          ** apply Nat.eq_dec.
      - apply Value_eq_dec.
    * apply list_eq_dec. apply Value_eq_dec.
    * apply list_eq_dec. apply prod_eq_dec; apply Value_eq_dec.
  Defined.

  Theorem Value_eqb_refl v :
    Value_eqb v v = true.
  Proof.
    einduction v using Value_ind2.
    * simpl. auto.
    * simpl. auto. destruct l; simpl. apply eqb_refl. apply Z.eqb_refl.
    * simpl. rewrite IHv0_1, IHv0_2. auto.
    * simpl.
    (* workaround *)
    assert (True). { apply IHv0. }
    (***)
    apply Nat.eqb_refl.
    * simpl. apply IHv0.
    * simpl. apply IHv0.
    * simpl. rewrite IHv0, IHv1. auto.
    * simpl. rewrite IHv0_1, IHv0_2, IHv0_3. auto.
    * simpl. auto.
    * simpl. auto.
    * simpl. auto.
    * simpl. auto.
  Qed.

  Definition extension_eqb (ext ext' : list (nat * FunctionIdentifier * FunctionExpression)) : bool :=
  list_eqb (prod_eqb (prod_eqb Nat.eqb funid_eqb) (prod_eqb (list_eqb eqb) Expression_eqb)) ext ext'.

  Fixpoint Value_full_eqb (e1 e2 : Value) : bool :=
  match e1, e2 with
  | VNil, VNil => true
  | VLit l, VLit l' => Literal_eqb l l'
  | VClos env ext id p b, VClos env' ext' id' p' b' =>
      (((Nat.eqb id id' && Expression_eqb b b') && list_eqb (eqb) p p') &&
      (fix blist l l' := match l, l' with
                         | [], [] => true
                         | (x, v)::xs, (x', v')::xs' => andb (andb (Value_full_eqb v v')
                                                                   (var_funid_eqb x x'))
                                                             (blist xs xs')
                         | _, _ => false
                         end) env env') &&
      extension_eqb ext ext'
  | VCons hd tl, VCons hd' tl' => Value_full_eqb hd hd' && Value_full_eqb tl tl'
  | VTuple l, VTuple l' => (fix blist l l' := match l, l' with
                                             | [], [] => true
                                             | x::xs, x'::xs' => andb (Value_full_eqb x x') (blist xs xs')
                                             | _, _ => false
                                             end) l l'
  | VMap l, VMap l' => (fix blist l l' := match l, l' with
                                                   | [], [] => true
                                                   | (x,y)::xs, (x',y')::xs' => andb (Value_full_eqb x x') (andb (Value_full_eqb y y') (blist xs xs'))
                                                   | _, _ => false
                                                   end) l l'
  | _, _ => false
  end.

  Theorem funid_eqb_refl :
    forall f,
    funid_eqb f f = true.
  Proof.
    intros. destruct f.
    simpl. rewrite eqb_refl, Nat.eqb_refl. auto.
  Qed.

  Theorem funid_eqb_eq :
    forall f1 f2,
    f1 = f2
    <->
    funid_eqb f1 f2 = true.
  Proof.
    intros. destruct f1, f2.
    simpl. split; intros.
    * inversion H. subst. rewrite eqb_refl, Nat.eqb_refl. auto.
    * apply andb_prop in H. destruct H. apply Nat.eqb_eq in H0. apply eqb_eq in H.
      subst. auto.
  Qed.

  Lemma Pattern_eqb_refl p :
    Pattern_eqb p p = true.
  Proof.
    einduction p using Pattern_ind2; simpl; auto.
    * destruct l; simpl. apply eqb_refl. apply Z.eqb_refl.
    * apply eqb_refl.
    * rewrite IHp0_1, IHp0_2. auto.
    * apply IHp0.
    * apply IHp0.
    * simpl. rewrite IHp0. simpl. auto.
    * simpl. rewrite IHp0_1, IHp0_2. auto.
    * simpl. auto.
    * simpl. auto.
  Qed.

  Lemma Pattern_list_eqb_refl pl :
  (fix blist (l0 l' : list Pattern) {struct l0} : bool :=
    match l0 with
    | [] => match l' with
            | [] => true
            | _ :: _ => false
            end
    | x :: xs =>
        match l' with
        | [] => false
        | x' :: xs' => andb (Pattern_eqb x x') (blist xs xs')
        end
    end) pl pl = true.
  Proof.
    induction pl.
    * auto.
    * simpl. rewrite Pattern_eqb_refl, IHpl. auto.
  Qed.

  Theorem Expression_eqb_refl e :
    Expression_eqb e e = true.
  Proof.
    einduction e using Expression_ind2.
    * apply IHe0.
    * simpl. auto.
    * simpl. destruct l; simpl. apply eqb_refl. apply Z.eqb_refl.
    * simpl. apply eqb_refl.
    * simpl. apply funid_eqb_refl.
    * simpl. rewrite IHe0. rewrite list_eqb_refl. auto. intros. apply eqb_refl.
    * simpl. rewrite IHe0_1, IHe0_2. auto.
    * apply IHe0.
    * simpl in IHe0_3.  simpl. rewrite IHe0_1. rewrite IHe0_2. simpl. auto.
    * simpl in IHe0. simpl. rewrite eqb_refl.  simpl. auto.
    * simpl in *. rewrite IHe0, IHe1. auto.
    * simpl. rewrite IHe0, Nat.eqb_refl. simpl. apply IHe1.
    * simpl. rewrite IHe0_1, IHe0_2. rewrite list_eqb_refl. auto. apply eqb_refl.
    * simpl. rewrite IHe0_1, IHe0_2. auto.
    * simpl. rewrite IHe1. simpl. apply IHe0.
    * simpl. apply IHe0.
    * simpl. rewrite IHe0_1, IHe0_2, IHe0_3. rewrite list_eqb_refl, list_eqb_refl. auto.
      apply eqb_refl. apply eqb_refl.
    * simpl. auto.
    * simpl. auto.
    * simpl. auto.
    * simpl. auto.
    * simpl. rewrite IHe0. simpl in *. auto.
    * simpl in *. rewrite IHe0, IHe1. auto.
    * simpl in *. rewrite IHe0_1, IHe0_2, IHe0_3. auto.
    * simpl in *. rewrite IHe0_1, IHe0_2, IHe0_3. rewrite Pattern_list_eqb_refl. auto.
    * simpl in *. rewrite IHe0. simpl. rewrite Bool.andb_true_r in *.
      rewrite funid_eqb_refl, IHe1. simpl. rewrite Bool.andb_true_r.
      rewrite list_eqb_refl. auto. apply eqb_refl.
  Qed.

  Theorem extension_eqb_refl ext :
    extension_eqb ext ext = true.
  Proof.
    apply list_eqb_refl. intros.
    apply prod_eqb_refl.
    * intros. apply prod_eqb_refl.
      - apply Nat.eqb_refl.
      - intros. apply prod_eqb_refl. apply eqb_refl. apply Nat.eqb_refl.
    * intros. apply prod_eqb_refl.
      - intros. apply list_eqb_refl. apply eqb_refl.
      - intros. apply Expression_eqb_refl.
  Qed.

  Theorem Value_full_eqb_refl v :
    Value_full_eqb v v = true.
  Proof.
    einduction v using Value_ind2.
    * simpl. auto.
    * simpl. auto. destruct l; simpl. apply eqb_refl. apply Z.eqb_refl.
    * simpl. rewrite IHv0_1, IHv0_2. auto.
    * simpl. pose (P := Nat.eq_refl id). rewrite <- Nat.eqb_eq in P. rewrite P. simpl.
      rewrite Expression_eqb_refl. simpl.
      rewrite list_eqb_refl. simpl. 2: intros; rewrite eqb_eq; apply eq_refl.
      rewrite extension_eqb_refl. simpl.
      apply IHv0.
    * simpl. apply IHv0.
    * simpl. apply IHv0.
    * simpl. rewrite IHv0, IHv1. auto.
    * simpl. rewrite IHv0_1, IHv0_2, IHv0_3. auto.
    * simpl. auto.
    * simpl. auto.
    * simpl. auto.
    * simpl. rewrite IHv0. simpl.
      rewrite var_funid_eqb_refl. simpl. auto.
  Qed.

  Theorem Pattern_eqb_eq p1 p2:
    p1 = p2
  <->
    Pattern_eqb p1 p2 = true.
  Proof.
    split.
    * intros. subst. apply Pattern_eqb_refl.
    * generalize dependent p2. einduction p1 using Pattern_ind2 with
       (Q := fun l => forall l0, (fix blist_eq (l l' : list Pattern) {struct l} : bool :=
        match l with
        | [] => match l' with
                | [] => true
                | _ :: _ => false
                end
        | x :: xs =>
            match l' with
            | [] => false
            | x' :: xs' => (Pattern_eqb x x' && blist_eq xs xs')%bool
            end
        end) l l0 = true -> l = l0)
       (R := fun l => forall l0, (fix blist_eq (l l' : list (Pattern * Pattern)) {struct l} : bool :=
        match l with
        | [] => match l' with
                | [] => true
                | _ :: _ => false
                end
        | (x, y) :: xs =>
            match l' with
            | [] => false
            | (x', y') :: xs' =>
                (Pattern_eqb x x' && Pattern_eqb y y' && blist_eq xs xs')%bool
            end
        end) l l0 = true -> l = l0).
      - intros. destruct p2; inversion H. auto.
      - intros. destruct p2; inversion H. destruct l, l0; inversion H1.
        apply eqb_eq in H2. subst. auto.
        apply Z.eqb_eq in H2. subst. auto.
      - intros. destruct p2; inversion H. apply eqb_eq in H1. subst. auto.
      - intros. destruct p0; inversion H. apply andb_prop in H1. destruct H1.
        rewrite (IHp1 _ H0), (IHp2 _ H1). auto.
      - intros. destruct p2; inversion H. apply IHp in H1. subst. auto.
      - intros. destruct p2; inversion H. apply IHp in H1. subst. auto.
      - intros. destruct l0. inversion H.
        apply andb_prop in H. destruct H. apply IHp in H. apply IHp0 in H0.
        subst. auto.
      - intros. destruct l0. inversion H. destruct p.
        apply andb_prop in H. destruct H.
        apply andb_prop in H. destruct H. apply IHp1 in H. apply IHp2 in H1.
        apply IHp3 in H0. subst. auto.
      - intros. simpl. destruct l0; inversion H. auto.
      - intros. simpl. destruct l0; inversion H. auto.
  Qed.

  Lemma Pattern_list_eqb_eq pl l1:
     pl = l1
   <->
    (fix blist0 (l0 l'0 : list Pattern) {struct l0} : bool :=
        match l0 with
        | [] => match l'0 with
                | [] => true
                | _ :: _ => false
                end
        | x :: xs0 =>
            match l'0 with
            | [] => false
            | x' :: xs'0 => (Pattern_eqb x x' && blist0 xs0 xs'0)%bool
            end
        end) pl l1 = true.
   Proof.
     split.
     * intros. subst. apply Pattern_list_eqb_refl.
     * simpl. generalize dependent l1. induction pl.
       - intros. destruct l1; inversion H. auto.
       - intros. destruct l1. inversion H.
         apply andb_prop in H. destruct H. apply Pattern_eqb_eq in H.
         apply IHpl in H0. subst. auto.
  Qed.

  Theorem Expression_eqb_eq :
    forall e1 e2,
    e1 = e2
  <->
    Expression_eqb e1 e2 = true.
  Proof.
    split.
    * intros. subst. apply Expression_eqb_refl.
    * generalize dependent e2. einduction e1 using Expression_ind2 with
       (Q := fun l => forall l0, (fix blist (l l' : list Expression) {struct l} : bool :=
        match l with
        | [] => match l' with
                | [] => true
                | _ :: _ => false
                end
        | x :: xs =>
            match l' with
            | [] => false
            | x' :: xs' => (Expression_eqb x x' && blist xs xs')%bool
            end
        end) l l0 = true -> l = l0)
       (W := fun l => forall l0, (fix blist (l l' : list (list Pattern * Expression * Expression)) {struct l} : bool :=
        match l with
        | [] => match l' with
                | [] => true
                | _ :: _ => false
                end
        | (pl, y, z) :: xs =>
            match l' with
            | [] => false
            | (pl', y', z') :: xs' =>
                ((fix blist0 (l0 l'0 : list Pattern) {struct l0} : bool :=
                    match l0 with
                    | [] => match l'0 with
                            | [] => true
                            | _ :: _ => false
                            end
                    | x :: xs0 =>
                        match l'0 with
                        | [] => false
                        | x' :: xs'0 => Pattern_eqb x x' && blist0 xs0 xs'0
                        end
                    end) pl pl' &&
                 (Expression_eqb y y' && (Expression_eqb z z' && blist xs xs')))%bool
            end
        end) l l0 = true -> l = l0)
       (Z := fun l => forall l0, (fix blist (l l' : list (FunctionIdentifier * (list string * Expression))) {struct l} :
          bool :=
        match l with
        | [] => match l' with
                | [] => true
                | _ :: _ => false
                end
        | (x, (y, z)) :: xs =>
            match l' with
            | [] => false
            | (x', (y', z')) :: xs' =>
                (funid_eqb x x' &&
                 (list_eqb eqb y y' && (Expression_eqb z z' && blist xs xs')))%bool
            end
        end) l l0 = true -> l = l0)
       (R := fun l => forall l0, (fix blist (l l' : list (Expression * Expression)) {struct l} : bool :=
        match l with
        | [] => match l' with
                | [] => true
                | _ :: _ => false
                end
        | (x, y) :: xs =>
            match l' with
            | [] => false
            | (x', y') :: xs' =>
                (Expression_eqb x x' && (Expression_eqb y y' && blist xs xs'))%bool
            end
        end) l l0 = true -> l = l0)
        .
      - simpl. intros. destruct e2; try destruct e; try inversion H.
        apply IHe in H. subst. auto.
      - simpl. intros. destruct e2; try destruct e; try inversion H. auto.
      - simpl. intros. destruct e2; try destruct e; try inversion H. auto.
        destruct l, l0; try inversion H. rewrite eqb_eq in H2. subst. auto.
        rewrite Z.eqb_eq in H2. subst. auto.
      - simpl. intros. destruct e2; try destruct e; try inversion H. auto.
        rewrite eqb_eq in H. subst. auto.
      - simpl. intros. destruct e2; try destruct e; try inversion H. auto.
        rewrite <- funid_eqb_eq in H. subst. auto.
      - simpl. intros. destruct e2; try destruct e0; try inversion H.
        apply andb_prop in H. destruct H. apply list_eqb_eq in H.
        apply IHe in H0. subst. auto. intros; split; apply eqb_eq.
      - simpl. intros. destruct e0; try destruct e; try inversion H.
        apply andb_prop in H. destruct H.
        pose (IHe1 _ H). pose (IHe2 _ H0). rewrite e, e0. auto.
      - simpl. intros. destruct e2; try destruct e; inversion H.
        apply IHe in H1. subst. auto.
      - simpl. intros. destruct e0; try destruct e; inversion H.
      apply andb_prop in H1. destruct H1. apply IHe3 in H1.
      apply andb_prop in H0. destruct H0.
      apply IHe2 in H0. apply IHe1 in H2. subst. auto.

      (*simpl. intros. destruct e2; try destruct e; inversion H.
        apply andb_prop in H1.  destruct H1. apply andb_prop in H0. destruct H0.
        apply eqb_eq in H0. apply eqb_eq in H2.
        apply IHe in H1. subst. auto.*)
      - simpl. intros. destruct e2; try destruct e; inversion H.
        apply andb_prop in H1.  destruct H1.
        apply eqb_eq in H0.
        apply IHe in H1. subst. auto.
      - simpl. intros. destruct e2; try destruct e0; inversion H.
        apply andb_prop in H1. destruct H1. apply IHe0 in H1. apply IHe in H0. subst. auto.
      - simpl. intros. destruct e2; try destruct e0; inversion H.
        apply andb_prop in H. destruct H.
        apply andb_prop in H. destruct H.
        apply IHe in H. apply IHe0 in H0. subst. auto.
      - simpl. intros. destruct e0; try destruct e; inversion H.
        apply andb_prop in H. destruct H.
        apply andb_prop in H. destruct H. apply IHe1 in H2. apply IHe2 in H0.
        apply list_eqb_eq in H. subst. auto. intros; split; apply eqb_eq.
      - simpl. intros. destruct e0; try destruct e; inversion H.
        apply andb_prop in H. destruct H.
        apply IHe1 in H. apply IHe2 in H0.
        subst. auto.
      - simpl. intros. destruct e2; try destruct e0; inversion H.
        apply andb_prop in H1. destruct H1. apply IHe0 in H1. apply IHe in H0. subst. auto.
      - simpl. intros. destruct e2; try destruct e; inversion H.
        apply IHe in H1. subst. auto.
      - simpl. intros. destruct e0; try destruct e; inversion H.
        apply andb_prop in H1. destruct H1.
        apply andb_prop in H0. destruct H0.
        apply andb_prop in H0. destruct H0.
        apply andb_prop in H0. destruct H0.
        apply IHe1 in H3. apply IHe2 in H2. apply IHe3 in H1.
        apply list_eqb_eq in H0. apply list_eqb_eq in H4. subst. auto.
        all: intros; split; apply eqb_eq.
      - intros. destruct l0; inversion H. auto.
      - intros. destruct l0; inversion H. auto.
      - intros. destruct l0; inversion H. auto.
      - intros. destruct l0; inversion H. auto.
      (* - intros. destruct el; inversion H. auto. *)
     (*  - intros. destruct l0; inversion H. apply andb_prop in H1.
        destruct H1. simpl in IHe. pose (IHe (ESingle s) H0). inversion e0.
        apply IHe0 in H1. subst. auto. *)
      - intros. destruct l0; inversion H. apply andb_prop in H1.
        destruct H1. apply IHe in H0. apply IHe0 in H1. subst. auto.
      - intros. destruct l0; inversion H. apply andb_prop in H1.
        destruct H1. apply IHe in H0. apply IHe0 in H1. subst. auto.
      - intros. destruct l0; inversion H. destruct p. apply andb_prop in H1.
        destruct H1.
        apply andb_prop in H1.
        destruct H1. apply IHe1 in H0. apply IHe2 in H1. apply IHe3 in H2. subst. auto.
      - intros. destruct l0; inversion H. destruct p, p.
        apply andb_prop in H1. destruct H1.
        apply andb_prop in H1. destruct H1.
        apply andb_prop in H2. destruct H2.
        apply IHe1 in H1. apply IHe2 in H2. apply IHe3 in H3.
        apply Pattern_list_eqb_eq in H0. subst. auto.
      - intros. destruct l0. inversion H. destruct p, p.
        apply andb_prop in H. destruct H.
        apply andb_prop in H0. destruct H0.
        apply andb_prop in H1. destruct H1.
        apply funid_eqb_eq in H. apply list_eqb_eq in H0. 2: intros; split; apply eqb_eq.
        apply IHe in H1. apply IHe0 in H2.
        subst. auto.
  Qed.

  Theorem extension_eqb_eq :
    forall e1 e2,
    e1 = e2
  <->
    extension_eqb e1 e2 = true.
  Proof.
    split.
    * intros. subst. apply extension_eqb_refl.
    * generalize dependent e2. induction e1; intros.
      - destruct e2; try inversion H. clear H. auto.
      - destruct e2; try inversion H. clear H.
        apply list_eqb_eq in H1. auto.
        intros. split; intros.
        + subst. apply prod_eqb_refl.
          ** intros. apply prod_eqb_refl; intros. apply Nat.eqb_refl. apply funid_eqb_refl.
          ** intros. apply prod_eqb_refl; intros.
             apply list_eqb_refl. intros. apply eqb_refl.
             apply Expression_eqb_refl.
        + apply prod_eqb_eq in H0.
          ** auto.
          ** intros. split; intros.
             -- subst. apply prod_eqb_refl; intros. apply Nat.eqb_refl. apply funid_eqb_refl.
             -- apply prod_eqb_eq in H3. auto. intros. split; apply Nat.eqb_eq.
                split; apply funid_eqb_eq.
          ** intros. split; intros.
             -- subst. apply prod_eqb_refl; intros.
                apply list_eqb_refl. intros. apply eqb_refl.
                apply Expression_eqb_refl.
             -- apply prod_eqb_eq in H3. auto.
                intros. split; intros. subst. apply list_eqb_refl. apply eqb_refl.
                apply list_eqb_eq in H5. auto.
                split; apply eqb_eq.
                split; apply Expression_eqb_eq.
  Qed.

  Theorem Value_full_eqb_eq :
    forall v1 v2,
    v1 = v2
  <->
    Value_full_eqb v1 v2 = true.
  Proof.
    split.
    * intros. rewrite H. apply Value_full_eqb_refl.
    * generalize dependent v2. induction v1 using Value_ind2 with (W :=
        fun ref => forall env, (fix blist (l l' : list ((Var + FunctionIdentifier) * Value)) {struct l} : bool :=
        match l with
        | [] => match l' with
                | [] => true
                | _ :: _ => false
                end
        | (x, v) :: xs =>
            match l' with
            | [] => false
            | (x', v') :: xs' =>
                (Value_full_eqb v v' && var_funid_eqb x x' && blist xs xs')%bool
            end
        end) ref env = true -> ref = env)
        (Q := fun l => forall vl, (fix blist (l l' : list Value) {struct l} : bool :=
        match l with
        | [] => match l' with
                | [] => true
                | _ :: _ => false
                end
        | x :: xs =>
            match l' with
            | [] => false
            | x' :: xs' => (Value_full_eqb x x' && blist xs xs')%bool
            end
        end) l vl = true -> l = vl)
        (R := fun l => forall l0, (fix blist (l l' : list (Value * Value)) {struct l} : bool :=
        match l with
        | [] => match l' with
                | [] => true
                | _ :: _ => false
                end
        | (x, y) :: xs =>
            match l' with
            | [] => false
            | (x', y') :: xs' =>
                (Value_full_eqb x x' && (Value_full_eqb y y' && blist xs xs'))%bool
            end
        end) l l0 = true -> l = l0); intros.
      - destruct v2; try inversion H. auto.
      - destruct v2; try inversion H. destruct l, l0; try inversion H1.
        + rewrite eqb_eq in H2. subst. auto.
        + rewrite Z.eqb_eq in H2. subst. auto.
      - destruct v2; try inversion H.
        apply andb_prop in H1. destruct H1.
        apply IHv1_1 in H0. apply IHv1_2 in H1. subst. auto.
      - destruct v2; try inversion H. clear H.
        apply andb_prop in H1. destruct H1.
        apply andb_prop in H. destruct H.
        apply andb_prop in H. destruct H.
        apply andb_prop in H. destruct H.
        apply extension_eqb_eq in H0.
        apply Expression_eqb_eq in H3.
        apply Nat.eqb_eq in H.
        apply list_eqb_eq in H2.
        2: { intros. split; intros. subst. apply eqb_refl. apply eqb_eq. auto. }
        apply IHv1 in H1. subst. auto.
      - destruct v2; try inversion H. clear H.
        apply IHv1 in H1. subst. auto.
      - destruct v2; try inversion H. clear H.
        apply IHv1 in H1. subst. auto.
      - destruct vl; try inversion H. clear H.
        apply andb_prop in H1. destruct H1.
        apply IHv1 in H. subst. pose (IHv0 vl H0). rewrite e. auto.
      - destruct l0; try inversion H. clear H. destruct p.
        apply andb_prop in H1. destruct H1.
        apply andb_prop in H0. destruct H0.
        apply IHv1_1 in H.
        apply IHv1_2 in H0.
        pose (IHv1_3 _ H1). rewrite H, H0, e. auto.
      - destruct vl; try inversion H. auto.
      - destruct l0; try inversion H. auto.
      - destruct env; try inversion H. auto.
      - destruct env; try inversion H. clear H. destruct p.
        apply andb_prop in H1. destruct H1.
        apply andb_prop in H. destruct H.
        apply IHv1 in H. apply var_funid_eqb_eq in H1.
        pose (IHv0 _ H0). rewrite H, H1, e. auto.
  Qed.

  Proposition value_full_list_eqb_eq :
    forall l1 l2,
    l1 = l2
  <->
    list_eqb Value_full_eqb l1 l2 = true.
  Proof.
    split.
    * intros. subst. apply list_eqb_refl. apply Value_full_eqb_refl.
    * generalize dependent l2. induction l1; intros.
      - simpl in H. destruct l2; auto. congruence.
      - simpl in H. destruct l2. congruence. apply andb_prop in H. destruct H.
        pose (IHl1 l2 H0). rewrite e. apply Value_full_eqb_eq in H. rewrite H. auto.
  Qed.

End Equalities.

Section Comparisons.
  (** Ordering on values *)
  Import Structures.OrderedTypeEx.String_as_OT.

  Inductive lt_Literal : Literal -> Literal -> Prop :=
  | lt_atom_int z a : lt_Literal (Integer z) (Atom a)
  | lt_atom_atom (a:string) (a':string) : lt a a' -> lt_Literal (Atom a) (Atom a')
  | lt_int_int (z : Z) (z' : Z) : Z.lt z z' -> lt_Literal (Integer z) (Integer z')
  .

  Lemma lt_5 : lt_Literal (Integer 5) (Integer 7).
  Proof.
    apply lt_int_int. lia.
  Qed.

  Lemma lt_str : lt_Literal (Atom "aaaa") (Atom "aaaa2").
  Proof.
    apply lt_atom_atom. apply lts_tail. apply lts_tail. apply lts_tail. apply lts_tail. apply lts_empty.
  Qed.

(* TODO: Major adjustment needed here ****

  Inductive lt_Value : Value -> Value -> Prop :=
  | lt_lit_lit l l' : lt_Literal l l' -> lt_Value (VLit l) (VLit l')
  | lt_lit_other l v : (forall l' : Literal, v <> VLit l') -> lt_Value (VLit l) (v)

  | lt_closure_closure ref params body ref' ext ext' params' body' n n' :
     Nat.lt n n' ->
     lt_Value (VClos ref ext n params body) (VClos ref' ext' n' params' body')
  | lt_closure_other v ref ext id body params: (forall ref' ext' id' params' body', v <> VClos ref' ext' id' params' body') -> (forall l : Literal, v <> VLit l) -> lt_Value (VClos ref ext id params body) (v)
  | lt_tuple_tuple_nil exps' : exps' <> [] -> lt_Value (VTuple [])  (VTuple exps')
  | lt_tuple_length exps exps' : length exps < length exps' -> lt_Value (VTuple exps) (VTuple exps')
  | lt_tuple_tuple_hd exps exps' hd hd' : length exps = length exps' -> lt_Value hd hd' -> lt_Value (VTuple (hd::exps)) (VTuple (hd'::exps'))
  | lt_tuple_tuple_tl exps exps' hd hd' : length exps = length exps' -> hd = hd' -> lt_Value (VTuple exps) (VTuple exps') -> lt_Value (VTuple (hd::exps)) (VTuple (hd'::exps'))
  | lt_tuple_map (l : list Value) (ml : list (Value * Value)): lt_Value (VTuple l) (VMap ml)
  | lt_tuple_list l hd tl: lt_Value (VTuple l) (VCons hd tl)
  | lt_tuple_emptylist l: lt_Value (VTuple l) (VNil)
  | lt_map_map_nil l' : l' <> [] -> lt_Value (VMap []) (VMap l')
  | lt_map_length l l' : length l < length l' -> lt_Value (VMap l) (VMap l')
  | lt_map_map_hd (l l' : list (Value*Value)) hd hd' hdv hdv':
    length l = length l' -> lt_Value hd hd' -> lt_Value (VMap ((hd, hdv)::l)) (VMap ((hd', hdv')::l'))
  | lt_map_map_vl (l l' : list (Value*Value)) hd hd' hdv hdv':
    length l = length l' -> lt_Value (VMap l) (VMap l') -> lt_Value (VMap ((hd, hdv)::l)) (VMap ((hd', hdv')::l'))
 (* TODO: extension needed for values, if all keys are equal *)
  | lt_map_emptylist l : lt_Value (VMap l) VNil
  | lt_map_list l hd tl : lt_Value (VMap l) (VCons hd tl)
  | lt_emptylist_list hd tl : lt_Value VNil (VCons hd tl)
  | lt_list_list_head hd hd' tl tl': lt_Value hd hd' -> lt_Value (VCons hd tl) (VCons hd' tl')
  | lt_lis_list_tail hd hd' tl tl': hd = hd' -> lt_Value tl tl' -> lt_Value (VCons hd tl) (VCons hd' tl')
  . *)

(*   Example e1 : lt_Value (VTuple []) (VNil).
  Proof.
    apply lt_tuple_emptylist.
  Qed.

  Example e2 : lt_Value (VTuple []) (VTuple [VNil]).
  Proof.
    apply lt_tuple_tuple_nil. congruence.
  Qed.

  Example e3 : lt_Value (VMap [(VLit (Integer 5), VNil)]) (VMap [(VNil, VNil)]).
  Proof.
    apply lt_map_map_hd; auto. apply lt_lit_other. intros. congruence.
  Qed. *)

  (** Boolean comparison: *)

  Import Coq.Strings.Ascii.

  Definition string_ltb (s1 s2 : string) : bool :=
  match cmp s1 s2 with
  | Lt => true
  | _ => false
  end.

  Definition literal_ltb (l1 l2 : Literal) : bool :=
  match l1, l2 with
  | Integer x, Integer x' => Z.ltb x x'
  | Atom s, Atom s' => string_ltb s s'
  | Integer x, Atom s => true
  | _, _ => false
  end.

  Section bool_list_ltb.
  Variable A : Type.
  Hypothesis less : A -> A -> bool.
  Hypothesis eq : A -> A -> bool.

  Fixpoint list_less (a b : list A) : bool :=
  match a, b with
  | [], [] => false
  | x::xs, [] => false
  | [], y::ys => true
  | x::xs, y::ys => if eq x y then list_less xs ys else less x y
  end.

  Fixpoint list_equal (a b : list A) : bool :=
  match a, b with
  | [], [] => true
  | x::xs, [] => false
  | [], y::ys => false
  | x::xs, y::ys => if eq x y then list_equal xs ys else false
  end.

  End bool_list_ltb.

  (** TODO: investigate, but now, we dont compare value sequences, only single values *)
  Fixpoint Value_ltb (k v : Value) : bool :=
  match k, v with
  | VLit l, VLit l' => literal_ltb l l'
  | VLit _, _ => true
  | VClos _ _ id _ _, VClos _ _ id' _ _ => Nat.ltb id id'
  | VClos _ _ _ _ _, VTuple _ => true
  | VClos _ _ _ _ _, VMap _ => true
  | VClos _ _ _ _ _, VNil => true
  | VClos _ _ _ _ _, VCons _ _ => true
  | VTuple l, VTuple l' => orb (Nat.ltb (length l) (length l')) (andb (Nat.eqb (length l) (length l')) (list_less Value Value_eqb Value_ltb l l'))
  | VTuple _, VNil => true
  | VTuple _, VMap _ => true
  | VTuple l, VCons _ _ => true
  | VMap l, VMap l' => orb (Nat.ltb (length l) (length l')) (andb (Nat.eqb (length l) (length l'))
                       (orb ((fix list_less (l l' : list (Value * Value)) :=
                          match l, l' with
                          | [], [] => false
                          | (x,y)::xs, [] => false
                          | [], (x',y')::ys => true
                          | (x,y)::xs, (x',y')::ys =>
                                  if Value_eqb x x' then list_less xs ys else Value_ltb x x'
                          end) l l')
                          (andb
                          (list_equal Value Value_eqb (map fst l) (map fst l'))

                          ((fix list_less (l l' : list (Value * Value)) :=
                          match l, l' with
                          | [], [] => false
                          | (x,y)::xs, [] => false
                          | [], (x',y')::ys => true
                          | (x,y)::xs, (x',y')::ys =>
                                  if Value_eqb y y' then list_less xs ys else Value_ltb y y'
                          end) l l'))))
  | VMap _, VNil => true
  | VMap _, VCons _ _ => true
  | VNil, VCons _ _ => true
  | VCons hd tl, VCons hd' tl' => if Value_eqb hd hd' then Value_ltb tl tl' else Value_ltb hd hd'
  | _, _ => false
  end.

End Comparisons.

Import Syntax.ValueNotations.

Goal Value_ltb (VMap [(ErrorValue, ErrorValue); (VLit (Integer 8), VLit (Integer 7))])
                   (VMap [(ErrorValue, ErrorValue); (VLit (Integer 7), VLit (Integer 6))]) = false. Proof. reflexivity. Qed.
Goal Value_ltb (VMap [(ErrorValue, ErrorValue); (ErrorValue, VLit (Integer 7))])
                   (VMap [(ErrorValue, ErrorValue); (ErrorValue, VLit (Integer 8))]) = true. Proof. reflexivity. Qed.