Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^384 - 5*2^368 - 1
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 12%nat;
    base := 32;
    bitwidth := 32;
    s := 2^384;
    c := [(1, 1); (5, 2^368)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Fiat.QueryStructure.Specification.Representation.QueryStructureNotations.
Require Import Fiat.QueryStructure.Implementation.ListImplementation.
Require Import ComputationalADT AddCache ADTCache CacheADT.

Definition MySchema :=
  Query Structure Schema
    [ relation "Person" has
          schema <"Age" :: nat,
                  "Name" :: string>;
      relation "Dog" has
          schema <"Owner" :: string,
                  "Name" :: string,
                  "Breed" :: string> ]
    enforcing [].

Definition Person := TupleDef MySchema "Person".
Definition Dog := TupleDef MySchema "Dog".

Definition MySig : ADTSig :=
  ADTsignature {
      "Empty" : unit → rep,
      "AddDog" : rep × Dog → rep × bool,
      "YoungOwners'Breeds" : rep × nat → rep × list string,
      "BreedPopulation" : rep × string → rep × nat
  }.

Definition MySpec : ADT MySig :=
  Def ADT {
    rep := QueryStructure MySchema,

   const "Empty" (_ : unit) : rep := empty,,

   update "AddDog" (dog : Dog) : bool :=
      Insert dog into "Dog",

    query "YoungOwners'Breeds" ( ageLimit : nat ) : list string :=
      For (d in "Dog")
          (o in "Person")
          Where (ageLimit > o!"Age")
          Where (d!"Name" = o!"Name")
          Return (d!"Breed"),

    query "BreedPopulation" ( breed : string ) : nat :=
        Count (For (d in "Dog")
                   Where (d!"Breed" = breed)
                   Return ())
}.

Section CachingRefinement.

  Definition CacheSpec := @CacheSpec string nat.
  Variable LRUCache : Sharpened CacheSpec.
  Definition PopCache := projT1 LRUCache.
  Definition PopCacheAbs : Rep CacheSpec -> Rep PopCache -> Prop :=
    AbsR (projT2 LRUCache).
  (* Definition PopCacheComp := snd (projT2 LRUCache). *)

  (* Definition EmptyCache := CallConstructor PopCacheComp "EmptyCache" ().
  Definition InsertKey r i := CallMethod PopCacheComp "AddKey" r i.
  Definition LookupKey r i := CallMethod PopCacheComp "LookupKey" r i.
  Definition UpdateKey r i := CallMethod PopCacheComp "UpdateKey" r i. *)

  Definition BreedCacheSpec
             (or : UnConstrQueryStructure MySchema)
             (cache : Rep CacheSpec) :=
    forall breed pop,
      cache (breed,  pop)
      -> refine
           (Count (For (UnConstrQuery_In or ``("Dog")
                                         (fun d =>
                                            Where (d!"Breed" = breed)
                                                  Return ()))))
           (ret pop).

  Definition MyListImpl_abs
             (or : cachedRep (UnConstrQueryStructure MySchema) (Rep CacheSpec))
             (nr : (list Person * list Dog) * (Rep PopCache)) : Prop :=
    ((origRep or) ! "Person" ≃ fst (fst nr) /\
     (origRep or) ! "Dog" ≃ snd (fst nr)) /\
    PopCacheAbs (cachedVal or) (snd nr).

  Definition My :
    Sharpened MySpec.
  Proof.
    unfold MySpec.

    start honing QueryStructure.

    hone representation using (cachedRep_AbsR BreedCacheSpec).

    hone method "YoungOwners'Breeds".
    { simplify with monad laws.
      setoid_rewrite (refine_pick_val _ H0).
      simplify with monad laws.
      unfold cachedRep_AbsR in H0; intuition; subst; simpl.
      finish honing.
    }

    hone method "BreedPopulation".
    { simplify with monad laws.
      etransitivity.
      apply refine_Pick_If_Then_Opt with (P := fun v => cachedVal r_n (n, v)); intros.
      { destruct H0; subst; unfold BreedCacheSpec in *|- .
        subst_strings.
        apply H2 in H1.
        rewrite H1.
        simplify with monad laws; cbv beta; simpl.
        refine pick val _; try split; eauto.
        simplify with monad laws.
        finish honing.
      }
      {
        unfold cachedRep_AbsR in *|-; simpl; split_and; subst.
        rewrite refine_under_bind; [reflexivity | ].
        intros; rewrite refine_pick_cachedRep.
        simplify with monad laws.
        assert (refine {cv | BreedCacheSpec (origRep r_n) cv}
                       (c <- (callMeth CacheSpec "AddKey" (cachedVal r_n) (n, a));
                        ret (fst c))).
        repeat econstructor.
        inversion_by computes_to_inv; subst.
        unfold BreedCacheSpec; intros.
        unfold SubEnsembleInsert in H1.
        intros H7; pose proof (H1 _ H3).
        destruct H4; injections.
        unfold refine; intros; inversion_by computes_to_inv; subst; eauto.
        apply H2; eauto.
        rewrite H1.
        simplify with monad laws.
        finish honing.
      }
      finish honing.
    }

    hone constructor "Empty".
    { simplify with monad laws.
      rewrite refine_pick_cachedRep.
      refine pick val (fun _ : string * nat => False).
      simplify with monad laws; finish honing.
      unfold BreedCacheSpec; simpl.
      intuition.
    }

    hone method "AddDog".
    {
      simplify with monad laws; cbv beta; simpl.
      etransitivity.
      eapply refine_bind_pick; intros.
      rewrite refine_pick_cachedRep.
      simplify with monad laws.
      assert (refine {cv |
                      BreedCacheSpec
                        (UpdateUnConstrRelation or ``(StringId7)
                                                (InsertQSSpecs.EnsembleInsert
                                                   {| tupleIndex := a; indexedTuple := n |}
                                                   (or!StringId7)%QueryImpl)) cv}
                     (r' <- callMeth CacheSpec "UpdateKey" (cachedVal r_n) (n!"Breed", S);
                      ret (fst r'))).
      repeat econstructor.
      inversion_by computes_to_inv; subst.
      unfold BreedCacheSpec; intros.
      simpl; pose_string_ids.
      etransitivity.
      apply refine_refine_Count.
      apply refine_For_In_Insert.
      unfold In, not; intros; eapply H1;
      [ eapply H4
      | subst_body; auto ].
      rewrite refine_Count_bind_bind_app.
      unfold cachedRep_AbsR, BreedCacheSpec in H0; split_and; subst.
      pose_string_ids.
      pose (n!"Breed"); simpl in *.
      etransitivity.
      apply refine_if with (b := if (string_dec d breed)
                                 then true
                                 else false);
        find_if_inside; try discriminate; subst; intros.
      { setoid_rewrite refine_Count at 1; simplify with monad laws;
        unfold Query_Where; refine pick val [()];
        [ | intuition; econstructor].
        simplify with monad laws.
        apply H2 in H3; unfold In in *.
        subst_strings.
        destruct H3; split_and.
        destruct_ex; split_and; subst.
        rewrite (H6 _ _ H8).
        simplify with monad laws; simpl; reflexivity.
        unfold EnsembleRemove in H3; simpl in H3; exfalso; eapply H3;
        reflexivity.
      }
      {
        setoid_rewrite refine_Count at 1; simplify with monad laws;
        unfold Query_Where; refine pick val [];
        [ | intuition; econstructor].
        simplify with monad laws.
        apply H2 in H3; unfold In in *.
        subst_strings.
        destruct H3; split_and; try congruence.
        destruct H3; rewrite (H6 _ _ H4); reflexivity.
      }
      find_if_inside; reflexivity.
      subst_strings; setoid_rewrite H2.
      simplify with monad laws.
      higher_order_1_reflexivity.
      cbv beta.
      unfold cachedRep_AbsR in H0; intuition.
      subst.
      finish honing.
    }

    hone representation using MyListImpl_abs.
    hone constructor "Empty".
    { simplify with monad laws.
      unfold MyListImpl_abs, GetUnConstrRelation; simpl.
      rewrite refineEquiv_pick_pair_pair.
      rewrite refine_pick_val by
          apply EnsembleIndexedListEquivalence_Empty;
        simplify with monad laws.
      rewrite refine_pick_val by
          apply EnsembleIndexedListEquivalence_Empty;
        simplify with monad laws.
      (* Rewriting with the cache implementation. *)
      assert (refine {c | PopCacheAbs (fun _ : string * nat => False) c}
                     (callCons PopCache "EmptyCache" ())).
      {
        pose (ADTRefinementPreservesConstructors (projT2 LRUCache) {| bindex := "EmptyCache" |}).
        simpl in r; rewrite <- r.
        rewrite refineEquiv_bind_unit; f_equiv.
      }
      rewrite H0.
      finish honing.
    }

    hone method "YoungOwners'Breeds".
    {
      pose_string_ids.
      simplify with monad laws; simpl.
      unfold MyListImpl_abs in *; intuition.
      rewrite refine_List_Query_In by apply H3.
      subst_strings.
      rewrite refine_Join_List_Query_In by apply H0.
      pose_string_ids.
      rewrite refine_List_Query_In_Where.
      rewrite refine_List_Query_In_Where.
      rewrite refine_List_For_Query_In_Return;
        simplify with monad laws; simpl.
      refine pick pair; simplify with monad laws;
      refine pick pair; simplify with monad laws.
      simpl in *.
      refine pick val _ ; try eassumption.
      simplify with monad laws.
      refine pick val _ ; try eassumption.
      simplify with monad laws.
      refine pick val _ ; try eassumption.
      simplify with monad laws.
      finish honing.
    }

    hone method "BreedPopulation".
    { simplify with monad laws.
      pose (callMeth PopCache "LookupKey" (snd r_n) n).
      assert (refine {b | forall b' : nat, b = Some b' -> cachedVal or (n, b')}
                     (o <- callMeth PopCache "LookupKey" (snd r_n) n;
                      ret (snd o))).
      {
        pose (ADTRefinementPreservesMethods (projT2 LRUCache) {| bindex := "LookupKey" |}
                                            (cachedVal or) (snd r_n) n (proj2 H0)).
        simpl in r.
        subst_strings.
        rewrite <- r.
        unfold refine; intros; inversion_by computes_to_inv; subst.
        simpl in *.
        econstructor; intros; eapply H2; eauto.
      }
      subst_strings; setoid_rewrite H1; simplify with monad laws.
      etransitivity; [apply refine_under_bind | ]; intros.
      rewrite refine_If_Opt_Then_Else_Bind; apply refine_If_Opt_Then_Else.
      { unfold pointwise_relation; intros.
        simplify with monad laws.
        refine pick val _; simpl; eauto.
        simplify with monad laws; higher_order_1_reflexivity.
      }
      {
        unfold MyListImpl_abs in *; split_and.
        rewrite refine_Count; simplify with monad laws.
        rewrite refine_List_Query_In by eassumption.
        simpl; subst_body.
        setoid_rewrite refine_List_Query_In_Where.
        rewrite refine_List_For_Query_In_Return;
          simplify with monad laws.
        etransitivity.
        apply refine_bind; [reflexivity | unfold pointwise_relation; intros].
        refine pick pair; simplify with monad laws.
        refine pick pair; simplify with monad laws.
        rewrite refine_pick_val by eassumption.
        simplify with monad laws.
        rewrite refine_pick_val by eassumption.
        simplify with monad laws.
        higher_order_1_reflexivity.
        pose (callMeth PopCache "AddKey" (snd r_n)).
        assert (forall kv, refine
                             (or <- (callMeth CacheSpec "AddKey" (cachedVal or) kv);
                              {b | PopCacheAbs (fst or) b})
                             (nr <- c kv; ret (fst nr))).
        {
          intros;
          pose (ADTRefinementPreservesMethods (projT2 LRUCache) {| bindex := "AddKey" |}
                                              _ _ kv H4).
          unfold c; subst_strings. rewrite <- r.
          repeat rewrite refineEquiv_bind_bind.
          f_equiv; unfold pointwise_relation; intros.
          rewrite refineEquiv_bind_bind; simpl.
          setoid_rewrite refineEquiv_bind_unit; simpl.
          setoid_rewrite refineEquiv_unit_bind.
          reflexivity.
        }
        simpl in H.
        rewrite <- refineEquiv_bind_bind.
        rewrite H; simplify with monad laws.
        reflexivity.
      }
      finish honing.
    }

    hone method "AddDog".
    {
      unfold MyListImpl_abs in *; split_and.
      pose_string_ids.
      simplify with monad laws; simpl.
      rewrite refine_pick_val with (A := nat) (a := length (snd (fst r_n))).
      simplify with monad laws; simpl.
      pose_string_ids.
      etransitivity.
      apply refine_bind; [reflexivity | unfold pointwise_relation; intros].
      refine pick pair; simplify with monad laws.
      refine pick pair; simplify with monad laws.
      rewrite refine_pick_val by eassumption.
      simplify with monad laws.
      subst_strings.
      match goal with
          |- context
               [{a | EnsembleIndexedListEquivalence
                       ((@UpdateUnConstrRelation ?QSSchema ?c ?Ridx
                                                 (InsertQSSpecs.EnsembleInsert ?n (?c!?R)))!?R)%QueryImpl a}%comp] =>
          let H := fresh in
          generalize ((@ImplementListInsert_eq QSSchema
                                               {| bindex := R |}
                                               n c)) as H; intros; setoid_rewrite H
      end; try reflexivity; try eassumption.
      simplify with monad laws.
      higher_order_1_reflexivity.
      pose (callMeth PopCache "UpdateKey" (snd r_n)).
      assert (forall kv, refine
                           (or <- (callMeth CacheSpec "UpdateKey" (cachedVal or) kv);
                            {b | PopCacheAbs (fst or) b})
                           (nr <- c kv; ret (fst nr))).
      {
        intros;
        pose (ADTRefinementPreservesMethods (projT2 LRUCache) {| bindex := "UpdateKey" |}
                                            _ _ kv H2).
        unfold c; subst_strings. rewrite <- r.
        repeat rewrite refineEquiv_bind_bind.
        f_equiv; unfold pointwise_relation; intros.
        rewrite refineEquiv_bind_bind; simpl.
        setoid_rewrite refineEquiv_bind_unit; simpl.
        setoid_rewrite refineEquiv_unit_bind.
        reflexivity.
      }
      simpl in H1.
      rewrite <- refineEquiv_bind_bind.
      subst_strings.
      set (n!"Breed").
      specialize (H1 (d, S )).
      subst_body.
      rewrite H1.
      simplify with monad laws.
      finish honing.
      intros; destruct H3 as [H3 _].
      intros; eapply lt_irrefl.
      setoid_rewrite <- H4 in H3; eapply H3.
      eauto.
    }

    finish sharpening.

  Defined.

End CachingRefinement.

Check (My (BoundedStringCacheADT nat 29)).


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^384 - 2^128 - 2^96 + 2^32 - 1
Base: 38.4
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 38 + 2/5;
    bitwidth := 64;
    s := 2^384;
    c := [(1, 1); (2^32, -1); (2^96, 1); (2^128, 1)];
    carry_chains := Some [[2; 1; 9; 9]; [3; 2; 0; 4; 1; 5; 6; 7; 8; 9]; [3; 2; 0; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From MetaCoq.Template Require Import All Loader.
Require Import MirrorSolve.Utils.

Import MCMonadNotation.
Open Scope bs.

Require Import Coq.Lists.List.
Import ListNotations.

Polymorphic Definition coerce {A} (x: (option A)) :=
  match x with
  | Some v => tmReturn v
  | None => tmFail "coerce"
  end.

Definition is_prop_t (t: term) :=
  match t with
  | tSort u => Universe.is_prop u
  | _ => false
  end.

Definition is_type_t (t: term) :=
  match t with
  | tSort u => Universe.is_type_sort u
  | _ => false
  end.

Definition is_set_t (t: term) :=
  match t with
  | tSort u => Universe.is_type_sort u
  | _ => false
  end.

Definition is_fo_kind (t: term) := (is_type_t t || is_set_t t)%bool.

Polymorphic Fixpoint is_prop_prod (t: term) :=
  match t with
  | tProd _ _ b => is_prop_prod b
  | _ => is_prop_t t
  end.

Definition check_ind_params (t: mutual_inductive_body) :=
  List.fold_left
    orb
    (List.map (fun x => is_fo_kind (x.(decl_type))) t.(ind_params))
    true.

Definition fo_context := list (term * bool). (* true values are f-o types and false values are not *)

Require Import MirrorSolve.Utils.
Require Import MirrorSolve.Reflection.Core.

(* Algorithm:
    1) first check that the inductive has type
      forall (T_i : Type/Set), Type/Set
    2) then check F for first-orderness assuming T_i are first order
*)

Fixpoint strip_prod_prefix (t: term) (n: nat) : option term :=
  match n with
  | 0 => Some t
  | S n =>
    match t with
    | tProd _ _ bod => strip_prod_prefix bod n
    | _ => None
    end
  end.

Definition adjust_ind_ty (t: term) (c: context) := strip_prod_prefix t (length c).

Definition is_fo_ind_ty (ind: one_inductive_body) : bool :=
  match adjust_ind_ty ind.(ind_type) ind.(ind_indices) with
  | Some t => is_fo_kind t
  | None => false
  end.

Fixpoint make_param_prefix (ctx: fo_context) (n: nat) : fo_context :=
  match n with
  | 0 => (tRel n, true) :: ctx
  | S n' => (tRel n, true) :: make_param_prefix ctx n'
  end.

Polymorphic Fixpoint validate_fo_type (ctx: fo_context) (t: term) : option bool :=
  match t with
  | tApp f xs =>
    let inner := (let fix rec acc :=
      match acc with
      | [] => Some true
      | x :: xs' =>
        match (validate_fo_type ctx x, rec xs') with
        | (Some b, Some b') => Some (b && b')%bool
        | (_, _) => None
        end
      end in rec xs) in
    match validate_fo_type ctx f, inner with
    | Some b, Some b' => Some (b && b')%bool
    | _, _ => None
    end
  | tProd _ ty bod =>
    match validate_fo_type ctx ty with
    | Some true =>
      let ctx' := map Utils.inc_subst_var ctx in
        validate_fo_type ((tRel 0, is_fo_kind ty) :: ctx') bod
    | Some false => Some false
    | None => None
    end
  | _ => find _ _ eq_term t ctx
  end.

Definition all_bool xs := List.fold_left andb xs true.

Definition all_map {A} (f: A -> bool) xs :=
  all_bool (List.map f xs).

Fixpoint opt_seq {A} (xs : list (option A)) : option (list A) :=
  match xs with
  | [] => Some []
  | Some x :: xs' =>
    match opt_seq xs' with
    | Some xs'' => Some (x :: xs'')
    | _ => None
    end
  | None :: _ => None
  end.

Require MirrorSolve.Reflection.FM.

Polymorphic Fixpoint validate_fo_term (ctx_ty: fo_context) (ctx_term: fo_context) (t: term) : option bool :=
  match t with
  | tApp _ es =>
    let worker t :=
      match validate_fo_term ctx_ty ctx_term t with
      | Some b => Some b
      | None => validate_fo_type ctx_ty t
      end in
    match opt_seq (map worker es) with
    | Some bs' => Some (all_bool bs')
    | None => None
    end
  | _ => find _ _ eq_term t ctx_term
  end.

Polymorphic Fixpoint validate_fo_prop (ctx_ty: fo_context) (ctx_term: fo_context) (t: term) : option bool :=
  if (eq_term t FM.c_True || eq_term t FM.c_False)%bool then Some true else
  match t with
  | tApp f es =>
    if eq_term f FM.c_eq then
      match es with
      | t_ty :: tl :: tr :: _ => validate_fo_type ctx_ty t_ty
      | _ => None
      end
    else if (eq_term f FM.c_or || eq_term f FM.c_and)%bool then
      match es with
      | tl :: tr :: _ =>
        match validate_fo_prop ctx_ty ctx_term tl, validate_fo_prop ctx_ty ctx_term tl with
        | Some l, Some r => Some (l && r)%bool
        | _, _ => None
        end
      | _ => None
      end
    else if eq_term f FM.c_not then
      match es with
      | x :: _ => validate_fo_prop ctx_ty ctx_term x
      | _ => None
      end
    else
      let worker t :=
        match validate_fo_term ctx_ty ctx_term t with
        | Some b => Some b
        | None => validate_fo_type ctx_ty t
        end in
      match opt_seq (map worker es) with
      | Some bs' => Some (all_bool bs')
      | None => None
      end
  | tProd ba_name ty bod =>
    match ba_name.(binder_name) with
    | nAnon =>
      match validate_fo_prop ctx_ty ctx_term ty, validate_fo_prop ctx_ty (map Utils.inc_subst_var ctx_term) bod with
      | Some el, Some er => Some (el && er)%bool
      | _, _ => None
      end
    | nNamed _ =>
      match validate_fo_type ctx_ty ty with
      | Some b_ty =>
        let ctx_term' := (tRel 0, b_ty) :: (map Utils.inc_subst_var ctx_term) in
        validate_fo_prop ctx_ty ctx_term' bod
      | None => None
      end
    end
  | _ => None
  end.

Polymorphic Fixpoint norm_lambda (t: term) : term :=
  match t with
  | tLambda name ty bod =>
    tProd name ty (norm_lambda bod)
  | _ => t
  end.

Definition validate_fo_ind (ctx: fo_context) (ind: one_inductive_body) (parent: mutual_inductive_body) :=
  (* assume the original ind type and also the indices are valid FO-types *)
  let param_len := length parent.(ind_params) in
  let ctx' := make_param_prefix ctx param_len in
    (* validate_fo_type ctx' ind.(ind_type). *)
  match strip_prod_prefix ind.(ind_type) param_len with
  | Some t =>
    let parent_ind_ok := is_fo_kind t in
    let ctors_inner := List.map (fun ctor =>
      match strip_prod_prefix ctor.(cstr_type) param_len with
      | Some t' => validate_fo_type ctx' t'
      | None => None
      end) ind.(ind_ctors) in
    match opt_seq ctors_inner with
    | Some ctors => Some (all_bool ctors && parent_ind_ok)%bool
    | None => None
    end
  | _ => None
  end.

Polymorphic Definition run_once_type (ctx: fo_context) (t: term) : TemplateMonad (option bool) :=
  match t with
  | tInd ind _ =>
    inds <- tmQuoteInductive ind.(inductive_mind) ;;
    ind' <- coerce (nth_error inds.(ind_bodies) ind.(inductive_ind)) ;;
    if is_prop_prod (ind'.(ind_type)) then tmReturn None else
    let ctx_inner := make_param_prefix ctx (length inds.(ind_params)) in
    tmReturn (validate_fo_ind ctx_inner ind' inds)
  | _ =>
    tmReturn (validate_fo_type ctx t)
  end.

Definition builtin_names := [
      (MPfile ["BinNums"; "Numbers"; "Coq"], "Z")
    ; (MPfile ["Datatypes"; "Init"; "Coq"], "bool")
  ].

Polymorphic Definition handle_one_decl (ctx: fo_context) (g: kername * global_decl) : TemplateMonad (option fo_context) :=
  match g.2 with
  | ConstantDecl _ =>
    (* tmPrint "skipping const decl for" ;;
    x <- tmEval all g.1 ;;
    tmPrint x ;; *)
    tmReturn (Some ctx)
  | InductiveDecl mi_bod =>
    tmReturn (
    if inb _ eq_kername g.1 builtin_names then Some ((tInd (mkInd g.1 0) [], true) :: ctx)
    else
    match mi_bod.(ind_bodies) with
    | [ind'] =>
      if is_prop_prod ind'.(ind_type) then Some ctx else
      let ctx_inner := make_param_prefix ctx (length mi_bod.(ind_params)) in
        match validate_fo_ind ctx_inner ind' mi_bod with
        | Some b => Some ((tInd (mkInd g.1 0) [], b) :: ctx)
        | None => None
        end
    | _ => Some ctx
    end)
  end.

Polymorphic Definition handle_decls_worker (acc: option fo_context ) (d: kername * global_decl) : TemplateMonad (option fo_context) :=
  match acc with
  | Some acc' => handle_one_decl acc' d
  | _ => tmReturn None
  end.

Polymorphic Definition handle_all_decls (ctx: fo_context) (gs: list (kername * global_decl)) : TemplateMonad (option fo_context) :=
  foldlM handle_decls_worker (Some ctx) gs.

Polymorphic Definition get_type {A} (_: A) : TemplateMonad term :=
  tmQuote A.

Polymorphic Definition get_type_term (x: term) : TemplateMonad term :=
  x <- tmUnquote x ;;
  x <- tmEval all x.(my_projT1) ;;
  tmQuote x.

Polymorphic Fixpoint extract_vars (t: term) : list term :=
  match t with
  | tVar _ => [t]
  | tProd _ ty bod => extract_vars ty ++ extract_vars bod
  | tLambda _ ty bod => extract_vars ty ++ extract_vars bod
  | tLetIn _ ty v bod => extract_vars ty ++ extract_vars v ++ extract_vars bod
  | tApp f args =>
    extract_vars f ++ List.concat (List.map extract_vars args)
  | tProj _ x => extract_vars x
  | _ => []
  end.

Polymorphic Definition preprocess_vars (t: term) : TemplateMonad fo_context :=
  mapM (fun x => ty <- get_type_term x ;; tmReturn (x, is_fo_kind ty)) (uniq _ eq_term (extract_vars t)).

Polymorphic Definition is_fo_type (p: program) : TemplateMonad (option bool) :=
  (* tmPrint "decls:" ;;
  x <- tmEval all p.1.(declarations) ;;
  tmPrint x ;; *)
  ctx <- preprocess_vars p.2 ;;
  (* tmPrint "init ctx:" ;;
  x <- tmEval all ctx ;;
  tmPrint x ;; *)
  r <- handle_all_decls ctx (List.rev (p.1.(declarations)));;
  match r with
  | Some ctx' =>
    (* tmPrint "ctx:" ;;
    tmPrint ctx' ;;
    tmPrint "term:" ;;
    x <- tmEval all p.2 ;;
    tmPrint x ;; *)
    run_once_type ctx' p.2
  | None => tmReturn None
  end.

Polymorphic Definition quoteConstRec {A} (a: A) : TemplateMonad program :=
  x <- tmQuote a ;;
  match x with
  | tConst name _ =>
    y <- tmQuoteConstant name false ;;
    match y.(cst_body) with
    | Some t =>
      inter <- tmUnquote t ;;
      inter <- tmEval all (my_projT2 inter) ;;
      tmQuoteRec inter
    | _ =>
      tmPrint x ;;
      tmFail "opaque/undefined constant in quoteConstRec"
    end
  | _ =>
    tmPrint x ;;
    tmFail "quoteConstRec passed a non-constant input"
  end.

Polymorphic Definition is_fo_const {A} (a: A) : TemplateMonad (option bool) :=
  p <- quoteConstRec a ;;
  let t := norm_lambda p.2 in
  ctx <- preprocess_vars t ;;
  (* tmPrint "init ctx:" ;;
  x <- tmEval all ctx ;;
  tmPrint x ;; *)
  r <- handle_all_decls ctx (List.rev (p.1.(declarations))) ;;
  match r with
  | Some ctx' => tmReturn (validate_fo_prop ctx' [] t)
  | _ => tmReturn None
  end.

(* Section Foo.
Variable (X: Type).
Definition foo := forall (x: X), (fun y => y = x) = (fun z => z = x).

MetaCoq Run (
  MetaCoq.Template.TemplateMonad.Core.tmBind (is_fo_const foo)  (fun x =>
  MetaCoq.Template.TemplateMonad.Core.tmBind (MetaCoq.Template.TemplateMonad.Core.tmEval MetaCoq.Template.TemplateMonad.Common.all x) (fun x =>
  MetaCoq.Template.TemplateMonad.Core.tmPrint x
))). *)

(* Section Foo.
Variable (A: Type).
Variable (B: Type).
Variable f: A -> B.

MetaCoq Run (
  x <- tmQuote (A, B, f) ;;
  x <- preprocess_vars x ;;
  x <- tmEval all x ;;
  tmPrint x
). *)


From st.STLCmuST Require Import lang types typing.
From st.STLCmu Require Import types lang typing contexts.
From st.STLCmuST Require Import contexts.
From st.embedding Require Import types.
From st.thms Require Import back_ctx_st_sem.
From st.STLCmu Require Import boring.
From st.end_to_end Require Import embedding_STLCmu_STLCmuST.
From st.STLCmuVS Require Import lang.
From st Require Import resources.

Section back_ctx_STLCmuST_sem_STLCmuVS.

  (* Given any syntactically-typed context in STLCmuST, ⊢ₛₜ C : ([[Γ]];[[τ]]) ⇒ ([];1), *)
  Context (C : ctx)
          (Γ : list type) (pΓ : Forall Closed Γ) (τ : type) (pτ : Closed τ)
          (pC : typed_ctx C (embed <$> Γ) (embed τ) [] (embed TUnit)).

  (* we have a semantically-typed context in STLCmuVS, C_b, *)
  Definition back_ctx_STLCmuST_sem_STLCmuVS : STLCmuVS.contexts.ctx :=
    back_ctx_st_sem C.

  (* It is indeed semantically-typed of (Γ;τ) ⇒ ([];1) *)
  Lemma back_ctx_STLCmuST_sem_STLCmuVS_typed :
    ∀ {Σ} {semΣ_inst : semΣ Σ},
      logrel.definitions.ctx_rel_typed MaybeStuck
                                         back_ctx_STLCmuST_sem_STLCmuVS
                                         back_ctx_STLCmuST_sem_STLCmuVS
                                           Γ τ [] TUnit.
  Proof. by apply back_ctx_st_sem_sem_typed. Qed.

  (* Furthermore, the backtranslated contexts successfully emulates the original (when interacting with syntactically typed terms in STLCmu). *)
  (* That is, for all syntactically typed e, Γ ⊢ₙₒ e : τ, C_b[e]⇓ ⇔ C[[[e]]]⇓ *)

  Lemma back_ctx_STLCmuST_sem_STLCmuVS_correct_emulation :
    ∀ (e : STLCmu.lang.expr) (de : Γ ⊢ₙₒ e : τ),
      STLCmuVS_halts (STLCmuVS.contexts.fill_ctx back_ctx_STLCmuST_sem_STLCmuVS (boring.embd_expr e)) <-> STLCmuST_halts (fill_ctx C (embd_expr e)).
  Proof.
    intros e de.
    rewrite -(comp_embeddings e).
    eapply back_ctx_st_sem_correct_emulation; eauto.
    by apply boring.embd_expr_typed.
  Qed.

End back_ctx_STLCmuST_sem_STLCmuVS.


Require Import Rel.Definitions.
Require Import Rel.BasicFacts.
Require Import Rel.Compat_sub.
Require Import Rel.Compat_bind_HV.
Require Import Util.Subset.
Require Import Lang.BindingsFacts.
Require Import Lang.Static.
Require Import Lang.StaticFacts.
Set Implicit Arguments.

Section section_compat_tm_happ.

Context (EV HV V : Set).
Context (Ξ : XEnv EV HV).
Context (Γ : V → ty EV HV ∅).
Context (P : HV → F).
Context (𝔽 : F).
Context (T : ty EV (inc HV) ∅).
Context (𝓔 : eff EV HV ∅).
Context (ℓ : lbl HV ∅).
Context (t₁ t₂ : tm EV HV V ∅).
Context (h₁ h₂ : hd EV HV V ∅).
Context (H_lbl_h₁ : lbl_hd h₁ = ℓ).
Context (H_lbl_h₂ : lbl_hd h₂ = ℓ).
Context (Wf_lbl_h₁ : wf_lbl Ξ (lbl_hd h₁)).

Hint Resolve subset_trans subset_refl st_reflexive get_some_inv postfix_refl postfix_is_subset.
Hint Constructors wf_lbl.

Lemma compat_tm_happ n :
n ⊨ ⟦ Ξ P Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : (ty_hfun 𝔽 T) # 𝓔 ⟧ →
n ⊨ ⟦ Ξ P Γ ⊢ h₁ ≼ˡᵒᵍₕ h₂ : 𝔽 # ℓ ⟧ →
n ⊨ ⟦ Ξ P Γ ⊢ (tm_happ t₁ h₁) ≼ˡᵒᵍ (tm_happ t₂ h₂) : (HV_subst_ty h₁ T) # 𝓔 ⟧.
Proof.
intros Ht Hh.
iintro ξ₁ ; iintro ξ₂ ; iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ; iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro cl_δ ; iintro cl_ρ₁ρ₂ ; iintro Hρ ; iintro Hγ.
iespecialize Ht.
repeat (ispecialize Ht ; [ eassumption | ]).

simpl.
generalize Ht.
generalize (subst_tm δ₁ ρ₁ γ₁ t₁), (subst_tm δ₂ ρ₂ γ₂ t₂).
clear Ht t₁ t₂.
intros t₁ t₂ Ht.

bind_happ.
eapply plug0 with (ξ₁ := ξ₁) (ξ₂ := ξ₂) ; [auto|auto| |auto|auto|exact Ht].

iintro ξ₁' ; iintro ξ₂' ; iintro v₁ ; iintro v₂ ; iintro Hξ₁' ; iintro Hξ₂' ; iintro Hv.
simpl in Hv |- *.
ispecialize Hv ξ₁' ; ispecialize Hv ξ₂'.
ispecialize Hv ; [auto 6|].
ispecialize Hv ; [auto 6|].
eapply ccompat_sub
  with (T := HV_subst_ty h₁ T) (𝓔 := HV_subst_eff h₁ []) ; [crush|crush| ].

replace Ξ with (HV_bind_XEnv (HV_substfun h₁) (HV_shift_XEnv Ξ)) by (
  erewrite
    HV_bind_map_XEnv with (g₁ := @hd_var EV HV V ∅),
    HV_bind_XEnv_id, HV_map_XEnv_id ;
  crush
).
erewrite <- I_iff_elim_M ; [ |
  eapply HV_bind_𝓣 with
    (ρ₁ := env_ext ρ₁ (subst_hd δ₁ ρ₁ γ₁ h₁))
    (ρ₂ := env_ext ρ₂ (subst_hd δ₂ ρ₂ γ₂ h₂))
    (ρ := env_ext ρ (𝓣𝓛⟦ HV_subst_XEnv h₁ (HV_shift_XEnv Ξ) ⊢ ℓ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ))
].
+ ispecialize Hh ξ₁' ; ispecialize Hh ξ₂'.
  ispecialize Hh δ₁ ; ispecialize Hh δ₂ ; ispecialize Hh δ.
  ispecialize Hh ρ₁ ; ispecialize Hh ρ₂ ; ispecialize Hh ρ.
  ispecialize Hh γ₁ ; ispecialize Hh γ₂.
  ispecialize Hh.
  { clear - Hξ Hξ₁' Hξ₂'.
    repeat match goal with [ H : _ ⊨ (_)ᵢ |- _ ] => ielim_prop H end.
    destruct Hξ ; iintro_prop ; split ; eauto.
  }
  ispecialize Hh.
  { clear - cl_δ Hξ₁' Hξ₂'.
    repeat iintro ; iespecialize cl_δ ; ispecialize cl_δ ; [ eassumption | ].
    repeat match goal with [ H : _ ⊨ (_)ᵢ |- _ ] => ielim_prop H end.
    destruct cl_δ ; split ; eauto.
  }
  ispecialize Hh.
  { clear - cl_ρ₁ρ₂ Hξ₁' Hξ₂'.
    repeat match goal with [ H : _ ⊨ (_)ᵢ |- _ ] => ielim_prop H end.
    iintro_prop ; eapply closed_ρ_monotone ; eauto.
  }
  ispecialize Hh.
  { eapply 𝑷_monotone ; eauto. }
  ispecialize Hh.
  { eapply 𝜞_monotone ; eauto. }

  destruct ℓ as [ p | [ | X ] ] ; [ | auto | ] ; simpl in Hh |- *.
  - idestruct Hh as r₁ Hh ; idestruct Hh as r₂ Hh ;
    idestruct Hh as X₁ Hh ; idestruct Hh as X₂ Hh ;
    idestruct Hh as Hh₁h₂ Hh ; idestruct Hh as Hρ₁ρ₂ Hr.
    ielim_prop Hh₁h₂ ; destruct Hh₁h₂ as [Hh₁ Hh₂] ; rewrite Hh₁, Hh₂.
    ielim_prop Hρ₁ρ₂ ; destruct Hρ₁ρ₂ as [Hρ₁ Hρ₂].
    ispecialize Hv r₁ ; ispecialize Hv r₂ ;
    ispecialize Hv X₁ ; ispecialize Hv X₂ ; ispecialize Hv (ρ p).
    ispecialize Hv.
    { clear - Hρ₁ Hρ₂ cl_ρ₁ρ₂ Hξ₁' Hξ₂'.
      repeat match goal with [ H : _ ⊨ (_)ᵢ |- _ ] => ielim_prop H end.
      specialize (cl_ρ₁ρ₂ p X₁) as cl_ρ₁ ; destruct cl_ρ₁ as [cl_ρ₁ _].
      specialize (cl_ρ₁ρ₂ p X₂) as cl_ρ₂ ; destruct cl_ρ₂ as [_ cl_ρ₂].
      apply postfix_is_subset in Hξ₁'.
      apply postfix_is_subset in Hξ₂'.
      crush.
    }
    ispecialize Hv ; [ exact Hr | exact Hv ].
  - idestruct Hh as r₁ Hh ; idestruct Hh as r₂ Hh ; idestruct Hh as Hh₁h₂ Hh ;
    idestruct Hh as S Hh ; idestruct Hh as 𝓕 Hh ; idestruct Hh as BindsX Hr.
    ielim_prop Hh₁h₂ ; destruct Hh₁h₂ as [Hh₁ Hh₂] ; rewrite Hh₁, Hh₂.
    ielim_prop BindsX.
    erewrite
      HV_bind_map_XEnv with (g₁ := @hd_var EV HV V ∅),
      HV_bind_XEnv_id, HV_map_XEnv_id ;
    [ | crush | crush | crush ].
    rewrite BindsX.
    ispecialize Hv r₁ ; ispecialize Hv r₂ ;
    ispecialize Hv X ; ispecialize Hv X ;
    ispecialize Hv (𝓣⟦ Ξ ⊢ S # 𝓕 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ).
    ispecialize Hv.
    { clear - BindsX Hξ Hξ₁' Hξ₂'.
      repeat match goal with [ H : _ ⊨ (_)ᵢ |- _ ] => ielim_prop H end.
      apply postfix_is_subset in Hξ₁'.
      apply postfix_is_subset in Hξ₂'.
      destruct Hξ.
      iintro_prop ; split ; eauto.
    }
    ispecialize Hv ; [ | exact Hv ].
    erewrite I_iff_elim_M ; [ apply Hr | clear ].
    auto_contr.
    apply 𝓗_Fun'_nonexpansive.
    * repeat iintro ; apply auto_contr_id.
    * repeat iintro ; apply fold_𝓥𝓤_in_𝓣.

+ destruct p as [ | p ] ; simpl ; [ crush | ].
  unfold compose ; erewrite V_bind_map_hd, V_bind_hd_id, V_map_hd_id ; crush.

+ destruct p as [ | p ] ; simpl.
  - destruct h₁ as [ p₁ | ? X₁ ? ], h₂ as [ p₂ | ? X₂ ? ] ;
    simpl in H_lbl_h₁, H_lbl_h₂ ;
    rewrite <- H_lbl_h₂ in H_lbl_h₁ ; inversion H_lbl_h₁ ;
    subst ; reflexivity.
  - unfold compose ; erewrite V_bind_map_hd, V_bind_hd_id, V_map_hd_id ; crush.

+ iintro p ; repeat iintro.
  destruct p as [ | p ] ; simpl ; try rewrite H_lbl_h₁ ; apply auto_contr_id.

+ assert (Wf_ℓ : wf_lbl Ξ ℓ).
  { clear - H_lbl_h₁ Wf_lbl_h₁ ; subst.
    auto.
  }
  destruct p as [ | p ] ; simpl ; try rewrite H_lbl_h₁ ; [ | constructor ].
  erewrite
    HV_bind_map_XEnv with (g₁ := @hd_var EV HV V ∅),
    HV_bind_XEnv_id, HV_map_XEnv_id ; crush.

Qed.

End section_compat_tm_happ.


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md descbrides the contents of each file and
   provides instructions to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* LIST LEMMAS                                                           *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Omega.

Require Import misc_arith.

Import ListNotations.

Open Scope list_scope.

Lemma map_expand:
forall (A B: Type) (f: A -> B) (l: list A) (s1 s2: list B),
s1 ++ s2 = map f l ->
exists s1' s2': list A,
l = s1' ++ s2' /\ map f s1' = s1 /\ map f s2' = s2.
Proof.
intros A B f l.
induction l.
- intros s1 s2 H.
  simpl in H.
  apply app_eq_nil in H.
  destruct H as [H1 H2].
  subst.
  exists [], [].
  auto.
- intros s1 s2 H.
  simpl in H.
  destruct s1.
  + simpl in H.
    destruct s2.
    * inversion H.
    * inversion H.
      exists [], (a::l). {
      split.
      - simpl.
        reflexivity.
      - split.
        + simpl.
          reflexivity.
        + simpl.
          reflexivity. }
  + destruct s2.
    * inversion H.
      exists (a::l), []. {
      split.
      - simpl.
        rewrite app_nil_r.
        reflexivity.
      - split.
        + simpl.
          rewrite <- H2.
          rewrite app_nil_r.
          reflexivity.
        + simpl.
          reflexivity. }
    * inversion H.
      specialize (IHl s1 (b0::s2)).
      specialize (IHl H2).
      destruct IHl as [s1' [s2' [H3 [H4 H5]]]].
      exists (a::s1').
      exists s2'. {
      split.
      - rewrite H3.
        simpl.
        reflexivity.
      - split.
        + simpl.
          rewrite H4.
          reflexivity.
        + rewrite H5.
          reflexivity. }
Qed.

Lemma equal_app (A: Type) :
forall l1 l2 s1 s2 : list A,
l1 ++ l2 = s1 ++ s2 ->
(exists l, s1 = l1 ++ l /\ l2 = l ++ s2) \/ (exists l, l1 = s1 ++ l /\ s2 = l ++ l2).
Proof.
intros l1.
induction l1 as [|a l1 IH].
- intros l2 s1 s2 H.
  simpl in H.
  subst.
  simpl.
  left.
  exists s1.
  split.
  reflexivity.
  reflexivity.
- intros l2 s1 s2 H.
  simpl in H.
  destruct s1 as [|a' s1].
  + simpl in H.
    subst.
    simpl.
    right.
    exists (a::l1).
    split.
    * reflexivity.
    * simpl.
      reflexivity.
  + simpl in H.
    inversion H.
    subst a'.
    clear H.
    apply IH in H2.
    destruct H2 as [(l & ? & ?) | (l & ? & ?)].
    * subst.
      simpl.
      left.
      exists l. {
      split.
      - reflexivity.
      - reflexivity. }
    * right.
      exists l. {
      split.
      - rewrite H.
        simpl.
        reflexivity.
      - rewrite H0.
        reflexivity. }
Qed.

Lemma last_last:
forall A: Type,
forall s d: A,
forall l: list A,
last (l++[s]) d = s.
Proof.
intros A s d l.
induction l.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + simpl.
    reflexivity.
  + rewrite <- app_comm_cons.
    exact IHl.
Qed.

Lemma length_ge_0:
forall A: Type,
forall l: list A,
length l >= 0.
Proof.
intros A l.
destruct l.
- simpl.
  omega.
- simpl.
  omega.
Qed.

Lemma length_ge_2:
forall A: Type,
forall a1 a2: A,
forall l: list A,
length (a1::a2::l) >= 2.
Proof.
intros A a1 a2 l.
simpl.
apply Le.le_n_S.
apply Le.le_n_S.
apply Le.le_0_n.
Qed.

Lemma length_lt_1:
forall A: Type,
forall l: list A,
length l < 1 -> l = [].
Proof.
intros A l H.
destruct l.
- reflexivity.
- replace (a::l) with ([a]++l) in H.
  + rewrite app_length in H.
    simpl in H.
    apply lt_S_n in H.
    apply lt_n_O in H.
    contradiction.
  + simpl.
    reflexivity.
Qed.

Lemma nth_cons:
forall A: Type,
forall a e: A,
forall l: list A,
forall i: nat,
nth (S i) (a::l) e = nth i l e.
Proof.
intros A a e l i.
simpl.
destruct i.
- simpl.
  reflexivity.
- reflexivity.
Qed.

Lemma length_not_zero:
forall A: Type,
forall l: list A,
length l > 0 -> [] <> l.
Proof.
intros A l H.
destruct l.
- simpl in H.
  apply gt_irrefl in H.
  contradiction.
- apply nil_cons.
Qed.

Lemma length_not_zero_inv:
forall A: Type,
forall l: list A,
l <> [] -> length l > 0.
Proof.
intros A l H.
destruct l.
- destruct H.
  reflexivity.
- simpl.
  omega.
Qed.

Lemma not_nil:
forall A: Type,
forall l: list A,
l <> [] -> length l <> 0.
Proof.
destruct l.
- intro H.
  auto.
- intro H.
  replace (a::l) with ([a]++l).
  + rewrite app_length.
    simpl.
    apply not_eq_sym.
    apply O_S.
  + simpl.
    reflexivity.
Qed.

Lemma not_nil_ge_1:
forall A: Type,
forall l: list A,
l <> [] -> length l >= 1.
Proof.
intros A l H.
apply not_nil in H.
destruct l.
- simpl in H.
  destruct H.
  reflexivity.
- simpl.
  apply le_n_S.
  apply le_0_n.
Qed.

Lemma list_last:
forall A: Type,
forall d: A,
forall l: list A,
removelast l <> [] -> nth (length (removelast l) - 1) (removelast l ++ [last l d]) d = last (removelast l) d.
Proof.
intros A d l H.
rewrite app_nth1 with (l:=removelast l).
- rewrite app_removelast_last with (l:=removelast l)(d:=d).
  + rewrite app_nth2.
    * rewrite app_length.
      assert (H1: Datatypes.length (removelast (removelast l)) + 1 - 1 -
                  Datatypes.length (removelast (removelast l)) = 0).
        {
        omega.
        }
      simpl.
      rewrite H1.
      rewrite last_last.
      reflexivity.
    * rewrite app_length.
      simpl.
      omega.
  + exact H.
- apply n_minus_1.
  apply not_nil.
  exact H.
Qed.

Lemma length_zero:
forall A: Type,
forall l: list A,
length l = 0 -> l = [].
Proof.
intros A l H.
destruct l.
- reflexivity.
- simpl in H.
  symmetry in H.
  apply O_S in H.
  contradiction.
Qed.

Lemma list_single:
forall A: Type,
forall l: list A,
forall d e: A,
nth 0 l d = e -> length l = 1 -> l = [e].
Proof.
intros A l d e H1 H2.
destruct l.
- simpl in H2.
  apply O_S in H2.
  contradiction.
- simpl in H1.
  rewrite H1.
  simpl in H2.
  inversion H2.
  apply length_zero in H0.
  rewrite H0.
  reflexivity.
Qed.

Lemma hd_nth0:
forall A: Type,
forall d: A,
forall l: list A,
hd d l = nth 0 l d.
Proof.
intros A d l.
destruct l.
- simpl.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma last_nth1:
forall A: Type,
forall d: A,
forall l: list A,
length l = 2 -> last l d = nth 1 l d.
Proof.
intros A d l H.
destruct l.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + simpl in H.
    inversion H.
  + replace (a :: a0 :: l) with ([a] ++ [a0] ++ l) in H.
    * repeat rewrite app_length in H.
      simpl in H.
      inversion H.
      apply length_zero in H1.
      subst.
      simpl.
      reflexivity.
    * simpl.
      reflexivity.
Qed.

Lemma hd_tl_nth1:
forall A: Type,
forall d: A,
forall l: list A,
length l > 2 -> hd d (tl l) = nth 1 l d.
Proof.
intros A d l H.
destruct l.
- simpl.
  reflexivity.
- simpl.
  apply hd_nth0.
Qed.

Lemma last_tl_last:
forall A: Type,
forall d: A,
forall l: list A,
length l > 2 -> last (tl l) d = last l d.
Proof.
intros A d l H.
destruct l.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + simpl in H.
    apply gt_S_n in H.
    apply lt_n_0 in H.
    contradiction.
  + reflexivity.
Qed.

Lemma nth_S:
forall A: Type,
forall i: nat,
forall s s0 s1: A,
forall l: list A,
nth (S i) (s::s0::s1::l) = nth i (s0::s1::l).
Proof.
intros A i s s0 s1 l.
destruct i.
- simpl.
  reflexivity.
- destruct i.
  + simpl.
    reflexivity.
  + destruct i.
    * simpl.
      reflexivity.
    * simpl.
      reflexivity.
Qed.

Lemma skipn_S:
forall i: nat,
forall A: Type,
forall a: A,
forall l: list A,
skipn (S i) (a :: l) = skipn i l.
Proof.
intros i A a l.
destruct i.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + reflexivity.
  + reflexivity.
Qed.

Lemma hd_skip:
forall i: nat,
forall A: Type,
forall d: A,
forall l: list A,
hd d (skipn i l) = nth i l d.
Proof.
intros i A d.
induction i as [| i IH].
- intros l.
  destruct l.
  + trivial.
  + trivial.
- intros l.
  destruct l.
  + trivial.
  + simpl.
    rewrite IH.
    reflexivity.
Qed.

Lemma last_skip:
forall i: nat,
forall A: Type,
forall d: A,
forall l: list A,
i < length l -> last (skipn i l) d = last l d.
Proof.
intros i A d.
induction i as [|i IH].
- intros l.
  destruct l.
  + trivial.
  + trivial.
- intros l.
  destruct l.
  + trivial.
  + simpl.
    intros Hl.
    assert (Hl' : i < length l) by omega.
    rewrite IH.
    * {
      destruct l.
      - simpl in Hl'.
        omega.
      - trivial.
      }
    * trivial.
Qed.

Lemma hd_hd:
forall A: Type,
forall d: A,
forall l l': list A,
length l >= 1 -> hd d l = hd d (l ++ l').
Proof.
intros A d l l' H.
destruct l.
- simpl in H.
  apply le_Sn_0 in H.
  contradiction.
- simpl.
  reflexivity.
Qed.

Lemma hd_first:
forall A: Type,
forall d: A,
forall l: list A,
forall i: nat,
i >= 1 -> hd d (firstn i l) = hd d l.
Proof.
intros A d l i H.
destruct l.
- destruct i.
  + simpl.
    reflexivity.
  + simpl.
    reflexivity.
- destruct i.
  + apply le_Sn_0 in H.
    contradiction.
  + simpl.
    reflexivity.
Qed.

Lemma firstn_empty:
forall A: Type,
forall a: A,
forall i: nat,
a :: firstn i [] = [a].
Proof.
intros A a i.
destruct i.
- simpl.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma firstn_single:
forall A: Type,
forall a: A,
forall i: nat,
firstn (S i) [a] = [a].
intros A a i.
destruct i.
- simpl.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma nth_S':
forall i: nat,
forall A: Type,
forall a d: A,
forall l: list A,
nth (S i) (a :: l) d = nth i l d.
Proof.
intros i A a d l.
destruct i.
- simpl. reflexivity.
- simpl. reflexivity.
Qed.

Lemma firstn_S:
forall A: Type,
forall a: A,
forall l: list A,
forall i: nat,
firstn (S i) (a :: l) = a :: firstn i l.
Proof.
intros A a l.
induction l.
- intros i. simpl. reflexivity.
- intros i. destruct i.
  + simpl. reflexivity.
  + simpl. reflexivity.
Qed.

Lemma last_cons:
forall A: Type,
forall a d: A,
forall l: list A,
l <> [] -> last (a :: l) d = last l d.
Proof.
intros A a d l H.
induction l.
- destruct H. reflexivity.
- trivial.
Qed.

Lemma not_nil_firstn:
forall A: Type,
forall l: list A,
forall i: nat,
l <> [] -> firstn (S i) l <> [].
Proof.
intros A l i H.
destruct l.
- simpl. exact H.
- simpl. apply not_eq_sym. apply nil_cons.
Qed.

Lemma nil_not_nil:
forall A: Type,
forall l: list A,
l = [] \/ l <> [].
Proof.
destruct l.
- left.
  reflexivity.
- right.
  apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma last_first_nth:
forall A: Type,
forall d: A,
forall l: list A,
forall i: nat,
length l >= S i -> last (firstn (S i) l) d = nth i l d.
Proof.
intros A d l.
induction l.
- destruct i.
  + trivial.
  + trivial.
- destruct i.
  + trivial.
  + intros H.
    rewrite nth_S'.
    rewrite <- IHl.
    * rewrite firstn_S.
      {
      rewrite last_cons.
      - reflexivity.
      - apply not_nil_firstn.
        specialize (IHl i).
        replace (a::l) with ([a]++l) in H.
        + rewrite app_length in H.
          simpl in H.
          assert (H1: length l > 0) by omega.
          destruct l.
          * simpl in H1.
            omega.
          * apply not_eq_sym.
            apply nil_cons.
        + simpl.
          reflexivity.
      }
    * {
      replace (a::l) with ([a]++l) in H.
      - rewrite app_length in H.
        simpl in H.
        omega.
      - simpl.
        reflexivity.
      }
Qed.

Lemma nth_last:
forall A: Type,
forall l: list A,
forall d: A,
nth (length l - 1) l d = last l d.
Proof.
intros A l d.
destruct l.
- simpl.
  reflexivity.
- remember (a::l) as l0.
  rewrite app_removelast_last with (l:=l0) (d:=d).
  + rewrite app_length.
    simpl.
    rewrite last_last.
    rewrite app_nth2.
    * assert (H: (Datatypes.length (removelast l0) + 1 - 1 - Datatypes.length (removelast l0) = 0)) by omega.
      rewrite H.
      simpl.
      reflexivity.
    * omega.
  + rewrite Heql0.
    apply not_eq_sym.
    replace (a::l) with ([]++a::l).
    * apply app_cons_not_nil.
    * simpl.
      reflexivity.
Qed.

Lemma hd_app:
forall A: Type,
forall l l': list A,
forall a d: A,
l <> [] ->
l' <> [] ->
hd d l = hd d l' ->
hd d (l ++ [a]) = hd d (l' ++ [a]).
Proof.
intros A l l' a d H1 H2 H3.
destruct l.
- destruct l'.
  + simpl.
    reflexivity.
  + destruct H1.
    reflexivity.
- destruct l'.
  + destruct H2.
    reflexivity.
  + simpl.
    simpl in H3.
    exact H3.
Qed.

Lemma last_2_1:
forall A: Type,
forall l: list A,
forall a1 a2 d: A,
last (a1 :: a2 :: l) d = last (a2 :: l) d.
Proof.
intros A l a1 a2 d.
simpl.
reflexivity.
Qed.

Lemma last_app:
forall A: Type,
forall l l': list A,
forall a d: A,
l <> [] ->
l' <> [] ->
last l d = last l' d ->
last ([a] ++ l) d = last ([a] ++ l') d.
Proof.
intros A l l' a d H1 H2 H3.
induction l, l'.
- simpl.
  reflexivity.
- destruct H1.
  reflexivity.
- destruct H2.
  reflexivity.
- replace ([a] ++ a0 :: l) with (a :: a0 :: l).
  + replace ([a] ++ a1 :: l') with (a :: a1 :: l').
    * repeat rewrite last_2_1.
      exact H3.
    * simpl.
      reflexivity.
  + simpl.
    reflexivity.
Qed.

Lemma hd_not_nil:
forall A: Type,
forall l: list A,
forall a d: A,
d <> a ->
hd d l = a ->
l <> [].
Proof.
intros A l a d H1 H2.
destruct l.
- simpl in H2.
  contradiction.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma hd_not_nil_v2:
forall A: Type,
forall l: list A,
forall d: A,
hd d l <> d -> l <> [].
Proof.
intros A l d H.
destruct l.
- simpl in H.
  destruct H.
  reflexivity.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma hd_not_zero:
forall A: Type,
forall l: list A,
forall a d: A,
d <> a ->
hd d l = a ->
length l > 0.
Proof.
intros A l a d H1 H2.
destruct l.
- simpl in H2.
  contradiction.
- simpl.
  apply gt_Sn_O.
Qed.

Lemma hd_removelast:
forall A: Type,
forall s d: A,
forall l l': list A,
l <> [] -> hd d (removelast (s :: l) ++ l') = s.
Proof.
intros A s d l l' H.
destruct l.
- destruct H.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma length_cons_gt_1:
forall A: Type,
forall s: A,
forall l: list A,
length (s :: l) > 1 -> l <> [].
Proof.
intros A s l H.
replace (s :: l) with ([s] ++ l) in H.
- rewrite app_length in H.
  simpl in H.
  apply gt_S_n in H.
  apply not_eq_sym.
  apply length_not_zero.
  exact H.
- simpl.
  reflexivity.
Qed.

Lemma length_cons_eq_1:
forall A: Type,
forall s: A,
forall l: list A,
length (s :: l) = 1 -> l = [].
Proof.
intros A s l H.
destruct l.
- reflexivity.
- simpl in H.
  apply eq_add_S in H.
  symmetry in H.
  apply O_S in H.
  contradiction.
Qed.

Lemma not_exists_forall_not:
forall A B: Type,
forall l: list (A+B),
~ (exists a': A, l = [inl a']) ->
forall a': A, (l <> [inl a']).
Proof.
intros A B l H a'.
unfold not at 1 in H.
unfold not.
destruct l.
- intro H1.
  inversion H1.
- intro H1.
  apply H.
  exists a'.
  exact H1.
Qed.

Lemma in_in:
forall A: Type,
forall s: A,
forall s1 s2: list A,
In s (s1 ++ [s] ++ s2).
Proof.
intros A s s1 s2.
induction s1.
- simpl.
  left.
  reflexivity.
- apply in_app_iff.
  right.
  simpl.
  left.
  reflexivity.
Qed.

Lemma in_out:
forall A: Type,
forall s: A,
forall l s1 s2: list A,
l = s1 ++ [s] ++ s2 ->
In s l.
Proof.
intros A s l s1 s2 H.
rewrite H.
apply in_in.
Qed.

Lemma exists_length_eq_2:
forall A: Type,
forall l: list A,
length l = 2 ->
exists s1 s2: A,
l = [s1] ++ [s2].
Proof.
intros A l H.
destruct l.
- simpl in H.
  apply O_S in H.
  contradiction.
- destruct l.
  + simpl in H.
    apply eq_add_S in H.
    apply O_S in H.
    contradiction.
  + destruct l.
    * exists a, a0.
      reflexivity.
    * simpl in H.
      repeat apply eq_add_S in H.
      symmetry in H.
      apply O_S in H.
      contradiction.
Qed.

Lemma exists_length_gt_2:
forall A: Type,
forall d: A,
forall l: list A,
length l > 2 ->
exists s1 s2: A,
exists l': list A,
l = [s1] ++ l' ++ [s2].
Proof.
intros A d l H.
destruct l.
- simpl in H.
  apply lt_n_0 in H.
  contradiction.
- destruct l.
  + simpl in H.
    apply gt_S_n in H.
    apply lt_n_0 in H.
    contradiction.
  + destruct l.
    * simpl in H.
      repeat apply gt_S_n in H.
      apply lt_n_0 in H.
      contradiction.
    * assert (H1: l = [] \/ l <> []).
        {
        apply nil_not_nil.
        }
      {
      destruct H1 as [H1 | H1].
      - subst.
        exists a, a1, [a0].
        reflexivity.
      - change (a :: a0 :: a1 :: l) with (([a] ++ [a0] ++ [a1]) ++ l) in H.
        exists a.
        rewrite app_removelast_last  with (A:=A) (l:=l) (d:=d).
        + exists (last l d).
          exists (a0 :: a1 :: removelast l).
          reflexivity.
        + exact H1.
      }
Qed.

Lemma exists_length_ge_2:
forall A: Type,
forall def: A,
forall l: list A,
length l >= 2 ->
exists s1 s2: A,
exists l': list A,
l = [s1] ++ l' ++ [s2].
Proof.
intros A def l H1.
assert (H2: length l > 2 \/ length l = 2) by omega.
destruct H2 as [H2 | H2].
- apply (exists_length_gt_2 A def l) in H2.
  exact H2.
- apply exists_length_eq_2 in H2.
  destruct H2 as [s1 [s2 H3]].
  exists s1, s2, [].
  simpl.
  exact H3.
Qed.

Lemma length_eq_0:
forall A: Type,
forall l: list A,
length l = 0 -> l = [].
Proof.
intros A l H.
destruct l.
- reflexivity.
- change (a ::l) with ([a] ++ l) in H.
  rewrite app_length in H.
  simpl in H.
  symmetry in H.
  apply O_S in H.
  contradiction.
Qed.

Lemma elem_not_nil:
forall A: Type,
forall w1 w2: list A,
forall X: A,
w1 ++ [X] ++ w2 <> [].
Proof.
intros A w1 w2 X.
destruct w1.
- simpl.
  apply not_eq_sym.
  apply nil_cons.
- simpl.
  apply not_eq_sym.
  replace (a :: w1 ++ X :: w2) with (([a] ++ w1) ++ [X] ++ w2).
  + apply app_cons_not_nil.
  + simpl.
    reflexivity.
Qed.

Lemma map_map_app:
forall A B : Type,
forall f: A -> B,
forall x y: list A,
forall z: list B,
map f x = map f y ++ z ->
exists z': list A,
z = map f z'.
Proof.
intros A B f x y z H.
symmetry in H.
apply map_expand in H.
destruct H as [s1' [s2' [H1 [H2 H3]]]].
exists s2'.
symmetry.
exact H3.
Qed.

Lemma cat_left:
forall A: Type,
forall a: A,
forall l1 l2: list A,
l1 = l2 -> [a] ++ l1 = [a] ++ l2.
Proof.
intros A a l1 l2 H.
rewrite H.
reflexivity.
Qed.

Lemma map_not_nil:
forall A B: Type,
forall f: A -> B,
forall l: list A,
map f l <> [] -> l <> [].
Proof.
intros A B f l H.
destruct l.
- destruct H.
  simpl.
  reflexivity.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma map_not_nil_inv:
forall A B: Type,
forall f: A -> B,
forall l: list A,
l <> [] -> map f l <> [].
Proof.
intros A B f l H.
destruct l.
- destruct H.
  reflexivity.
- simpl.
  apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma app_not_nil:
forall A: Type,
forall x y: list A,
x ++ y <> [] ->
(x <> [] \/ y <> []).
Proof.
intros A x y H.
assert (H1: x = [] \/ x <> []).
  {
  apply nil_not_nil.
  }
assert (H2: y = [] \/ y <> []).
  {
  apply nil_not_nil.
  }
destruct H1 as [H1 | H1].
- destruct H2 as [H2 | H2].
  + rewrite H1 in H.
    rewrite H2 in H.
    simpl in H.
    destruct H.
    reflexivity.
  + right.
    exact H2.
- destruct H2 as [H2 | H2].
  + rewrite H2 in H.
    rewrite app_nil_r in H.
    left.
    exact H.
  + left.
    exact H1.
Qed.

Lemma app_not_nil_inv:
forall A: Type,
forall x y: list A,
(x <> [] \/ y <> []) ->
x ++ y <> [].
Proof.
intros A x y H.
destruct H as [H | H].
- intros H2.
  apply app_eq_nil in H2.
  destruct H2 as [H2 _].
  contradiction.
- intros H2.
  apply app_eq_nil in H2.
  destruct H2 as [_ H2].
  contradiction.
Qed.

Lemma list_not_nil:
forall A: Type,
forall l: list A,
l <> [] ->
exists l1 l2 l3: list A,
l = l1 ++ l2 ++ l3 /\
l2 <> [].
Proof.
intros A l H.
destruct l.
- destruct H.
  reflexivity.
- exists [], [a], l.
  split.
  + simpl.
    reflexivity.
  + apply not_eq_sym.
    apply nil_cons.
Qed.

Lemma app_eq:
forall A: Type,
forall a: A,
forall l1 l2: list A,
l1 = l2 -> [a] ++ l1 = [a] ++ l2.
Proof.
intros A a l1 l2 H.
destruct l1, l2.
- simpl.
  reflexivity.
- inversion H.
- inversion H.
- rewrite H.
  reflexivity.
Qed.

Lemma list_single_elem:
forall A: Type,
forall l1 l2: list A,
forall a b: A,
l1 ++ a :: l2 = [b] ->
l1 = []/\ l2 = [].
Proof.
intros A l1 l2 a b H1.
split.
- destruct l1.
  + reflexivity.
  + inversion H1.
    destruct l1.
    * inversion H2.
    * inversion H2.
- destruct l1.
  + inversion H1.
    reflexivity.
  + inversion H1.
    destruct l1.
    * inversion H2.
    * inversion H2.
Qed.

Lemma last_not_nil:
forall A: Type,
forall l: list A,
forall d: A,
(last l d) <> d -> l <> [].
Proof.
intros A l d H.
destruct l.
- simpl in H.
  destruct H.
  reflexivity.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma app_cons_eq:
forall A: Type,
forall s1 s2: list A,
forall a b: A,
s1 ++ a :: s2 = [b] ->
s1 = [] /\ s2 = [] /\ a = b.
Proof.
intros A s1 s2 a b H.
destruct s1.
- inversion H.
  subst.
  auto.
- inversion H.
  destruct s1.
  + inversion H2.
  + inversion H2.
Qed.

Lemma not_in_not_eq:
forall A: Type,
forall a b: A,
~ In a [b] -> a <> b.
Proof.
intros A a b H.
simpl in H.
intros H2.
apply H.
left.
symmetry.
exact H2.
Qed.

Lemma inl_neq:
forall X Y: Type,
forall a b: X,
@inl X Y a <> @inl X Y b -> a <> b.
Proof.
intros X Y a b H.
intro.
apply H.
subst.
reflexivity.
Qed.

Lemma length_cons_le:
forall A: Type,
forall l1 l2: list A,
forall a: A,
forall n: nat,
length (l1 ++ a :: l2) <= n ->
length (l1 ++ l2) <= n.
Proof.
intros A l1 l2 a n H.
rewrite app_length.
change (a :: l2) with ([a] ++ l2) in H.
repeat rewrite app_length in H.
simpl in H.
omega.
Qed.

Lemma in_app_cons:
forall A: Type,
forall l1 l2: list A,
forall a b: A,
In a (l1 ++ l2) ->
In a (l1 ++ b :: l2).
Proof.
intros A l1 l2 a b H.
apply in_app_or in H.
apply in_or_app.
destruct H as [H | H].
- left.
  exact H.
- right.
  change (b :: l2) with ([b] ++ l2).
  apply in_or_app.
  right.
  exact H.
Qed.

Lemma cons_app:
forall (A: Type) (s: A) (l: list A),
s :: l = [s] ++ l.
Proof.
intros.
simpl.
reflexivity.
Qed.

Lemma length_map_ge:
forall A B: Type,
forall n: nat,
forall f: A -> B,
forall s: list A,
length s >= n ->
length (map f s) >= n.
Proof.
induction n, s.
- simpl.
  auto.
- simpl.
  intros H.
  omega.
- simpl.
  auto.
- simpl.
  intros H.
  apply le_S_n in H.
  specialize (IHn f s H).
  apply le_n_S in IHn.
  exact IHn.
Qed.

Lemma length_map_le:
forall A B: Type,
forall n: nat,
forall f: A -> B,
forall s: list A,
length s <= n ->
length (map f s) <= n.
Proof.
induction n, s.
- simpl.
  auto.
- simpl.
  intros H.
  omega.
- simpl.
  auto.
- simpl.
  intros H.
  apply le_S_n in H.
  specialize (IHn f s H).
  apply le_n_S in IHn.
  exact IHn.
Qed.

Lemma length_map_le_inv:
forall A B: Type,
forall n: nat,
forall f: A -> B,
forall s: list A,
length (map f s) <= n ->
length s <= n.
Proof.
induction n, s.
- simpl.
  auto.
- simpl.
  intros H.
  omega.
- simpl.
  auto.
- simpl.
  intros H.
  apply le_S_n in H.
  specialize (IHn f s H).
  apply le_n_S in IHn.
  exact IHn.
Qed.

Lemma map_eq:
forall A B: Type,
forall f: A -> B,
forall l1 l2: list A,
injective A B f ->
map f l1 = map f l2 -> l1 = l2.
Proof.
intros A B f.
induction l1.
- intros l2 H1 H2.
  simpl in H2.
  symmetry in H2.
  apply map_eq_nil in H2.
  symmetry.
  exact H2.
- intros l2 H1 H2.
  simpl in H2.
  destruct l2.
  + simpl in H2.
    inversion H2.
  + simpl in H2.
    inversion H2.
    assert (H1':= H1).
    specialize (H1 a a0 H0).
    specialize (IHl1 l2 H1' H3).
    subst.
    reflexivity.
Qed.

Fixpoint iter {A: Type} (w: list A) (n: nat): list A:=
match n with
| O => []
| S n => w ++ iter w n
end.

Lemma iter_comm:
forall A: Type,
forall l: list A,
forall i: nat,
l ++ iter l i = iter l i ++ l.
Proof.
intros A l i.
revert l.
induction i.
- simpl.
  intros l.
  rewrite app_nil_r.
  reflexivity.
- intros l.
  simpl.
  rewrite <- app_assoc.
  rewrite <- IHi.
  reflexivity.
Qed.

Lemma cons_neq:
forall A: Type,
forall a: A,
forall l: list A,
l <> a :: l.
Proof.
intros A a l.
induction l.
- intros H.
  inversion H.
- intros H.
  inversion H.
  contradiction.
Qed.

Lemma list_split:
forall A: Type,
forall l: list A,
forall n m: nat,
length l = n + m ->
exists l1 l2: list A,
l = l1 ++ l2 /\
length l1 = n /\
length l2 = m.
Proof.
intros A l n m H1.
assert (H2: firstn n l ++ skipn n l = l).
  {
  apply firstn_skipn.
  }
assert (H3: length (firstn n l) = min n (length l)).
  {
  apply firstn_length.
  }
assert (H4: min n (n + m) = n).
  {
  apply min_l.
  omega.
  }
assert (H5: length (firstn n l) = n).
  {
  rewrite H1 in H3.
  rewrite H4 in H3.
  exact H3.
  }
clear H3 H4.
rewrite <- H2 in H1.
rewrite app_length in H1.
rewrite H5 in H1.
assert (H6: length (skipn n l) = m) by omega.
exists (firstn n l), (skipn n l).
split.
- symmetry.
  exact H2.
- split.
  + exact H5.
  + exact H6.
Qed.

Lemma list_split_exists:
forall A: Type,
forall l: list A,
exists l1 l2: list A,
l = l1 ++ l2.
Proof.
intros A.
induction l.
- exists [], [].
  reflexivity.
- destruct IHl as [l1 [l2 IHl]].
  rewrite IHl.
  exists (a :: l1), l2.
  reflexivity.
Qed.

Fixpoint get_As (A B: Type) (l: list (A + B)): list A:=
match l with
| [] => []
| inl a :: l => a :: get_As A B l
| inr b :: l => get_As A B l
end.

Lemma get_As_correct:
forall A B: Type,
forall r: list (A + B),
(forall e: (A + B), In e r -> exists a: A, e = inl a) ->
r = map inl (get_As A B r).
Proof.
intros A B r H.
induction r.
- simpl.
  reflexivity.
- destruct a.
  + simpl.
    rewrite <- IHr.
    * reflexivity.
    * intros e H1.
      apply H.
      simpl.
      right.
      exact H1.
  + specialize (H (inr b)).
    assert (H1: In (inr b) (inr b :: r)).
      {
      simpl.
      left.
      reflexivity.
      }
    specialize (H H1).
    destruct H as [n H].
    discriminate.
Qed.

Fixpoint get_Bs (A B: Type) (l: list (A + B)): list B:=
match l with
| [] => []
| inl a :: l => get_Bs A B l
| inr b :: l => b :: get_Bs A B l
end.

Lemma get_Bs_correct:
forall A B: Type,
forall r: list (A + B),
(forall e: (A + B), In e r -> exists b: B, e = inr b) ->
r = map inr (get_Bs A B r).
Proof.
intros A B r H.
induction r.
- simpl.
  reflexivity.
- destruct a.
  + specialize (H (inl a)).
    assert (H1: In (inl a) (inl a :: r)).
      {
      simpl.
      left.
      reflexivity.
      }
    specialize (H H1).
    destruct H as [n H].
    discriminate.
  + simpl.
    rewrite <- IHr.
    * reflexivity.
    * intros e H1.
      apply H.
      simpl.
      right.
      exact H1.
Qed.

Lemma split_app:
forall A: Type,
forall l l1 l2: list A,
l = l1 ++ l2 ->
exists l' l'': list A,
l = l' ++ l'' /\
l' = l1 /\
l'' = l2.
Proof.
intros A l.
destruct l.
- intros l1 l2 H.
  symmetry in H.
  apply app_eq_nil in H.
  destruct H as [H H1].
  subst.
  exists [], [].
  simpl.
  auto.
- intros l1 l2 H.
  exists l1, l2.
  split.
  + exact H.
  + auto.
Qed.

Lemma not_nil_app:
forall A: Type,
forall l1 l2: list A,
l1 <> [] ->
l1 ++ l2 <> [].
Proof.
intros A l1 l2 H.
destruct l1.
- destruct H.
  reflexivity.
- apply not_eq_sym.
  intros H1.
  inversion H1.
Qed.

Fixpoint flat {A: Type} (l: list (list A)): list A:=
match l with
| [] => []
| s :: l => s ++ flat l
end.

Lemma flat_app:
forall A: Type,
forall l1 l2: list (list A),
flat (l1 ++ l2) = flat l1 ++ flat l2.
Proof.
induction l1.
- simpl.
  reflexivity.
- intros l2.
  simpl.
  specialize (IHl1 l2).
  rewrite IHl1.
  rewrite <- app_assoc.
  reflexivity.
Qed.

Lemma app_single:
forall A: Type,
forall l1 l2: list A,
forall a: A,
l1 ++ l2 = [a] ->
l1 = [a] /\ l2 = [] \/
l1 = [] /\ l2 = [a].
Proof.
intros A l1 l2 a H.
destruct l1, l2.
- inversion H.
- inversion H.
  subst.
  right.
  auto.
- inversion H.
  subst.
  left.
  rewrite app_nil_r.
  auto.
- inversion H.
  destruct l1.
  + inversion H2.
  + inversion H2.
Qed.

(* --------------------------------------------------------------------- *)
(* SUFFIX                                                                *)
(* --------------------------------------------------------------------- *)

Section Suffix.

Variable A: Type.

Definition suffix_v1 (l1 l2: list A): Prop:=
exists l,
l2 = l ++ l1.

Inductive suffix_v2: list A -> list A -> Prop:=
| suffix_eq:  forall l1 l2: list A, l1 = l2 -> suffix_v2 l1 l2
| suffix_app: forall l1 l2: list A, forall a: A, suffix_v2 l1 l2 -> suffix_v2 l1 (a :: l2).

Fixpoint suffix_v3 (l1 l2: list A): Prop:=
l1 = l2 \/
match l2 with
| [] => False
| e :: l' => suffix_v3 l1 l'
end.

Lemma suffix_v1_nil:
forall l: list A,
suffix_v1 [] l.
Proof.
intros l.
exists l.
rewrite app_nil_r.
reflexivity.
Qed.

Lemma suffix_v2_nil:
forall l: list A,
suffix_v2 [] l.
Proof.
induction l.
- apply suffix_eq.
  reflexivity.
- apply suffix_app.
  exact IHl.
Qed.

Lemma suffix_v3_nil:
forall l: list A,
suffix_v3 [] l.
Proof.
intros l.
induction l.
- simpl.
  left.
  reflexivity.
- simpl.
  right.
  exact IHl.
Qed.

Lemma suffix_v1_equiv_suffix_v2:
forall l1 l2: list A,
suffix_v1 l1 l2 <-> suffix_v2 l1 l2.
Proof.
intros l1 l2.
split.
- intros H.
  destruct H as [l H].
  subst.
  induction l.
  + simpl.
    apply suffix_eq.
    reflexivity.
  + simpl.
    apply suffix_app.
    exact IHl.
- intros H.
  induction H.
  + subst.
    exists [].
    reflexivity.
  + destruct IHsuffix_v2 as [l IHsuffix_v2].
    subst.
    exists (a :: l).
    reflexivity.
Qed.

Lemma suffix_v2_equiv_suffix_v3:
forall l1 l2: list A,
suffix_v2 l1 l2 <-> suffix_v3 l1 l2.
Proof.
intros l1 l2.
split.
- intros H.
  induction H.
  + subst.
    destruct l2.
    * simpl.
      left.
      reflexivity.
    * simpl.
      left.
      reflexivity.
  + simpl.
    right.
    exact IHsuffix_v2.
- generalize dependent l2.
  induction l2.
  + intros H.
    simpl in H.
    destruct H as [H | H].
    * subst.
      apply suffix_eq.
      reflexivity.
    * contradiction.
  + intros H.
    simpl in H.
    destruct H as [H | H].
    * subst.
      apply suffix_eq.
      reflexivity.
    * apply suffix_app.
      apply IHl2.
      exact H.
Qed.

Lemma suffix_v1_split:
forall l1 l2: list A,
suffix_v1 l1 l2 ->
exists l: list A,
l ++ l1 = l2.
Proof.
intros l1 l2 H.
unfold suffix_v1 in H.
destruct H as [l H].
subst.
exists l.
reflexivity.
Qed.

Lemma suffix_v2_split:
forall l1 l2: list A,
suffix_v2 l1 l2 ->
exists l: list A,
l ++ l1 = l2.
Proof.
intros l1 l2 H.
induction H.
- subst.
  exists [].
  reflexivity.
- destruct IHsuffix_v2 as [l H2].
  rewrite <- H2.
  exists (a :: l).
  reflexivity.
Qed.

Lemma suffix_v3_split:
forall l1 l2: list A,
suffix_v3 l1 l2 ->
exists l: list A,
l ++ l1 = l2.
Proof.
induction l2.
- intros H.
  simpl in H.
  destruct H as [H | H].
  + subst.
    exists [].
    reflexivity.
  + contradiction.
- intros H.
  simpl in H.
  destruct H as [H | H].
  + subst.
    exists [].
    reflexivity.
  + specialize (IHl2 H).
    destruct IHl2 as [l H2].
    subst.
    exists (a :: l).
    reflexivity.
Qed.

End Suffix.


Require Import
        List
        FJ.Base
        FJ.Semantics.AuxiliarDefinitions
        FJ.Syntax
        FJ.Typing.Subtyping
        FJ.Tactics.

(* type rules for expressions *)

Section TYPING.

  Variable CT : ClassTable.

  Reserved Notation "G '|--' e '::' C" (at level 58, e at next level).

  Inductive StupidWarning : Set := StupidCast : StupidWarning.

  Definition Gamma : Type := Map ClassName.

  Inductive ExpHasType (G : Gamma) : Exp -> ClassName -> Prop :=
  | T_Var : forall v C,
      M.MapsTo v C G ->
      G |-- (EVar v) :: C
  | T_Field : forall e C fs fd fi n,
      G |-- e :: C ->
      fields CT n C fs  ->
      M.MapsTo fi fd fs ->
      G |-- (EFieldAccess e fi) :: (fdtype fd)
  | T_Invoc : forall e C0 Ds es m n mt,
      G |-- e :: C0 ->
      m_type_lookup CT n m C0 mt ->
      Forall2 (ExpHasType G) es Ds ->
      Forall2 (Subtype CT) Ds (mtparams mt) ->
      G |-- EMethodInvoc e m es :: (mttype mt)
  | T_New : forall C Ds Cs fs es n,
      fields CT n C fs ->
      Ds = map fdtype (values fs) ->
      Forall2 (ExpHasType G) es Cs ->
      Forall2 (Subtype CT) Cs Ds ->
      G |-- (ENew C es) :: C
  | T_UCast : forall e D C n,
      G |-- e :: D ->
      BoundedSubtype CT n D C ->
      G |-- (ECast C e) :: C
  | T_DCast : forall e C D n,
      G |-- e :: D    ->
      BoundedSubtype CT n C D ->
      C <> D          ->
      G |-- (ECast C e) :: C
  | T_SCast : forall e D C n m,
      G |-- e :: D ->
      ~ (BoundedSubtype CT n D C)   ->
      ~ (BoundedSubtype CT m C D)   ->
      StupidWarning ->
      G |-- (ECast C e) :: C
  where "G '|--' e '::' C" := (ExpHasType G e C).

  Definition mkGamma (fargs : list FormalArg) : Gamma :=
    fold_left (fun ac f => M.add (get_name f) (ftype f) ac) fargs (M.empty _).

  (* method typing *)

  Inductive MethodOk : ClassName -> Method -> Prop :=
  | T_Method
    : forall CD C E0 MD n,
      M.MapsTo C CD CT ->
      mkGamma ((mkFormalArg this C) :: (margs MD)) |-- (mbody MD) :: E0 ->
      Subtype CT E0 (mtype MD) ->
      valid_override CT n (mname MD) (cextends CD)
                     (mkMethodType (map ftype (margs MD)) (mtype MD)) ->
      MethodOk C MD.

  (* class typing *)

  Inductive ClassOk : ClassDecl -> Prop :=
  | T_Class
    : forall C CD D n dfds ms K fs,
      M.MapsTo C CD CT ->
      CD = mkClassDecl C D fs K ms ->
      fields CT n D dfds ->
      Forall (MethodOk C) (values ms) ->
      ClassOk CD.

End TYPING.

Notation "CT ';' G '|--' e '::' C" := (ExpHasType CT G e C)(at level 58, e at next level).

Hint Constructors StupidWarning.
Hint Constructors ExpHasType.
Hint Constructors MethodOk.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** * Definition of the part of boolean-returning CFG parser-recognizer that instantiates things to lists *)
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Common.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.

Set Implicit Arguments.
Local Open Scope type_scope.
Local Open Scope string_like_scope.

Local Arguments leb !_ !_.

Section recursive_descent_parser_list.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HLSP : StringLikeProperties Char} {G : pregrammar' Char}
          (Char_beq : Char -> Char -> bool).
  Definition rdp_list_nonterminals_listT : Type := list nat.
  Notation rdp_list_nonterminal_carrierT := default_nonterminal_carrierT.
  (** (nonterminal, production_index, drop_count) *)
  Notation rdp_list_production_carrierT := default_production_carrierT.

  Definition list_bin_eq
    := Eval unfold list_bin in list_bin EqNat.beq_nat.

  Definition rdp_list_is_valid_nonterminal : rdp_list_nonterminals_listT -> rdp_list_nonterminal_carrierT -> bool
    := fun ls nt => list_bin_eq nt ls.

  Local Ltac fix_list_bin_eq :=
    unfold rdp_list_is_valid_nonterminal;
    change list_bin_eq with (list_bin EqNat.beq_nat) in *.

  Local Notation valid_nonterminals := (map fst (pregrammar_productions G)).

  Definition rdp_list_initial_nonterminals_data
  : rdp_list_nonterminals_listT
    := up_to (List.length valid_nonterminals).

  Definition rdp_list_of_nonterminal
  : String.string -> rdp_list_nonterminal_carrierT
    := default_of_nonterminal (G := G).
  Definition rdp_list_to_nonterminal
  : rdp_list_nonterminal_carrierT -> String.string
    := default_to_nonterminal (G := G).

  Definition rdp_list_to_production : rdp_list_production_carrierT -> production Char
    := default_to_production (G := G).

  Definition rdp_list_nonterminal_to_production : rdp_list_nonterminal_carrierT -> list rdp_list_production_carrierT
    := fun nt_idx
       => List.map
            (fun p_idx : nat => (nt_idx, (p_idx, 0)))
            (up_to (List.length (Lookup G (rdp_list_to_nonterminal nt_idx)))).

  Definition rdp_list_production_tl : rdp_list_production_carrierT -> rdp_list_production_carrierT
    := (default_production_tl (G := G)).

  Local Ltac t' :=
    idtac;
    match goal with
      | _ => assumption
      | _ => omega
      | _ => congruence
      | _ => discriminate
      | [ H : first_index_error _ _ = Some _ |- _ ] => apply first_index_error_Some_correct in H
      | [ H : first_index_error _ _ = None |- _ ] => rewrite first_index_error_None_correct in H
      | _ => intro
      | [ H : and _ _ |- _ ] => destruct H
      | [ H : ex _ |- _ ] => destruct H
      | [ H : string_beq _ _ = true |- _ ] => apply string_bl in H
      | _ => progress subst
      | [ |- nth _ _ _ = _ ] => apply nth_error_Some_nth
      | [ H : ?T |- _ <-> ?T ] => split; [ intro; assumption | intro ]
      | [ H : is_true (list_bin _ _ _) |- _ ] => apply (list_in_bl (@beq_nat_true)) in H
      | [ |- is_true (list_bin _ _ _) ] => apply list_in_lb; [ intros ???; subst; symmetry; apply beq_nat_refl | ]
      | [ H : In _ (up_to _) |- _ ] => apply in_up_to_iff in H
      | [ |- In _ (up_to _) ] => apply in_up_to_iff
      | [ H : In ?nt _ |- _ ] => let H' := fresh in assert (H' : string_beq nt nt = false) by eauto; exfalso; clear -H'
      | [ H : context[string_beq ?x ?x] |- _ ] => rewrite (string_lb eq_refl) in H
      | [ |- _ <-> _ ] => split
      | [ |- In (nth _ ?ls _) ?ls ] => apply nth_In; assumption
      | [ H : nth_error _ _ = Some _ |- _ ]
        => let H' := fresh in
           pose proof H as H';
             apply nth_error_In in H;
             apply nth_error_Some_short in H'
      | [ |- ?x < ?y ] => destruct (le_lt_dec y x); [ exfalso | assumption ]
      | [ H : context[nth ?nt ?ls ?d] |- _ ]
        => rewrite nth_overflow in H by assumption
      | [ H : In some_invalid_nonterminal _ |- _ ]
        => apply some_invalid_nonterminal_invalid in H
      | _ => progress simpl in *
      | [ |- In (nth _ (uniquize ?beq ?ls) _) ?ls ]
        => apply (uniquize_In _ beq)
      | [ H : In ?x (uniquize ?beq ?ls) |- In ?x ?ls ]
        => eapply uniquize_In; eexact H
      | [ H : forall elem, In elem (uniquize ?beq ?ls) -> ?beq ?nt elem = false,
            H' : In ?nt ?ls
            |- _ ]
        => exfalso; specialize (H nt)
      | _ => progress specialize_by (apply uniquize_In_refl; first [ apply string_lb; reflexivity | apply @string_bl | assumption ])
    end.

  Local Ltac t := repeat t'.

  Definition rdp_list_initial_nonterminals_correct'
  : forall nt,
      is_true (rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data nt) <-> List.In (rdp_list_to_nonterminal nt) (Valid_nonterminals G).
  Proof.
    fix_list_bin_eq.
    unfold rdp_list_is_valid_nonterminal, rdp_list_to_nonterminal, rdp_list_initial_nonterminals_data, default_to_nonterminal.
    intro nt.
    t.
  Qed.

  Definition rdp_list_initial_nonterminals_correct
  : forall nt,
      is_true (rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data (rdp_list_of_nonterminal nt)) <-> List.In nt (Valid_nonterminals G).
  Proof.
    fix_list_bin_eq.
    unfold rdp_list_is_valid_nonterminal, rdp_list_of_nonterminal, rdp_list_initial_nonterminals_data, default_of_nonterminal.
    intro nt.
    rewrite first_index_default_first_index_error.
    destruct (first_index_error (string_beq nt) valid_nonterminals) eqn:H'; t.
  Qed.

  Lemma rdp_list_find_to_nonterminal idx
  : List.first_index_error
      (string_beq (rdp_list_to_nonterminal idx))
      valid_nonterminals
    = bool_rect
        (fun _ => option _)
        (Some idx)
        (None)
        (Compare_dec.leb (S idx) (List.length valid_nonterminals)).
  Proof.
    apply default_find_to_nonterminal.
  Qed.

  Lemma rdp_list_to_of_nonterminal
  : forall nt,
      List.In nt (Valid_nonterminals G)
      -> rdp_list_to_nonterminal (rdp_list_of_nonterminal nt) = nt.
  Proof.
    unfold rdp_list_to_nonterminal, rdp_list_of_nonterminal, default_to_nonterminal, default_of_nonterminal.
    intro nt.
    rewrite first_index_default_first_index_error.
    destruct (first_index_error (string_beq nt) valid_nonterminals) eqn:H';
      t.
  Qed.

  Lemma rdp_list_of_to_nonterminal
  : forall nt,
      is_true (rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data nt)
      -> rdp_list_of_nonterminal (rdp_list_to_nonterminal nt) = nt.
  Proof.
    pose proof (nonterminals_unique G) as HNoDup.
    hnf in HNoDup.
    simpl in *.
    unfold rdp_list_to_nonterminal, rdp_list_of_nonterminal, rdp_list_is_valid_nonterminal, rdp_list_initial_nonterminals_data, default_to_nonterminal, default_of_nonterminal.
    intros nt H.
    apply (list_in_bl (@beq_nat_true)), in_up_to_iff in H.
    revert nt H.
    replace valid_nonterminals with (uniquize string_beq valid_nonterminals) by (rewrite HNoDup; reflexivity).
    induction valid_nonterminals as [|x xs IHxs].
    { simpl; intros; omega. }
    { simpl in *.
      destruct (list_bin string_beq x (uniquize string_beq xs)) eqn:Hbin; try assumption.
      { apply (f_equal (@List.length _)) in HNoDup.
        simpl in *.
        pose proof (uniquize_shorter xs string_beq) as H'.
        rewrite HNoDup in H'.
        exfalso; clear -H'.
        omega. }
      apply (f_equal (@tl _)) in HNoDup; simpl @tl in HNoDup.
      specialize_by assumption.

      intros [|nt].
      { simpl.
        rewrite (string_lb eq_refl); trivial. }
      { simpl Datatypes.length.
        intro H.
        apply lt_S_n in H.
        etransitivity; [ | eapply (f_equal S), (IHxs _ H); clear IHxs ].
        rewrite first_index_default_S_cons; simpl.
        match goal with
          | [ |- context[string_beq ?x ?y] ]
            => destruct (string_beq x y) eqn:H'
        end; simpl;
        [ exfalso | reflexivity ].
        clear -Hbin H H'.
        apply string_bl in H'.
        subst.
        rewrite list_in_lb in Hbin; [ congruence | apply @string_lb | ].
        apply nth_In; assumption. } }
  Qed.

  Definition rdp_list_production_carrier_valid
  : rdp_list_production_carrierT -> bool
    := default_production_carrier_valid (G := G).

  Lemma rdp_list_production_tl_correct
  : forall p,
      rdp_list_to_production (rdp_list_production_tl p) = tl (rdp_list_to_production p).
  Proof.
    unfold rdp_list_to_production, rdp_list_production_tl, default_production_tl, default_to_production; simpl.
    intros [? [? p]]; rewrite tl_drop; simpl.
    do 2 try
       match goal with
         | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?; simpl
       end;
      repeat match goal with
               | _ => destruct p; reflexivity
               | _ => assumption
               | _ => omega
               | [ H : leb _ _ = false |- _ ] => apply leb_iff_conv in H
               | [ H : ?x < 1 |- _ ] => assert (x = 0) by omega; clear H
               | [ H : ?x = 0 |- context[?x] ] => rewrite H
               | [ H : ?x = nil |- context[?x] ] => rewrite H
               | [ H : List.length ?x = 0 |- _ ] => assert (x = nil) by (destruct x; simpl in *; trivial; discriminate); clear H
               | _ => progress simpl in *
               | _ => reflexivity
               | [ H : _ < S _ |- _ ] => apply le_S_n in H
               | _ => rewrite drop_all by assumption
               | [ |- nil = drop _ _ ] => symmetry; apply drop_all
               | [ |- context[List.length (tl ?x)] ] => destruct x eqn:?
             end.
  Qed.

  Local Arguments List.nth _ !_ !_ _.
  Local Arguments minus !_ !_.

  Lemma rdp_list_nonterminal_to_production_correct
  : forall nt,
      List.In nt (Valid_nonterminals G)
      -> List.map rdp_list_to_production (rdp_list_nonterminal_to_production (rdp_list_of_nonterminal nt))
         = Lookup G nt.
  Proof.
    intros nt Hvalid.
    unfold rdp_list_to_production, rdp_list_nonterminal_to_production, default_to_production.
    rewrite map_map; simpl.
    rewrite !rdp_list_to_of_nonterminal by assumption.
    rewrite <- list_to_productions_to_nonterminal.
    change default_to_nonterminal with rdp_list_to_nonterminal.
    rewrite rdp_list_to_of_nonterminal by assumption.
    induction (Lookup_string G nt) as [|p ps IHps]; simpl.
    { reflexivity. }
    { simpl.
      rewrite minus_diag; simpl.
      apply f_equal.
      etransitivity; [ | apply IHps ]; clear IHps.
      apply map_ext_in.
      intros a H; apply in_up_to_iff in H.
      rewrite NPeano.Nat.sub_succ_r.
      destruct (Datatypes.length ps - a) eqn:H'; try omega; [].
      reflexivity. }
  Qed.

  Lemma rdp_list_production_tl_valid
  : forall p,
      rdp_list_production_carrier_valid p -> rdp_list_production_carrier_valid (rdp_list_production_tl p).
  Proof.
    unfold rdp_list_production_carrier_valid, default_production_carrier_valid, rdp_list_production_tl, default_production_tl; simpl; trivial.
    repeat match goal with
             | _ => progress simpl in *
             | _ => intro
             | _ => progress unfold is_true in *
             | [ |- andb ?x ?y = true ] => apply Bool.andb_true_iff
             | [ H : andb ?x ?y = true |- _ ] => apply Bool.andb_true_iff in H
             | [ H : and _ _ |- _ ] => destruct H
             | [ H : ?x = true |- context[?x] ] => rewrite H
             | [ |- ?x = ?x ] => reflexivity
             | [ |- and _ _ ] => split
             | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
           end.
  Qed.

  Local Arguments leb !_ !_.

  Lemma rdp_list_nonterminal_to_production_valid
  : forall nt,
      rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data nt
      -> List.Forall rdp_list_production_carrier_valid (rdp_list_nonterminal_to_production nt).
  Proof.
    unfold rdp_list_production_carrier_valid, rdp_list_is_valid_nonterminal, rdp_list_initial_nonterminals_data, rdp_list_nonterminal_to_production.
    intros nt Hnt.
    apply Forall_map, Forall_forall; unfold compose; simpl; intros ? H.
    fix_list_bin_eq.
    apply list_in_bl in Hnt; [ | exact (EqNat.beq_nat_true) ].
    apply in_up_to_iff in Hnt.
    unfold default_production_carrier_valid; simpl.
    repeat (apply Bool.andb_true_iff; split); apply leb_iff.
    { rewrite map_length in Hnt.
      exact Hnt. }
    { apply in_up_to_iff in H.
      rewrite <- list_to_productions_to_nonterminal.
      exact H. }
    { omega. }
  Qed.

  Lemma rdp_list_production_carrier_valid_reachable (idx : rdp_list_production_carrierT)
        (Hvalid : rdp_list_production_carrier_valid idx)
  : production_is_reachable G (rdp_list_to_production idx).
  Proof.
    unfold production_is_reachable, rdp_list_production_carrier_valid, default_production_carrier_valid, rdp_list_production_carrierT in *.
    repeat setoid_rewrite Bool.andb_true_iff in Hvalid.
    repeat setoid_rewrite Compare_dec.leb_iff in Hvalid.
    destruct_head and.
    simpl in *.
    exists (rdp_list_to_nonterminal (fst idx)).
    unfold rdp_list_to_production, default_to_production in *; simpl in *.
    match goal with
      | [ |- context[In (_ ++ Operations.List.drop ?n ?ls)%list _] ]
        => exists (Operations.List.take n ls)
    end.
    rewrite app_take_drop.
    split.
    { apply rdp_list_initial_nonterminals_correct'.
      unfold rdp_list_is_valid_nonterminal, rdp_list_initial_nonterminals_data.
      fix_list_bin_eq.
      apply list_in_lb; [ apply beq_nat_true_iff | ].
      rewrite map_length.
      apply in_up_to; assumption. }
    { unfold rdp_list_to_nonterminal.
      rewrite list_to_productions_to_nonterminal.
      destruct (Lookup_idx G (fst idx)) eqn:Heq.
      { simpl in *.
        omega. }
      { apply nth_In.
        simpl; omega. } }
  Qed.

  Definition filter_out_eq nt ls
    := Eval unfold filter_out in filter_out (EqNat.beq_nat nt) ls.

  Definition rdp_list_remove_nonterminal : rdp_list_nonterminals_listT -> rdp_list_nonterminal_carrierT -> rdp_list_nonterminals_listT
    := fun ls nt =>
         filter_out_eq nt ls.

  Local Ltac fix_filter_out_eq :=
    unfold rdp_list_remove_nonterminal;
    change filter_out_eq with (fun nt ls => filter_out (EqNat.beq_nat nt) ls); cbv beta;
    setoid_rewrite filter_out_filter.

  Local Ltac fix_eqs := try fix_filter_out_eq; try fix_list_bin_eq.

  Definition rdp_list_nonterminals_listT_R : rdp_list_nonterminals_listT -> rdp_list_nonterminals_listT -> Prop
    := ltof _ (@List.length _).
  Lemma filter_list_dec {T} f (ls : list T) : List.length (filter f ls) <= List.length ls.
  Proof.
    induction ls; trivial; simpl in *.
    repeat match goal with
             | [ |- context[if ?a then _ else _] ] => destruct a; simpl in *
             | [ |- S _ <= S _ ] => solve [ apply Le.le_n_S; auto ]
             | [ |- _ <= S _ ] => solve [ apply le_S; auto ]
           end.
  Qed.
  Lemma rdp_list_remove_nonterminal_dec : forall ls prods,
                                            @rdp_list_is_valid_nonterminal ls prods = true
                                            -> @rdp_list_nonterminals_listT_R (@rdp_list_remove_nonterminal ls prods) ls.
  Proof.
    intros ls prods H.
    unfold rdp_list_is_valid_nonterminal, rdp_list_nonterminals_listT_R, rdp_list_remove_nonterminal, ltof in *.
    fix_eqs.
    apply list_in_bl in H; [ | solve [ intros; apply beq_nat_true; trivial ] ].
    match goal with
      | [ H : In ?prods ?ls |- context[filter ?f ?ls] ]
        => assert (~In prods (filter f ls))
    end.
    { intro H'.
      apply filter_In in H'.
      destruct H' as [? H'].
      rewrite <- beq_nat_refl in H'.
      simpl in *; congruence. }
    { match goal with
        | [ |- context[filter ?f ?ls] ] => generalize dependent f; intros
      end.
      induction ls; simpl in *; try congruence.
      repeat match goal with
               | [ |- context[if ?x then _ else _] ] => destruct x; simpl in *
               | [ H : _ \/ _ |- _ ] => destruct H
               | _ => progress subst
               | [ H : ~(_ \/ _) |- _ ] => apply Decidable.not_or in H
               | [ H : _ /\ _ |- _ ] => destruct H
               | [ H : ?x <> ?x |- _ ] => exfalso; apply (H eq_refl)
               | _ => apply Lt.lt_n_S
               | _ => apply Le.le_n_S
               | _ => apply filter_list_dec
               | [ H : _ -> _ -> ?G |- ?G ] => apply H; auto
             end. }
  Qed.
  Lemma rdp_list_ntl_wf : well_founded rdp_list_nonterminals_listT_R.
  Proof.
    unfold rdp_list_nonterminals_listT_R.
    intro.
    apply well_founded_ltof.
  Defined.

  Lemma rdp_list_remove_nonterminal_1
  : forall ls ps ps',
      rdp_list_is_valid_nonterminal (rdp_list_remove_nonterminal ls ps) ps' = true
      -> rdp_list_is_valid_nonterminal ls ps' = true.
  Proof.
    unfold rdp_list_is_valid_nonterminal, rdp_list_remove_nonterminal.
    fix_eqs.
    repeat match goal with
             | _ => exfalso; congruence
             | _ => reflexivity
             | _ => assumption
             | [ |- context[if ?E then _ else _] ] => destruct E
             | _ => intro
             | [ H : In _ (filter _ _) |- _ ] => apply filter_In in H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ H : ?T, H' : ~?T |- _ ] => destruct (H' H)
             | [ H : list_bin _ _ _ = true |- _ ] => apply list_in_bl in H; [ | solve [ intros; apply beq_nat_true; trivial ] ]
             | [ |- list_bin _ _ _ = true ] => apply list_in_lb
             | _ => progress subst
             | [ |- context[beq_nat ?x ?x] ] => rewrite <- beq_nat_refl
           end.
  Qed.

  Lemma rdp_list_remove_nonterminal_2
  : forall ls ps ps',
      rdp_list_is_valid_nonterminal (rdp_list_remove_nonterminal ls ps) ps' = false
      <-> rdp_list_is_valid_nonterminal ls ps' = false \/ ps = ps'.
  Proof.
    unfold rdp_list_is_valid_nonterminal, rdp_list_remove_nonterminal.
    fix_eqs.
    repeat match goal with
             | _ => exfalso; congruence
             | _ => reflexivity
             | _ => progress subst
             | _ => intro
             | [ H : @eq bool ?x ?y -> False |- _ ] => apply Bool.eq_true_not_negb in H
             | [ H : context[In _ (filter _ _)] |- _ ] => rewrite filter_In in H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ H : ?T, H' : ~?T |- _ ] => destruct (H' H)
             | [ |- true = false \/ _ ] => right
             | [ |- ?x = ?x \/ _ ] => left; reflexivity
             | [ H : ~(_ /\ ?x = ?x) |- _ ] => specialize (fun y => H (conj y eq_refl))
             | [ H : ~(?T /\ _), H' : ?T |- _ ] => specialize (fun y => H (conj H' y))
             | [ H : (?T /\ _) -> False, H' : ?T |- _ ] => specialize (fun y => H (conj H' y))
             | [ H : _ \/ _ |- _ ] => destruct H
             | [ |- _ <-> _ ] => split
             | [ H : context[match ?E with left _ => _ | right _ => _ end] |- _ ] => destruct E
             | [ |- context[match ?E with left _ => _ | right _ => _ end] ] => destruct E
             | [ H : _ |- _ ] => rewrite Bool.negb_involutive in H
             | [ H : string_beq _ _ = true |- _ ] => apply string_bl in H
             | [ H : context[string_beq ?x ?x] |- _ ] => rewrite (string_lb (eq_refl x)) in H
             | _ => progress simpl in *
             | [ H : list_bin _ _ _ = true |- _ ] => apply list_in_bl in H; [ | solve [ intros; apply beq_nat_true; trivial ] ]
             | [ |- list_bin _ _ _ = true ] => apply list_in_lb
             | [ |- context[list_bin ?x ?y ?z = false] ] => case_eq (list_bin x y z)
             | [ H : list_bin _ _ _ = false |- _ ] => apply Bool.not_true_iff_false in H
             | [ H : list_bin _ _ _ <> true |- _ ] => specialize (fun pf H' => H (list_in_lb pf H'))
             | [ H : ?A -> ?B |- _ ]
               => let H' := fresh in
                  assert (H' : A) by (intros; subst; rewrite <- ?beq_nat_refl; reflexivity);
                    specialize (H H'); clear H'
             | [ H : beq_nat _ _ = true |- _ ] => apply beq_nat_true in H
             | [ H : context[beq_nat ?x ?x] |- _ ] => rewrite <- beq_nat_refl in H
           end.
  Qed.

  Lemma rdp_list_remove_nonterminal_noninc (ls : rdp_list_nonterminals_listT) nonterminal
  : ~ rdp_list_nonterminals_listT_R ls (rdp_list_remove_nonterminal ls nonterminal).
  Proof.
    simpl. unfold ltof, rdp_list_remove_nonterminal.
    fix_eqs.
    intro H.
    cut (Datatypes.length ls < Datatypes.length ls); try omega.
    eapply Lt.lt_le_trans; [ eassumption | ].
    apply filter_list_dec.
  Qed.

  Lemma rdp_list_nonterminals_length_zero
  : forall ls,
      List.length ls = 0
      -> forall nt, rdp_list_is_valid_nonterminal ls nt = false.
  Proof.
    destruct ls; simpl; trivial; intro; exfalso; omega.
  Qed.

  Lemma rdp_list_is_valid_nonterminal_nth_error
        nt_idx
    : rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data nt_idx
      <-> nth_error (pregrammar_productions G) nt_idx <> None.
  Proof.
    unfold rdp_list_is_valid_nonterminal; fix_eqs.
    transitivity (List.In nt_idx rdp_list_initial_nonterminals_data).
    { split; intro H.
      { apply list_in_bl in H; [ assumption | apply Nat.eqb_eq ]. }
      { apply list_in_lb; [ apply Nat.eqb_eq | assumption ]. } }
    unfold rdp_list_initial_nonterminals_data.
    rewrite <- in_up_to_iff, map_length.
    rewrite nth_error_Some; reflexivity.
  Qed.

  Global Instance rdp_list_predata : @parser_computational_predataT Char
    := { nonterminals_listT := rdp_list_nonterminals_listT;
         initial_nonterminals_data := rdp_list_initial_nonterminals_data;
         of_nonterminal := rdp_list_of_nonterminal;
         to_nonterminal := rdp_list_to_nonterminal;
         production_carrierT := rdp_list_production_carrierT;
         to_production := rdp_list_to_production;
         nonterminal_to_production := rdp_list_nonterminal_to_production;
         production_tl := rdp_list_production_tl;
         production_carrier_valid := rdp_list_production_carrier_valid;
         is_valid_nonterminal := rdp_list_is_valid_nonterminal;
         remove_nonterminal := rdp_list_remove_nonterminal;
         nonterminals_length := @List.length _ }.

  Global Instance rdp_list_rdata' : @parser_removal_dataT' _ G rdp_list_predata
    := { nonterminals_length_zero := rdp_list_nonterminals_length_zero;
         remove_nonterminal_dec := rdp_list_remove_nonterminal_dec;
         remove_nonterminal_noninc := rdp_list_remove_nonterminal_noninc;
         to_of_nonterminal := rdp_list_to_of_nonterminal;
         of_to_nonterminal := rdp_list_of_to_nonterminal;
         production_tl_correct := rdp_list_production_tl_correct;
         nonterminal_to_production_correct := rdp_list_nonterminal_to_production_correct;
         production_tl_valid := rdp_list_production_tl_valid;
         nonterminal_to_production_valid := rdp_list_nonterminal_to_production_valid;
         initial_nonterminals_correct := rdp_list_initial_nonterminals_correct;
         initial_nonterminals_correct' := rdp_list_initial_nonterminals_correct';
         remove_nonterminal_1 := rdp_list_remove_nonterminal_1;
         remove_nonterminal_2 := rdp_list_remove_nonterminal_2 }.
End recursive_descent_parser_list.


Require Import Coq.Arith.EqNat.
Require Import Coq.Relations.Relations.

Require Import compcert.exportclight.Clightdefs.
Require Import compcert.lib.Axioms.
Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Floats.
Require Import compcert.lib.Maps.
Require Import compcert.common.AST.
Require Import compcert.common.Values.
Require Import compcert.common.Memdata.
Require Import compcert.common.Memtype.
Require Import compcert.common.Memory.
Require Export sepcomp.Address.

Lemma range_dec: forall a b c: Z, {a <= b < c}+{~(a <= b < c)}.
Proof. intros. destruct (zle a b). destruct (zlt b c). left; split; auto.
  right;  omega. right; omega.
Qed.

Require Export msl.eq_dec.

Instance EqDec_ident: EqDec ident := ident_eq.

Instance EqDec_byte: EqDec byte := Byte.eq_dec.

Instance EqDec_type: EqDec type := type_eq.
Instance EqDec_int: EqDec int := Int.eq_dec.
Instance EqDec_int64: EqDec int64 := Int64.eq_dec.
Instance EqDec_float: EqDec float := Float.eq_dec.
Instance EqDec_float32: EqDec float32 := Float32.eq_dec.

Instance EqDec_memval: EqDec memval.
Proof.
 hnf; repeat decide equality; apply eq_dec.
Defined.

Instance EqDec_val: EqDec val.
Proof.
hnf. decide equality; apply eq_dec.
Defined.

Instance EqDec_quantity: EqDec quantity.
Proof.
hnf. decide equality.
Defined.

Definition access_at (m: mem) (loc: address) (k: perm_kind): option permission :=
   PMap.get (fst loc) (Mem.mem_access m) (snd loc) k.

Lemma perm_access: forall m b ofs k p,
    Mem.perm m b ofs k p <-> (Mem.perm_order'' (access_at m (b,ofs) k) (Some p)).
Proof. reflexivity. Qed.

Lemma access_perm: forall m b ofs k p,
  access_at m (b, ofs) k = Some p ->
  Mem.perm m b ofs k p.
Proof.
intros.
unfold Mem.perm, Mem.perm_order'.
unfold access_at in H. simpl in H.
rewrite H; auto.
constructor.
Qed.

Lemma access_cur_max: forall m a,
           Mem.perm_order'' (access_at m a Max)  (access_at m a Cur).
Proof.
 destruct a as [b z].
 destruct (access_at m (b,z) Cur) eqn:Hc.
 rewrite <- perm_access.
 apply (Mem.perm_cur_max m b z).
 rewrite perm_access. rewrite Hc. constructor.
 destruct (access_at m (b, z) Max); constructor.
Qed.

Lemma invalid_noaccess: forall m b ofs k,
     ~Mem.valid_block m b -> access_at m (b, ofs) k = None.
Proof. intros; apply Mem.nextblock_noaccess. assumption. Qed.

Lemma access_empty: forall a k, access_at Mem.empty a k = None.
Proof.
  intros. unfold access_at, Mem.empty; simpl. rewrite PMap.gi. reflexivity.
Qed.

Transparent Mem.alloc.

Theorem alloc_access_other:
  forall m1 lo hi m2 b, Mem.alloc m1 lo hi = (m2, b) ->
  forall b' ofs k,
  b'<>b \/ (ofs < lo \/ ofs >= hi) ->
  access_at m1 (b', ofs) k = access_at m2 (b', ofs) k.
Proof.
 intros.
pose proof (Mem.nextblock_noaccess m1 b ofs k).
pose proof (Mem.alloc_result _ _ _ _ _ H).
unfold access_at; inversion H; clear H; subst; simpl.
destruct (eq_block b' (Mem.nextblock m1)).
destruct H0; try contradiction.
subst b'.
rewrite PMap.gss.
destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; apply H1; apply Plt_strict.
rewrite PMap.gso by auto. auto.
Qed.

Theorem alloc_access_same:
  forall m1 lo hi m2 b, Mem.alloc m1 lo hi = (m2, b) ->
  forall ofs k,
  lo <= ofs < hi -> access_at m2 (b,ofs) k = Some Freeable.
Proof.
 intros.
 inversion H; clear H; subst. unfold access_at; simpl.
 rewrite PMap.gss.
destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
Qed.

Opaque Mem.alloc.
Transparent Mem.free.

Lemma access_free:
  forall m1 b lo hi,
  (forall ofs, lo <= ofs < hi -> access_at m1 (b,ofs) Cur = Some Freeable) ->
  { m2: mem | Mem.free m1 b lo hi = Some m2 }.
Proof.
 intros.
 unfold Mem.free.
 destruct (Mem.range_perm_dec m1 b lo hi Cur Freeable).
 eauto.
 contradiction n; clear n.
 hnf; intros. unfold Mem.perm. unfold access_at in H.
 simpl in H; rewrite H by auto. constructor.
Qed.

Lemma free_access:
  forall m1 b lo hi m2, Mem.free m1 b lo hi = Some m2 ->
  (forall ofs, lo <= ofs < hi ->
      access_at m1 (b,ofs) Cur = Some Freeable /\ access_at m2 (b,ofs) Max = None).
Proof.
 intros.
 unfold Mem.free in H.
 destruct (Mem.range_perm_dec m1 b lo hi Cur Freeable); inversion H; clear H; subst.
 specialize (r _ H0).
 hnf in r.
 unfold access_at. simpl.
 destruct ((Mem.mem_access m1) !! b ofs Cur); try contradiction.
 assert (p=Freeable) by (destruct p; inversion r; auto). subst p.
 split; auto.
 simpl. rewrite PMap.gss.
 destruct (zle lo ofs), (zlt ofs hi); try omega. reflexivity.
Qed.

Lemma free_access_other:
  forall m1 bf lo hi m2, Mem.free m1 bf lo hi = Some m2 ->
  forall b ofs k,
  b <> bf \/ ofs < lo \/ hi <= ofs ->
  access_at m1 (b,ofs) k = access_at m2 (b,ofs) k.
Proof.
 intros.
 unfold Mem.free in H.
 destruct (Mem.range_perm_dec m1 bf lo hi Cur Freeable); inversion H; clear H; subst.
 unfold access_at; simpl.
 destruct (eq_block b bf).
 subst bf; rewrite PMap.gss.
 destruct H0. contradiction H; auto.
 destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
 rewrite PMap.gso by auto. reflexivity.
Qed.

Opaque Mem.free.

Lemma access_drop_1:
  forall m b lo hi p m', Mem.drop_perm m b lo hi p = Some m' ->
  (forall ofs, lo <= ofs < hi ->
     forall k,
     access_at m (b, ofs) k = Some Freeable /\ access_at m' (b, ofs) k = Some p).
Proof.
 intros.
 unfold Mem.drop_perm in H.
 destruct (Mem.range_perm_dec m b lo hi Cur Freeable); inversion H; clear H; subst.
 unfold access_at; simpl.
 rewrite PMap.gss.
 destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
 split; auto.
 specialize (r _ H0). hnf in r. destruct ( (Mem.mem_access m) !! b ofs Cur) eqn:?; try contradiction.
 assert (p0=Freeable) by (destruct p0; inv r; auto). subst.
 pose proof (Mem.access_max m b ofs).
 rewrite Heqo in H.
 destruct k; auto.
 destruct ((Mem.mem_access m) !! b ofs Max); inv H; auto.
Qed.

Lemma access_drop_2:
  forall m b lo hi p,
  (forall ofs, lo <= ofs < hi -> access_at m (b,ofs) Cur = Some Freeable) ->
  { m' | Mem.drop_perm m b lo hi p = Some m' }.
Proof.
 intros.
 unfold Mem.drop_perm.
 destruct (Mem.range_perm_dec m b lo hi Cur Freeable).
 eauto.
 contradiction n; hnf; intros.
 specialize (H _ H0).
 unfold access_at in *.  hnf. simpl in *; rewrite H. constructor.
Qed.

Lemma access_drop_3:
  forall m b lo hi p m', Mem.drop_perm m b lo hi p = Some m' ->
  forall b' ofs k, b' <> b \/ ofs < lo \/ hi <= ofs ->
    access_at m (b', ofs) k = access_at m' (b',ofs) k.
Proof.
 intros.
 unfold Mem.drop_perm in H.
 destruct (Mem.range_perm_dec m b lo hi Cur Freeable); inversion H; clear H; subst.
 unfold access_at; simpl.
 destruct (eq_block b' b).
 subst. rewrite PMap.gss.
 destruct H0.
 contradiction H; auto.
 destruct (zle lo ofs), (zlt ofs hi); try omega; simpl; auto.
 rewrite PMap.gso by auto.
 auto.
Qed.

Lemma storebytes_access:
 forall m1 b ofs bytes m2 (STORE: Mem.storebytes m1 b ofs bytes = Some m2),
  access_at m1 = access_at m2.
Proof.
intros.
apply extensionality ;intros [b' z].
apply extensionality ;intro k.
apply Mem.storebytes_access in STORE.
unfold access_at; f_equal; auto.
Qed.

Lemma store_access:
 forall chunk m1 b ofs v m2 (STORE: Mem.store chunk m1 b ofs v = Some m2),
  access_at m1 = access_at m2.
Proof.
intros.
apply extensionality; intros [b' z'].
apply extensionality ;intro k.
unfold access_at. apply Mem.store_access in STORE. rewrite STORE; auto.
Qed.

Lemma perm_order'_dec_fiddle:
  forall y x, y = Some x ->
     proj_sumbool (Mem.perm_order'_dec y Nonempty) = true.
Proof.
intros. subst. simpl.
unfold Mem.perm_order_dec. destruct x; reflexivity.
Qed.

Lemma access_at_valid_pointer:
  forall m b ofs p, access_at m (b,ofs) Cur = Some p ->
   Mem.valid_pointer m b ofs = true.
Proof.
intros.
unfold access_at, Mem.valid_pointer in *.
simpl in *.
apply perm_order'_dec_fiddle with p.
auto.
Qed.