(** * Definition of a boolean-returning CFG parser-recognizer *)
Require Import Coq.Lists.List Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Arith.Compare_dec Coq.Classes.RelationClasses Coq.Strings.String.
Require Import Coq.omega.Omega.
Require Import ParsingParses.Parsers.ContextFreeGrammar ParsingParses.Parsers.BooleanRecognizer ParsingParses.Parsers.MinimalParse.
Require Import ParsingParses.Parsers.BaseTypes ParsingParses.Parsers.BooleanBaseTypes.
Require Import ParsingParses.Parsers.Splitters.RDPList ParsingParses.Parsers.Splitters.BruteForce.
Require Import ParsingParses.Parsers.MinimalParseOfParse.
Require Import ParsingParses.Parsers.ContextFreeGrammarProperties ParsingParses.Parsers.WellFoundedParse.
Require Import ParsingParses.Common ParsingParses.Common.Wf.
Require Import Coq.Logic.Eqdep_dec.

Local Hint Extern 0 =>
match goal with
  | [ H : false = true |- _ ] => solve [ destruct (Bool.diff_false_true H) ]
  | [ H : true = false |- _ ] => solve [ destruct (Bool.diff_true_false H) ]
end.

Local Coercion is_true : bool >-> Sortclass.

Local Open Scope string_like_scope.

Section sound.
  Section general.
    Context CharType (String : string_like CharType) (G : grammar CharType).
    Context {data : @boolean_parser_dataT CharType String}
            {cdata : @boolean_parser_completeness_dataT' _ String G data}
            {rdata : @parser_removal_dataT' predata}.

    Let P : string -> Prop
      := fun p => is_valid_nonterminal initial_nonterminals_data p = true.

    Section parts.
      Local Hint Constructors parse_of_item parse_of parse_of_production.

      (*Let H_subT valid
        := sub_productions_listT is_valid_nonterminal valid initial_nonterminals_data.*)

      Section item.
        Context (str : StringWithSplitState String split_stateT)
                (str_matches_nonterminal : string -> bool).

        Definition str_matches_nonterminal_soundT
          := forall nonterminal, str_matches_nonterminal nonterminal = true
                          -> parse_of_item _ G str (NonTerminal _ nonterminal).

        Definition str_matches_nonterminal_completeT P str0
          := forall (valid : nonterminals_listT) nonterminal (H_sub : P str0 valid nonterminal),
               minimal_parse_of_item (G := G) str0 valid str (NonTerminal _ nonterminal)
               -> str_matches_nonterminal nonterminal = true.

        Lemma parse_item_sound
              (str_matches_nonterminal_sound : str_matches_nonterminal_soundT)
              (it : item CharType)
        : parse_item str_matches_nonterminal str it = true -> parse_of_item _ G str it.
        Proof.
          unfold parse_item, str_matches_nonterminal_soundT in *.
          repeat match goal with
                   | _ => intro
                   | [ H : context[match ?E with _ => _ end] |- _ ] => atomic E; destruct E
                   | [ |- context[match ?E with _ => _ end] ] => atomic E; destruct E
                   | [ H : _ = true |- _ ] => apply bool_eq_correct in H
                   | [ H : context[match ?E with _ => _ end] |- context[?E] ] => destruct E
                   | _ => progress (simpl in *; subst)
                   | _ => solve [ eauto ]
                   | [ H : StringWithSplitState _ _ |- _ ] => destruct H
                 end.
        Defined.

        Lemma parse_item_complete
              str0
              valid Pv
              (str_matches_nonterminal_complete : str_matches_nonterminal_completeT Pv str0)
              (it : item CharType)
              (Hinit : forall nonterminal,
                         minimal_parse_of_nonterminal (G := G) str0 valid str nonterminal
                         -> Pv str0 valid nonterminal)
        : minimal_parse_of_item (G := G) str0 valid str it
          -> parse_item str_matches_nonterminal str it = true.
        Proof.
          unfold parse_item, str_matches_nonterminal_completeT in *.
          repeat
            repeat
            match goal with
              | _ => intro
              | _ => reflexivity
              | _ => eassumption
              | [ |- _ /\ _ ] => split
              | [ |- ?x < ?x \/ _ ] => right
              | [ H : ?T |- ?T \/ _ ] => left; exact H
              | [ |- ?x = ?x \/ _ ] => left; reflexivity
              | [ |- _ \/ ?x = ?x ] => right; reflexivity
              | [ |- _ = true ] => apply bool_eq_correct
              | [ H : context[?E] |- context[match ?E with _ => _ end] ] => destruct E
              | [ H : minimal_parse_of _ _ _ [] |- _ ] => solve [ inversion H ]
              | [ |- str_matches_nonterminal _ = true ]
                => eapply str_matches_nonterminal_complete; [..| eassumption ]
              | [ H : minimal_parse_of_item _ _ _ (Terminal _) |- _ ] => inversion_clear H
              | [ H : minimal_parse_of_item _ _ _ (NonTerminal _ _) |- _ ] => inversion_clear H
              | [ H : forall nonterminal, _ -> Pv _ _ nonterminal |- Pv _ _ _ ] => eapply H
          end.
        Qed.
      End item.

      Section item_ext.
        Lemma parse_item_ext
              (str : StringWithSplitState String split_stateT)
              (str_matches_nonterminal1 str_matches_nonterminal2 : string -> bool)
              (it : item CharType)
              (ext : forall x, str_matches_nonterminal1 x = str_matches_nonterminal2 x)
        : parse_item str_matches_nonterminal1 str it
          = parse_item str_matches_nonterminal2 str it.
        Proof.
          unfold parse_item.
          destruct it; auto;
          match goal with
            | [ |- context[match ?E with _ => _ end] ] => destruct E
          end;
          auto.
        Qed.
      End item_ext.

      Section production.
        Context (str0 : String)
                (parse_nonterminal : forall (str : StringWithSplitState String split_stateT),
                                str ≤s str0
                                -> string
                                -> bool).

        Definition parse_nonterminal_soundT
          := forall str pf nonterminal,
               @parse_nonterminal str pf nonterminal = true
               -> parse_of_item _ G str (NonTerminal _ nonterminal).

        Definition parse_nonterminal_completeT P
          := forall valid (str : StringWithSplitState String split_stateT) pf nonterminal (H_sub : P str0 valid nonterminal),
               minimal_parse_of_nonterminal (G := G) str0 valid str nonterminal
               -> @parse_nonterminal str pf nonterminal = true.

        Lemma parse_production_sound
                 (parse_nonterminal_sound : parse_nonterminal_soundT)
                 (str : StringWithSplitState String split_stateT) (pf : str ≤s str0)
                 (prod : production CharType)
        : parse_production parse_nonterminal str pf prod = true
          -> parse_of_production _ G str prod.
        Proof.
          revert str pf; induction prod;
          repeat match goal with
                   | _ => intro
                   | _ => progress simpl in *
                   | _ => progress subst
                   | _ => solve [ auto ]
                   | [ H : fold_right orb false (map _ _) = true |- _ ] => apply fold_right_orb_map_sig1 in H
                   | [ H : (_ || _)%bool = true |- _ ] => apply Bool.orb_true_elim in H
                   | [ H : (_ && _)%bool = true |- _ ] => apply Bool.andb_true_iff in H
                   | _ => progress destruct_head sumbool
                   | _ => progress destruct_head and
                   | _ => progress destruct_head prod
                   | _ => progress destruct_head sig
                   | _ => progress destruct_head @StringWithSplitState
                   | _ => progress simpl in *
                   | _ => progress subst
                   | [ H : (_ =s _) = true |- _ ] => apply bool_eq_correct in H
                   | [ H : (_ =s _) = true |- _ ]
                     => let H' := fresh in
                        pose proof H as H';
                          apply bool_eq_correct in H';
                          progress subst
                   | [ |- parse_of_production _ _ (_ ++ Empty _) [?it] ]
                     => constructor
                   | [ |- parse_of_item _ _ ?s _ ]
                     => eapply parse_item_sound with (str := {| string_val := s |});
                       hnf in *; solve [ eauto with nocore ]
                 end.
          { constructor;
            solve [ eapply IHprod; eassumption
                  | eapply parse_item_sound; try eassumption;
                    hnf in parse_nonterminal_sound |- *;
                    apply parse_nonterminal_sound ]. }
        Defined.

        Lemma parse_production_complete
              valid Pv
              (parse_nonterminal_complete : parse_nonterminal_completeT Pv)
              (Hinit : forall str (pf : str ≤s str0) nonterminal,
                         minimal_parse_of_nonterminal (G := G) str0 valid str nonterminal
                         -> Pv str0 valid nonterminal)
              (str : StringWithSplitState String split_stateT) (pf : str ≤s str0)
              (prod : production CharType)
              (split_string_for_production_complete'
               : forall str0 valid (str : StringWithSplitState String split_stateT) (pf : str ≤s str0),
                   Forall_tails
                     (fun prod' =>
                        match prod' return Type with
                          | nil => True
                          | it::its => split_list_completeT (G := G) (valid := valid) (str0 := str0) it its str pf (split_string_for_production it its str)
                        end)
                     prod)
        : minimal_parse_of_production (G := G) str0 valid str prod
          -> parse_production parse_nonterminal str pf prod = true.
        Proof.
          revert valid str Hinit pf; induction prod;
          [
          | specialize (IHprod (fun str0 valid str pf => snd (split_string_for_production_complete' str0 valid str pf))) ];
          repeat match goal with
                   | _ => intro
                   | _ => progress simpl in *
                   | _ => progress subst
                   | _ => progress destruct_head @StringWithSplitState
                   | _ => solve [ auto ]
                   | [ H : fold_right orb false (map _ _) = true |- _ ] => apply fold_right_orb_map_sig1 in H
                   | [ H : (_ || _)%bool = true |- _ ] => apply Bool.orb_true_elim in H
                   | [ H : (_ && _)%bool = true |- _ ] => apply Bool.andb_true_iff in H
                   | [ H : minimal_parse_of_production _ _ _ nil |- _ ] => inversion_clear H
                   | [ |- (_ =s _) = true ] => apply bool_eq_correct
                   | _ => progress destruct_head_hnf sumbool
                   | _ => progress destruct_head_hnf and
                   | _ => progress destruct_head_hnf sig
                   | _ => progress destruct_head_hnf sigT
                   | _ => progress destruct_head_hnf Datatypes.prod
                   | _ => progress simpl in *
                   | _ => progress subst
                   | [ H : (_ =s _) = true |- _ ] => apply bool_eq_correct in H
                   | [ H : (_ =s _) = true |- _ ]
                     => let H' := fresh in
                        pose proof H as H';
                          apply bool_eq_correct in H';
                          progress subst
                   | [ H : minimal_parse_of_production _ _ _ (_::_) |- _ ] => inversion H; clear H; subst
                   | [ H : ?s ≤s _ |- context[split_string_for_production_correct ?it ?p {| string_val := ?s ; state_val := ?st |}] ]
                     => let H' := fresh in
                        pose proof
                             (fun v a b p0 p1 p2
                              => fst (@split_string_for_production_complete' _ v {| string_val := s ; state_val := st |} H) (existT _ (a, b) (p0, p1, p2))) as H';
                          clear split_string_for_production_complete';
                          simpl in H';
                          specialize (fun a b p0 v p1 p2 => H' v a b p0 p1 p2)
                   | [ H : forall a b, is_true (string_val a ++ string_val b =s _ ++ _) -> _ |- _ ]
                     => specialize (fun st0 st1 => H {| state_val := st0 |} {| state_val := st1 |} (proj2 (@bool_eq_correct _ _ _ _) eq_refl))
                   | [ H : forall a b, is_true (a ++ b =s _ ++ _) -> _ |- _ ]
                     => specialize (H _ _ (proj2 (@bool_eq_correct _ _ _ _) eq_refl))
                   | [ H : ?a -> ?b, H' : ?a |- _ ] => specialize (H H')
                   | [ H : forall v : nonterminals_listT, @?a v -> @?b v |- _ ]
                     => pose proof (H valid); pose proof (H initial_nonterminals_data); clear H
                   | [ |- fold_right orb false (map _ _) = true ] => apply fold_right_orb_map_sig2
                   | [ H : minimal_parse_of_item _ _ _ _ |- _ ] => inversion H; clear H; subst
                   | [ |- (_ =s _) = true ] => apply bool_eq_correct
                 end;
          (lazymatch goal with
            | [ H : In (?s1, ?s2) (split_string_for_production ?it ?prod {| string_val := ?str ; state_val := ?st |})
                |- { x : { s1s2 : _ | (?f (fst s1s2) ++ ?f (snd s1s2) =s ?str) = true } | _ } ]
              => let H' := fresh in
                 pose proof (proj1 (@Forall_forall _ _ _) (split_string_for_production_correct it prod {| string_val := str ; state_val := st |}) _ H) as H';
                   refine (exist _ (exist _ (s1, s2) _) _);
                   simpl in *
          end);
          repeat match goal with
                   | _ => split
                   | [ |- (_ && _)%bool = true ] => apply Bool.andb_true_iff
                   | [ |- (_ =s _) = true ] => apply bool_eq_correct
                   | [ |- In _ (combine_sig _) ] => apply In_combine_sig
                   | [ IHprod : _ |- _ ] => eapply IHprod; eassumption
                 end;
          eapply parse_nonterminal_complete; [..| eassumption ]; simpl;
          repeat match goal with
                   | _ => eassumption
                   | _ => reflexivity
                   | [ |- Pv _ _ _ ] => eapply Hinit; [ .. | eassumption ]
                   | _ => etransitivity; [ | eassumption ];
                          solve [ apply str_le1_append
                                | apply str_le2_append ]
                 end.
          Grab Existential Variables.
          assumption.
          assumption.
        Qed.
      End production.

      Section production_ext.
        Lemma parse_production_ext
              (str0 : String)
              (parse_nonterminal1 parse_nonterminal2 : forall (str : StringWithSplitState String split_stateT),
                                           str ≤s str0
                                           -> string
                                           -> bool)
              (str : StringWithSplitState String split_stateT) (pf : str ≤s str0) (prod : production CharType)
              (ext : forall str' pf' nonterminal', parse_nonterminal1 str' pf' nonterminal'
                                            = parse_nonterminal2 str' pf' nonterminal')
        : parse_production parse_nonterminal1 str pf prod
          = parse_production parse_nonterminal2 str pf prod.
        Proof.
          revert str pf.
          induction prod as [|? ? IHprod]; simpl; intros; try reflexivity; [].
          f_equal.
          apply map_ext; intros.
          apply f_equal2; [ apply parse_item_ext | apply IHprod ].
          intros; apply ext.
        Qed.
      End production_ext.

      Section productions.
        Context (str0 : String)
                (parse_nonterminal : forall (str : StringWithSplitState String split_stateT),
                                str ≤s str0
                                -> string
                                -> bool).

        Local Ltac parse_productions_t :=
          repeat match goal with
                   | _ => intro
                   | [ H : (_ || _)%bool = true |- _ ] => apply Bool.orb_true_elim in H
                   | [ H : (_ && _)%bool = true |- _ ] => apply Bool.andb_true_iff in H
                   | [ |- (_ || _)%bool = true ] => apply Bool.orb_true_iff
                   | [ |- (_ =s _) = true ] => apply bool_eq_correct
                   | [ H : (_ =s _) = true |- _ ] => apply bool_eq_correct in H
                   | _ => progress destruct_head_hnf sumbool
                   | _ => progress destruct_head_hnf and
                   | _ => progress destruct_head_hnf sig
                   | _ => progress destruct_head_hnf sigT
                   | _ => progress destruct_head_hnf Datatypes.prod
                   | _ => progress simpl in *
                   | _ => progress subst
                   | [ H : parse_of _ _ _ nil |- _ ] => solve [ inversion H ]
                   | [ H : parse_of _ _ _ (_::_) |- _ ] => inversion H; clear H; subst
                   | [ H : minimal_parse_of _ _ _ nil |- _ ] => solve [ inversion H ]
                   | [ H : minimal_parse_of _ _ _ (_::_) |- _ ] => inversion H; clear H; subst
                   | [ H : parse_production _ _ _ _ = true |- _ ] => apply parse_production_sound with (str := {| string_val := _ |}) in H; try eassumption; []
                   | _ => left; eapply parse_production_complete; eassumption
                   | _ => solve [ eauto ]
                 end.

        Lemma parse_productions_sound
                 (parse_nonterminal_sound : parse_nonterminal_soundT parse_nonterminal)
                 (str : StringWithSplitState String split_stateT) (pf : str ≤s str0)
                 (prods : productions CharType)
        : parse_productions parse_nonterminal str pf prods = true
          -> parse_of _ G str prods.
        Proof.
          destruct str as [str st]; simpl in *.
          revert str pf st; induction prods; simpl.
          { unfold parse_productions; simpl; intros ??? H; exfalso; clear -H.
            abstract discriminate. }
          { unfold parse_productions in *; simpl in *.
            parse_productions_t. }
        Defined.

        Lemma parse_productions_complete
              valid Pv
              (parse_nonterminal_complete : parse_nonterminal_completeT parse_nonterminal Pv)
              (Hinit : forall str (pf : str ≤s str0) nonterminal,
                         minimal_parse_of_nonterminal (G := G) str0 valid str nonterminal
                         -> Pv str0 valid nonterminal)
              (str : StringWithSplitState String split_stateT) (pf : str ≤s str0)
              (prods : productions CharType)
              (split_string_for_production_complete'
               : forall str0 valid (str : StringWithSplitState String split_stateT) (pf : str ≤s str0),
                   ForallT
                     (Forall_tails
                        (fun prod' =>
                           match prod' return Type with
                             | nil => True
                             | it::its => split_list_completeT (G := G) (valid := valid) (str0 := str0) it its str pf (split_string_for_production it its str)
                           end))
                     prods)
        : minimal_parse_of (G := G) str0 valid str prods
          -> parse_productions parse_nonterminal str pf prods = true.
        Proof.
          destruct str as [str st]; simpl in *.
          revert str pf st; induction prods; simpl.
          { unfold parse_productions; simpl; intros ??? H; exfalso; clear -H.
            abstract inversion H. }
          { specialize (IHprods (fun str0 valid str pf => snd (split_string_for_production_complete' str0 valid str pf))).
            pose proof (fun str0 valid str pf => fst (split_string_for_production_complete' str0 valid str pf)) as split_string_for_production_complete''.
            clear split_string_for_production_complete'.
            unfold parse_productions in *; simpl in *.
            parse_productions_t. }
        Defined.
      End productions.

      Section productions_ext.
        Lemma parse_productions_ext
              (str0 : String)
              (parse_nonterminal1 parse_nonterminal2 : forall (str : StringWithSplitState String split_stateT),
                                           str ≤s str0
                                           -> string
                                           -> bool)
              (str : StringWithSplitState String split_stateT) (pf : str ≤s str0) (prods : productions CharType)
              (ext : forall str' pf' nonterminal', parse_nonterminal1 str' pf' nonterminal'
                                            = parse_nonterminal2 str' pf' nonterminal')
        : parse_productions parse_nonterminal1 str pf prods
          = parse_productions parse_nonterminal2 str pf prods.
        Proof.
          revert str pf.
          induction prods as [|? ? IHprod]; simpl; intros; try reflexivity; [].
          unfold parse_productions; simpl.
          apply f_equal2; [ apply parse_production_ext | apply IHprod ].
          intros; apply ext.
        Qed.
      End productions_ext.

      Section nonterminals.
        Section step.
          Context (str0 : String) (valid : nonterminals_listT)
                  (parse_nonterminal
                   : forall (p : String * nonterminals_listT),
                       prod_relation (ltof _ Length) nonterminals_listT_R p (str0, valid)
                       -> forall str : StringWithSplitState String split_stateT, str ≤s fst p -> string -> bool).

          Lemma parse_nonterminal_step_sound
                (parse_nonterminal_sound : forall p pf, parse_nonterminal_soundT (@parse_nonterminal p pf))
                (str : StringWithSplitState String split_stateT) (pf : str ≤s str0) (nonterminal : string)
          : parse_nonterminal_step (G := G) parse_nonterminal _ pf nonterminal
            = true
            -> parse_of_item _ G str (NonTerminal _ nonterminal).
          Proof.
            unfold parse_nonterminal_step.
            intro H'; constructor; revert H'.
            edestruct lt_dec as [|n].
            { intro H'.
              apply parse_productions_sound in H'; trivial. }
            { edestruct dec; [ | intro H''; exfalso; clear -H'';
                                 abstract discriminate ].
              pose proof (strle_to_sumbool _ pf) as pf'.
              destruct pf' as [pf'|]; subst.
              { destruct (n pf'). }
              { intro H'.
                apply parse_productions_sound in H'; trivial;
                destruct_head @StringWithSplitState; subst; trivial. } }
          Defined.

          Lemma parse_nonterminal_step_complete
                Pv
                (parse_nonterminal_complete : forall p pf, parse_nonterminal_completeT (@parse_nonterminal p pf) (Pv p))
                (str : StringWithSplitState String split_stateT) (pf : str ≤s str0) (nonterminal : string)
                (Hnt : is_valid_nonterminal initial_nonterminals_data nonterminal)
                (Hinit : forall str1,
                           str1 ≤s str ->
                           forall nonterminal0,
                             minimal_parse_of_nonterminal (G := G) str initial_nonterminals_data str1 nonterminal0 ->
                             Pv (str : String, initial_nonterminals_data) str initial_nonterminals_data nonterminal0)
                (Hinit' : forall str,
                            str ≤s str0 ->
                            forall nonterminal0 : string,
                              minimal_parse_of_nonterminal (G := G)
                                                    str0 (remove_nonterminal valid nonterminal) str nonterminal0 ->
                              Pv (str0, remove_nonterminal valid nonterminal) str0 (remove_nonterminal valid nonterminal) nonterminal0)
          : minimal_parse_of_nonterminal (G := G) str0 valid str nonterminal
            -> parse_nonterminal_step (G := G) parse_nonterminal _ pf nonterminal
            = true.
          Proof.
            unfold parse_nonterminal_step.
            edestruct lt_dec as [|n].
            { intros H'.
              inversion H'; clear H'; subst. (* Work around Anomaly: Evar ?425 was not declared. Please report. *)
              { eapply parse_productions_complete; [ .. | eassumption ];
                trivial.
                intros; apply split_string_for_production_complete; assumption. }
              { destruct_head @StringWithSplitState; subst.
                match goal with
                  | [ H : ?x < ?x |- _ ] => exfalso; clear -H; abstract omega
                end. } }
            { destruct pf as [pf|]; subst.
              { destruct (n pf). }
              { edestruct dec as [|pf']; simpl.
                { intro H'.
                  inversion_clear H'.
                  { match goal with
                      | [ H : ?T, H' : ~?T |- _ ] => destruct (H' H)
                    end. }
                  { let H' := match goal with H : minimal_parse_of _ _ _ _ |- _ => constr:H end in
                    eapply parse_productions_complete in H'; eauto.
                    eapply (@parse_nonterminal_complete (_, _)).
                    intros; apply split_string_for_production_complete; assumption. } }
                { intro H''; exfalso; clear -n H'' pf'.
                  abstract (
                      inversion_clear H'';
                      (omega || congruence)
                    ). } } }
          Qed.
        End step.

        Section step_extensional.
          Lemma parse_nonterminal_step_ext (str0 : String) (valid : nonterminals_listT)
                (parse_nonterminal1 parse_nonterminal2: forall (p : String * nonterminals_listT),
                                            prod_relation (ltof _ Length) nonterminals_listT_R p (str0, valid)
                                            -> forall str : StringWithSplitState String split_stateT, str ≤s fst p -> string -> bool)
                (str : StringWithSplitState String split_stateT) (pf : str ≤s str0) (nonterminal : string)
                (ext : forall p pf0 str' pf' nonterminal', parse_nonterminal1 p pf0 str' pf' nonterminal'
                                                    = parse_nonterminal2 p pf0 str' pf' nonterminal')
          : parse_nonterminal_step (G := G) parse_nonterminal1 _ pf nonterminal
            = parse_nonterminal_step (G := G) parse_nonterminal2 _ pf nonterminal.
          Proof.
            unfold parse_nonterminal_step.
            edestruct lt_dec.
            { apply parse_productions_ext; auto. }
            { edestruct dec; trivial.
              apply parse_productions_ext; auto. }
          Qed.
        End step_extensional.

        Section wf.
          Lemma parse_nonterminal_or_abort_sound
                (p : String * nonterminals_listT) (str : StringWithSplitState String split_stateT)
                (pf : str ≤s fst p)
                (nonterminal : string)
          : parse_nonterminal_or_abort (G := G) p _ pf nonterminal
            = true
            -> parse_of_item _ G str (NonTerminal _ nonterminal).
          Proof.
            unfold parse_nonterminal_or_abort.
            revert str pf nonterminal.
            let Acca := match goal with |- context[@Fix3 _ _ _ _ _ ?Rwf _ _ ?a _ _ _] => constr:(Rwf a) end in
            induction (Acca) as [? ? IHr];
              intros str pf nonterminal.
            rewrite Fix3_eq.
            { apply parse_nonterminal_step_sound; assumption. }
            { intros.
              apply parse_nonterminal_step_ext.
              trivial. }
          Defined.

          Lemma prod_relation_elim_helper {A R x} {valid : A}
          : prod_relation (ltof String Length) R
                          (fst x, valid) x
            -> R valid (snd x).
          Proof.
            intros [ H | [? H] ].
            { exfalso; simpl in *; clear -H.
              unfold ltof in H; simpl in H.
              abstract omega. }
            { exact H. }
          Qed.

          Lemma parse_nonterminal_or_abort_complete
                (Pv := fun (p : String * nonterminals_listT)
                           (str0 : String) (valid0 : nonterminals_listT) (nt : string) =>
                         is_valid_nonterminal initial_nonterminals_data nt
                         /\ sub_nonterminals_listT valid0 (snd p)
                         /\ sub_nonterminals_listT (snd p) initial_nonterminals_data)
                (p : String * nonterminals_listT)
          : @parse_nonterminal_completeT
              (fst p)
              (parse_nonterminal_or_abort (G := G) p)
              (Pv p).
          Proof.
            unfold parse_nonterminal_or_abort.

            let Acca := match goal with |- context[@Fix3 _ _ _ _ _ ?Rwf _ _ ?a] => constr:(Rwf a) end in
            induction (Acca) as [x ? IHr];
              intros valid str pf nonterminal ?.
            rewrite Fix3_eq;
              [
              | solve [ intros;
                        apply parse_nonterminal_step_ext;
                        trivial ] ].
            match goal with
              | [ H : appcontext[?f]
                  |- _ -> parse_nonterminal_step (fun y _ b c d => ?f y b c d) _ _ _ = true ]
                => revert H;
                  generalize f;
                  let H' := fresh "parse_nonterminal_step'" in
                  intros H' H
            end.
            destruct_head_hnf and.
            intro; eapply parse_nonterminal_step_complete with (Pv := Pv); subst Pv;
            [ intros; eapply IHr | .. ];
            instantiate;
            trivial; simpl in *;
            try solve [ assumption
                      | intros; reflexivity
                      | intros; repeat split; reflexivity
                      | intros; repeat split;
                        try inversion_one_head @minimal_parse_of_nonterminal;
                        try solve [ reflexivity
                                  | assumption
                                  | etransitivity; [ apply sub_nonterminals_listT_remove; apply remove_nonterminal_1 | assumption ] ] ];
            [].
            { eapply @expand_minimal_parse_of_nonterminal; [ .. | eassumption ];
              trivial;
              try solve [ reflexivity
                        | apply remove_nonterminal_1
                        | apply remove_nonterminal_2 ]. }
          Defined.

          Lemma parse_nonterminal_sound
                (str : StringWithSplitState String split_stateT) (nonterminal : string)
          : parse_nonterminal (G := G) str nonterminal
            = true
            -> parse_of_item _ G str (NonTerminal _ nonterminal).
          Proof.
            unfold parse_nonterminal, parse_nonterminal_or_abort.
            apply parse_nonterminal_or_abort_sound.
          Defined.

          Lemma parse_nonterminal_complete'
                (str : StringWithSplitState String split_stateT)
                (nonterminal : string)
                (H_init : is_valid_nonterminal initial_nonterminals_data nonterminal)
          : minimal_parse_of_nonterminal (G := G) str initial_nonterminals_data str nonterminal
            -> parse_nonterminal (G := G) str nonterminal
               = true.
          Proof.
            unfold parse_nonterminal.
            eapply (@parse_nonterminal_or_abort_complete
                    (str : String, initial_nonterminals_data)).
            repeat split; try reflexivity; assumption.
          Defined.

          Lemma parse_nonterminal_complete
                (str : StringWithSplitState String split_stateT)
                (nonterminal : string)
                (p : parse_of _ G str (Lookup G nonterminal))
                (H_valid_tree : Forall_parse_of_item
                                  (fun _ p =>
                                     is_valid_nonterminal initial_nonterminals_data p = true) (ParseNonTerminal _ p))
          : parse_nonterminal (G := G) str nonterminal = true.
          Proof.
            apply parse_nonterminal_complete'; try assumption.
            { exact (fst H_valid_tree). }
            { pose proof (@minimal_parse_of_nonterminal__of__parse_of_nonterminal
                            _ String G
                            _
                            _
                            (S (size_of_parse_item (ParseNonTerminal _ p)))
                            str str
                            initial_nonterminals_data
                            nonterminal
                            p
                            (Lt.lt_n_Sn _)
                            (reflexivity _)
                            (reflexivity _)
                            H_valid_tree)
                as p'.
              destruct p' as [ [ p' ] | [ nonterminal' [ [ H0 H1 ] ] ] ].
              { exact p'. }
              { exfalso; congruence. } }
          Qed.
        End wf.
      End nonterminals.
    End parts.
  End general.
End sound.

Section correct.
  Context {CharType} {String : string_like CharType} {G : grammar CharType}.
  Context `{cdata : @boolean_parser_correctness_dataT _ String G}.
  Context (str : StringWithSplitState String split_stateT)
          (nt : string).

  Definition parse_nonterminal_correct
  : (parse_nonterminal (G := G) str nt -> parse_of_item String G str (NonTerminal _ nt))
    * (forall p : parse_of String G str (G nt),
         Forall_parse_of_item
           (fun _ nt => is_valid_nonterminal initial_nonterminals_data nt)
           (ParseNonTerminal _ p)
         -> parse_nonterminal (G := G) str nt).
  Proof.
    split.
    { apply parse_nonterminal_sound. }
    { apply parse_nonterminal_complete; exact _. }
  Defined.
End correct.

Section brute_force_make_parse_of.
  Variable G : grammar Ascii.ascii.

  Definition brute_force_parse_sound
             (str : @String Ascii.ascii string_stringlike)
  : brute_force_parse G str = true -> parse_of_item _ G str (NonTerminal _ G).
  Proof.
    unfold brute_force_parse, brute_force_parse_nonterminal.
    apply parse_nonterminal_sound.
  Defined.

  Definition brute_force_parse_complete'
             (str : @String Ascii.ascii string_stringlike)
  : @minimal_parse_of_nonterminal _ _ G (rdp_list_predata (G := G)) str (Valid_nonterminals G) str G
    -> brute_force_parse G str = true.
  Proof.
    unfold brute_force_parse, brute_force_parse_nonterminal.
    simpl; intro.
    eapply parse_nonterminal_complete'; try eassumption; try exact _; try exact rdp_list_rdata'.
    inversion_one_head @minimal_parse_of_nonterminal; assumption.
  Defined.

  Definition brute_force_parse_complete
             (str : @String Ascii.ascii string_stringlike)
             (p : parse_of _ G str G)
             (H_valid_tree : Forall_parse_of_item
                               (fun _ p =>
                                  rdp_list_is_valid_nonterminal (Valid_nonterminals G) p = true) (ParseNonTerminal _ p))
  : brute_force_parse G str = true.
  Proof.
    unfold brute_force_parse, brute_force_parse_nonterminal.
    eapply parse_nonterminal_complete; try eassumption; try exact _; try exact rdp_list_rdata'.
  Qed.
End brute_force_make_parse_of.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import CRelationClasses.
From Equations.Type Require Import Relation Relation_Properties.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config BasicAst Reflect.
From MetaCoq.PCUIC Require Import PCUICAst PCUICOnOne PCUICAstUtils PCUICEquality
     PCUICLiftSubst PCUICUnivSubst PCUICCases PCUICOnFreeVars.

Set Default Goal Selector "!".

Implicit Types (cf : checker_flags).

Definition cumul_predicate (cumul : context -> term -> term -> Type) Γ Re p p' :=
  All2 (cumul Γ) p.(pparams) p'.(pparams) *
  (R_universe_instance Re p.(puinst) p'.(puinst) *
  ((eq_context_gen eq eq p.(pcontext) p'.(pcontext)) *
    cumul (Γ ,,, inst_case_predicate_context p) p.(preturn) p'.(preturn))).

Reserved Notation " Σ ;;; Γ ⊢ t ≤s[ pb ] u" (at level 50, Γ, t, u at next level,
  format "Σ  ;;;  Γ  ⊢  t  ≤s[ pb ]  u").

Definition cumul_Ind_univ {cf} (Σ : global_env_ext) pb i napp :=
  R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (IndRef i) napp.

Definition cumul_Construct_univ {cf} (Σ : global_env_ext) pb  i k napp :=
  R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (ConstructRef i k) napp.

(** * Definition of cumulativity and conversion relations *)

Inductive cumulSpec0 {cf : checker_flags} (Σ : global_env_ext) Γ (pb : conv_pb) : term -> term -> Type :=

(* transitivity *)

| cumul_Trans : forall t u v,
    is_closed_context Γ -> is_open_term Γ u ->
    Σ ;;; Γ ⊢ t ≤s[pb] u ->
    Σ ;;; Γ ⊢ u ≤s[pb] v ->
    Σ ;;; Γ ⊢ t ≤s[pb] v

(* symmetry *)

| cumul_Sym : forall t u,
    Σ ;;; Γ ⊢ t ≤s[Conv] u ->
    Σ ;;; Γ ⊢ u ≤s[pb] t

(* reflexivity *)

| cumul_Refl : forall t,
    Σ ;;; Γ ⊢ t ≤s[pb] t

(* Cumulativity rules *)

| cumul_Ind : forall i u u' args args',
    cumul_Ind_univ Σ pb i #|args| u u' ->
    All2 (fun t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) args args' ->
    Σ ;;; Γ ⊢ mkApps (tInd i u) args ≤s[pb] mkApps (tInd i u') args'

| cumul_Construct : forall i k u u' args args',
    cumul_Construct_univ Σ pb i k #|args| u u' ->
    All2 (fun t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) args args' ->
    Σ ;;; Γ ⊢ mkApps (tConstruct i k u) args ≤s[pb] mkApps (tConstruct i k u') args'

| cumul_Sort : forall s s',
    compare_universe pb Σ s s' ->
    Σ ;;; Γ ⊢ tSort s ≤s[pb] tSort s'

| cumul_Const : forall c u u',
    R_universe_instance (compare_universe Conv Σ) u u' ->
    Σ ;;; Γ ⊢ tConst c u ≤s[pb] tConst c u'

(* congruence rules *)

| cumul_Evar : forall e args args',
    All2 (fun t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) args args' ->
    Σ ;;; Γ ⊢ tEvar e args ≤s[pb] tEvar e args'

| cumul_App : forall t t' u u',
    Σ ;;; Γ ⊢ t ≤s[pb] t' ->
    Σ ;;; Γ ⊢ u ≤s[Conv] u' ->
    Σ ;;; Γ ⊢ tApp t u ≤s[pb] tApp t' u'

| cumul_Lambda : forall na na' ty ty' t t',
    eq_binder_annot na na' ->
    Σ ;;; Γ ⊢ ty ≤s[Conv] ty' ->
    Σ ;;; Γ ,, vass na ty ⊢ t ≤s[pb] t' ->
    Σ ;;; Γ ⊢ tLambda na ty t ≤s[pb] tLambda na' ty' t'

| cumul_Prod : forall na na' a a' b b',
    eq_binder_annot na na' ->
    Σ ;;; Γ ⊢ a ≤s[Conv] a' ->
    Σ ;;; Γ ,, vass na a ⊢ b ≤s[pb] b' ->
    Σ ;;; Γ ⊢ tProd na a b ≤s[pb] tProd na' a' b'

| cumul_LetIn : forall na na' t t' ty ty' u u',
    eq_binder_annot na na' ->
    Σ ;;; Γ ⊢ t ≤s[Conv] t' ->
    Σ ;;; Γ ⊢ ty ≤s[Conv] ty' ->
    Σ ;;; Γ ,, vdef na t ty ⊢ u ≤s[pb] u' ->
    Σ ;;; Γ ⊢ tLetIn na t ty u ≤s[pb] tLetIn na' t' ty' u'

| cumul_Case indn : forall p p' c c' brs brs',
    cumul_predicate (fun Γ t u => Σ ;;; Γ ⊢ t ≤s[Conv] u) Γ (compare_universe Conv Σ) p p' ->
    Σ ;;; Γ ⊢ c ≤s[Conv] c' ->
    All2 (fun br br' =>
      eq_context_gen eq eq (bcontext br) (bcontext br') ×
      Σ ;;; Γ ,,, inst_case_branch_context p br ⊢ bbody br ≤s[Conv] bbody br'
    ) brs brs' ->
    Σ ;;; Γ ⊢ tCase indn p c brs ≤s[pb] tCase indn p' c' brs'

| cumul_Proj : forall p c c',
    Σ ;;; Γ ⊢ c ≤s[Conv] c' ->
    Σ ;;; Γ ⊢ tProj p c ≤s[pb] tProj p c'

| cumul_Fix : forall mfix mfix' idx,
    All2 (fun x y =>
      Σ ;;; Γ ⊢ x.(dtype) ≤s[Conv] y.(dtype) ×
      Σ ;;; Γ ,,, fix_context mfix ⊢ x.(dbody) ≤s[Conv] y.(dbody) ×
      (x.(rarg) = y.(rarg)) ×
      eq_binder_annot x.(dname) y.(dname)
    ) mfix mfix' ->
    Σ ;;; Γ ⊢ tFix mfix idx ≤s[pb] tFix mfix' idx

| cumul_CoFix : forall mfix mfix' idx,
    All2 (fun x y =>
      Σ ;;; Γ ⊢ x.(dtype) ≤s[Conv] y.(dtype) ×
      Σ ;;; Γ ,,, fix_context mfix ⊢ x.(dbody) ≤s[Conv] y.(dbody) ×
      (x.(rarg) = y.(rarg)) ×
      eq_binder_annot x.(dname) y.(dname)
    ) mfix mfix' ->
    Σ ;;; Γ ⊢ tCoFix mfix idx ≤s[pb] tCoFix mfix' idx

(** Reductions *)

(** Beta red *)
| cumul_beta : forall na t b a,
    Σ ;;; Γ ⊢ tApp (tLambda na t b) a ≤s[pb] b {0 := a}

(** Let *)
| cumul_zeta : forall na b t b',
    Σ ;;; Γ ⊢ tLetIn na b t b' ≤s[pb] b' {0 := b}

| cumul_rel i body :
    option_map decl_body (nth_error Γ i) = Some (Some body) ->
    Σ ;;; Γ ⊢ tRel i ≤s[pb] lift0 (S i) body

(** iota red *)
| cumul_iota : forall ci c u args p brs br,
    nth_error brs c = Some br ->
    #|args| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat ->
    Σ ;;; Γ ⊢ tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs  ≤s[pb] iota_red ci.(ci_npar) p args br

(** Fix unfolding, with guard *)
| cumul_fix : forall mfix idx args narg fn,
    unfold_fix mfix idx = Some (narg, fn) ->
    is_constructor narg args = true ->
    Σ ;;; Γ ⊢ mkApps (tFix mfix idx) args ≤s[pb] mkApps fn args

(** CoFix-case unfolding *)
| cumul_cofix_case : forall ip p mfix idx args narg fn brs,
    unfold_cofix mfix idx = Some (narg, fn) ->
    Σ ;;; Γ ⊢ tCase ip p (mkApps (tCoFix mfix idx) args) brs ≤s[pb] tCase ip p (mkApps fn args) brs

(** CoFix-proj unfolding *)
| cumul_cofix_proj : forall p mfix idx args narg fn,
    unfold_cofix mfix idx = Some (narg, fn) ->
    Σ ;;; Γ ⊢ tProj p (mkApps (tCoFix mfix idx) args) ≤s[pb] tProj p (mkApps fn args)

(** Constant unfolding *)
| cumul_delta : forall c decl body (isdecl : declared_constant Σ c decl) u,
    decl.(cst_body) = Some body ->
    Σ ;;; Γ ⊢ tConst c u ≤s[pb] body@[u]

(** Proj *)
| cumul_proj : forall p args u arg,
    nth_error args (p.(proj_npars) + p.(proj_arg)) = Some arg ->
    Σ ;;; Γ ⊢ tProj p (mkApps (tConstruct p.(proj_ind) 0 u) args) ≤s[pb] arg

where " Σ ;;; Γ ⊢ t ≤s[ pb ] u " := (@cumulSpec0 _ Σ Γ pb t u) : type_scope.

Definition convSpec `{checker_flags} (Σ : global_env_ext) Γ := cumulSpec0 Σ Γ Conv.
Definition cumulSpec `{checker_flags} (Σ : global_env_ext) Γ := cumulSpec0 Σ Γ Cumul.

(* ** Syntactic cumulativity up-to universes *)

Notation " Σ ;;; Γ |- t <=s u " := (@cumulSpec _ Σ Γ t u) (at level 50, Γ, t, u at next level).
Notation " Σ ;;; Γ |- t =s u " := (@convSpec _ Σ Γ t u) (at level 50, Γ, t, u at next level).

Include PCUICConversion.

Module PCUICConversionParSpec <: EnvironmentTyping.ConversionParSig PCUICTerm PCUICEnvironment PCUICTermUtils PCUICEnvTyping.
  Definition cumul_gen := @cumulSpec0.
End PCUICConversionParSpec.

Notation " Σ ⊢ Γ ≤s[ pb ] Δ " := (@cumul_pb_context _ pb Σ Γ Δ) (at level 50, Γ, Δ at next level) : type_scope.
Notation " Σ ⊢ Γ ≤s Δ " := (@cumul_pb_context _ Cumul Σ Γ Δ) (at level 50, Γ, Δ at next level) : type_scope.
Notation " Σ ⊢ Γ =s Δ " := (@cumul_pb_context _ Conv Σ Γ Δ) (at level 50, Γ, Δ at next level) : type_scope.

#[global]
Instance cumul_spec_refl {cf:checker_flags} Σ Γ pb : Reflexive (cumulSpec0 Σ Γ pb).
Proof. intro; constructor 3. Qed.

#[global]
Instance conv_refl' {cf:checker_flags} Σ Γ : Reflexive (convSpec Σ Γ) := _.

#[global]
Instance cumul_pb_decls_refl {cf:checker_flags} pb Σ Γ Γ' : Reflexive (cumul_pb_decls cumulSpec0 pb Σ Γ Γ').
Proof.
  intros x. destruct x as [na [b|] ty]; constructor; auto.
  all:constructor; reflexivity.
Qed.

#[global]
Instance conv_decls_refl {cf:checker_flags} Σ Γ Γ' : Reflexive (conv_decls cumulSpec0 Σ Γ Γ') := _.
#[global]
Instance cumul_decls_refl {cf:checker_flags} Σ Γ Γ' : Reflexive (cumul_decls cumulSpec0 Σ Γ Γ') := _.

Section ContextConversion.
  Context {cf : checker_flags}.
  Context (Σ : global_env_ext).

  Notation conv_context := (conv_context cumulSpec0 Σ).
  Notation cumul_context := (cumul_context cumulSpec0 Σ).

  Global Instance cumul_pb_ctx_refl pb : Reflexive (cumul_pb_context cumulSpec0 pb Σ).
  Proof using Type.
    intro Γ; induction Γ; try econstructor; auto.
    reflexivity.
  Qed.

  Global Instance conv_ctx_refl : Reflexive (conv_context) := _.
  Global Instance cumul_ctx_refl : Reflexive (cumul_context) := _.

  Definition conv_ctx_refl' Γ : conv_context Γ Γ
  := conv_ctx_refl Γ.

  Definition cumul_ctx_refl' Γ : cumul_context Γ Γ
    := cumul_ctx_refl Γ.

End ContextConversion.

Lemma cumulSpec0_ind_all :
  forall {cf} (Σ : global_env_ext)
         (P : conv_pb -> context -> term -> term -> Type),

        (* beta *)
       (forall (pb : conv_pb) (Γ : context) (na : aname) (t b a : term),
        P pb Γ (tApp (tLambda na t b) a) (b {0 := a})) ->

        (* let *)
       (forall (pb : conv_pb) (Γ : context) (na : aname) (b t b' : term), P pb Γ (tLetIn na b t b') (b' {0 := b})) ->

       (forall (pb : conv_pb) (Γ : context) (i : nat) (body : term),
        option_map decl_body (nth_error Γ i) = Some (Some body) -> P pb Γ (tRel i) ((lift0 (S i)) body)) ->

        (* iota *)
       (forall (pb : conv_pb) (Γ : context) (ci : case_info) (c : nat) (u : Instance.t) (args : list term)
          (p : predicate term) (brs : list (branch term)) br,
          nth_error brs c = Some br ->
          #|args| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat ->
          P pb Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs)
              (iota_red ci.(ci_npar) p args br)) ->

        (* fix unfolding *)
       (forall (pb : conv_pb) (Γ : context) (mfix : mfixpoint term) (idx : nat) (args : list term) (narg : nat) (fn : term),
        unfold_fix mfix idx = Some (narg, fn) ->
        is_constructor narg args = true -> P pb Γ (mkApps (tFix mfix idx) args) (mkApps fn args)) ->

      (* cofix unfolding *)
       (forall (pb : conv_pb) (Γ : context) ci (p : predicate term) (mfix : mfixpoint term) (idx : nat)
          (args : list term) (narg : nat) (fn : term) (brs : list (branch term)),
        unfold_cofix mfix idx = Some (narg, fn) ->
        P pb Γ (tCase ci p (mkApps (tCoFix mfix idx) args) brs) (tCase ci p (mkApps fn args) brs)) ->

       (forall (pb : conv_pb) (Γ : context) (p : projection) (mfix : mfixpoint term) (idx : nat) (args : list term)
          (narg : nat) (fn : term),
        unfold_cofix mfix idx = Some (narg, fn) -> P pb Γ (tProj p (mkApps (tCoFix mfix idx) args)) (tProj p (mkApps fn args))) ->

        (* constant unfolding *)
       (forall (pb : conv_pb) (Γ : context) c (decl : constant_body) (body : term),
        declared_constant Σ c decl ->
        forall u : Instance.t, cst_body decl = Some body -> P pb Γ (tConst c u) (subst_instance u body)) ->

        (* Proj *)
       (forall (pb : conv_pb) (Γ : context)p (args : list term) (u : Instance.t)
         (arg : term),
           nth_error args (p.(proj_npars) + p.(proj_arg)) = Some arg ->
           P pb Γ (tProj p (mkApps (tConstruct p.(proj_ind) 0 u) args)) arg) ->

        (* transitivity *)
       (forall (pb : conv_pb) (Γ : context) (t u v : term),
          is_closed_context Γ -> is_open_term Γ u ->
          cumulSpec0 Σ Γ pb t u -> P pb Γ t u ->
          cumulSpec0 Σ Γ pb u v -> P pb Γ u v ->
          P pb Γ t v) ->

        (* symmetry *)
       (forall (pb : conv_pb) (Γ : context) (t u : term),
        cumulSpec0 Σ Γ Conv u t -> P Conv Γ u t ->
         P pb Γ t u) ->

        (* reflexivity *)
        (forall (pb : conv_pb) (Γ : context) (t : term),
        P pb Γ t t) ->

        (* congruence rules *)

        (forall (pb : conv_pb) (Γ : context) (ev : nat) (l l' : list term),
          All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Conv Γ)) l l' -> P pb Γ (tEvar ev l) (tEvar ev l')) ->

        (forall (pb : conv_pb) (Γ : context) (t t' u u' : term),
          cumulSpec0 Σ Γ pb t t' -> P pb Γ t t' ->
          cumulSpec0 Σ Γ Conv u u' -> P Conv Γ u u' ->
          P pb Γ (tApp t u) (tApp t' u')) ->

        (forall (pb : conv_pb) (Γ : context) (na na' : aname) (ty ty' t t' : term),
          eq_binder_annot na na' ->
          cumulSpec0 Σ Γ Conv ty ty' -> P Conv Γ ty ty' ->
          cumulSpec0 Σ (Γ ,, vass na ty) pb t t' -> P pb (Γ ,, vass na ty) t t' ->
          P pb Γ (tLambda na ty t) (tLambda na' ty' t')) ->

        (forall (pb : conv_pb) (Γ : context) (na na' : binder_annot name) (a a' b b' : term),
          eq_binder_annot na na' ->
          cumulSpec0 Σ Γ Conv a a' -> P Conv Γ a a' ->
          cumulSpec0 Σ (Γ,, vass na a) pb b b' -> P pb (Γ,, vass na a) b b' ->
          P pb Γ (tProd na a b) (tProd na' a' b')) ->

     (forall (pb : conv_pb) (Γ : context) (na na' : binder_annot name) (t t' ty ty' u u' : term),
        eq_binder_annot na na' ->  cumulSpec0 Σ Γ Conv t t' -> P Conv Γ t t' ->
        cumulSpec0 Σ Γ  Conv ty ty' -> P Conv Γ ty ty' ->
        cumulSpec0 Σ (Γ,, vdef na t ty) pb u u' -> P pb (Γ,, vdef na t ty) u u' ->
        P pb Γ (tLetIn na t ty u) (tLetIn na' t' ty' u')) ->

      (forall (pb : conv_pb) (Γ : context) (indn : case_info) (p p' : predicate term)
        (c c' : term) (brs brs' : list (branch term)),
        cumul_predicate (fun Γ t u => cumulSpec0 Σ Γ Conv t u × P Conv Γ t u) Γ
          (compare_universe Conv Σ) p p' ->
        cumulSpec0 Σ Γ Conv c c' -> P Conv Γ c c' ->
        All2
          (Trel_conj (fun br br' : branch term =>
               eq_context_gen eq eq (bcontext br) (bcontext br') *
               cumulSpec0 Σ (Γ,,, inst_case_branch_context p br) Conv
                 (bbody br) (bbody br'))
            (fun br br' => P Conv (Γ,,, inst_case_branch_context p br) (bbody br) (bbody br'))) brs brs' ->
       P pb Γ (tCase indn p c brs) (tCase indn p' c' brs')) ->

       (forall (pb : conv_pb) (Γ : context)
          (p : projection) (c c' : term),
        cumulSpec0 Σ Γ Conv c c' -> P Conv Γ c c' ->
         P pb Γ (tProj p c) (tProj p c')) ->

       (forall (pb : conv_pb) (Γ : context)
          (mfix : mfixpoint term) (mfix' : list (def term)) (idx : nat),
          All2
            (fun x y : def term =>
             ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) ×
                P Conv Γ (dtype x) (dtype y)
               × cumulSpec0 Σ (Γ,,, fix_context mfix) Conv
                   (dbody x) (dbody y)) ×
                P Conv (Γ,,, fix_context mfix) (dbody x) (dbody y) × rarg x = rarg y) *
             eq_binder_annot (dname x) (dname y)) mfix mfix' ->
           P pb Γ (tFix mfix idx) (tFix mfix' idx)) ->

       (forall (pb : conv_pb) (Γ : context)
           (mfix : mfixpoint term) (mfix' : list (def term)) (idx : nat),
           All2
             (fun x y : def term =>
              ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) ×
                 P Conv Γ (dtype x) (dtype y)
                × cumulSpec0 Σ (Γ,,, fix_context mfix) Conv
                    (dbody x) (dbody y)) × P Conv (Γ,,, fix_context mfix)
                    (dbody x) (dbody y) × rarg x = rarg y) *
              eq_binder_annot (dname x) (dname y)) mfix mfix' ->
            P pb Γ (tCoFix mfix idx) (tCoFix mfix' idx)) ->

      (* cumulativity rules *)

      (forall (pb : conv_pb)
            (Γ : context) (i : inductive) (u u' : list Level.t)
            (args args' : list term),
      R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (IndRef i) #|args| u u' ->
      All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Conv Γ)) args args' ->
      P pb Γ (mkApps (tInd i u) args) (mkApps (tInd i u') args')) ->

    (forall (pb : conv_pb)
      (Γ : context) (i : inductive) (k : nat)
      (u u' : list Level.t) (args args' : list term),
      R_global_instance Σ (eq_universe Σ) (compare_universe pb Σ) (ConstructRef i k) #|args| u u' ->
      All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Conv Γ)) args args' ->
      P pb Γ (mkApps (tConstruct i k u) args)
              (mkApps (tConstruct i k u') args')) ->

      (forall (pb : conv_pb)
          (Γ : context) (s s' : Universe.t),
          compare_universe pb Σ s s' -> P pb Γ (tSort s) (tSort s')) ->

      (forall (pb : conv_pb)
          (Γ : context) (c : kername) (u u' : list Level.t),
          R_universe_instance (compare_universe Conv Σ) u u' -> P pb Γ (tConst c u) (tConst c u') ) ->

       forall (pb : conv_pb) (Γ : context) (t t0 : term), cumulSpec0 Σ Γ pb t t0 -> P pb Γ t t0.
Proof.
  intros. rename X24 into Xlast. revert pb Γ t t0 Xlast.
  fix aux 5. intros pb Γ t u.
  move aux at top.
  destruct 1.
  - eapply X8; eauto.
  - eapply X9; eauto.
  - eapply X10; eauto.
  - eapply X20; eauto. clear -a aux.
    revert args args' a.
    fix aux' 3; destruct 1; constructor; auto.
  - eapply X21; eauto. clear -a aux.
    revert args args' a.
    fix aux' 3; destruct 1; constructor; auto.
  - eapply X22; eauto.
  - eapply X23; eauto.
  - eapply X11.
    revert args args' a.
    fix aux' 3; destruct 1; constructor; auto.
  - eapply X12; eauto.
  - eapply X13; eauto.
  - eapply X14; eauto.
  - eapply X15; eauto.
  - eapply X16 ; eauto.
    + unfold cumul_predicate in *. destruct c0 as [c0 [cuniv [ccontext creturn]]].
      repeat split ; eauto.
      * revert c0. generalize (pparams p), (pparams p').
        fix aux' 3; destruct 1; constructor; auto.
    + revert brs brs' a.
      fix aux' 3; destruct 1; constructor; intuition auto.
  - eapply X17 ; eauto.
  - eapply X18 ; eauto.
    revert a.
    set (mfixAbs := mfix). unfold mfixAbs at 2 5.
    clearbody mfixAbs.
    revert mfix mfix'.
    fix aux' 3; destruct 1; constructor.
    + intuition auto.
    + auto.
  - eapply X19 ; eauto.
    revert a.
    set (mfixAbs := mfix). unfold mfixAbs at 2 5.
    clearbody mfixAbs.
    revert mfix mfix'.
    fix aux' 3; destruct 1; constructor.
    + intuition auto.
    + auto.
  - eapply X.
  - eapply X0.
  - eapply X1; eauto.
  - eapply X2; eauto.
  - eapply X3; eauto.
  - eapply X4; eauto.
  - eapply X5; eauto.
  - eapply X6; eauto.
  - eapply X7; eauto.
Defined.

Lemma convSpec0_ind_all :
  forall {cf} (Σ : global_env_ext)
         (P : context -> term -> term -> Type),

        (* beta *)
       (forall  (Γ : context) (na : aname) (t b a : term),
        P Γ (tApp (tLambda na t b) a) (b {0 := a})) ->

        (* let *)
       (forall  (Γ : context) (na : aname) (b t b' : term), P  Γ (tLetIn na b t b') (b' {0 := b})) ->

       (forall  (Γ : context) (i : nat) (body : term),
        option_map decl_body (nth_error Γ i) = Some (Some body) -> P  Γ (tRel i) ((lift0 (S i)) body)) ->

        (* iota *)
       (forall  (Γ : context) (ci : case_info) (c : nat) (u : Instance.t) (args : list term)
          (p : predicate term) (brs : list (branch term)) br,
          nth_error brs c = Some br ->
          #|args| = (ci.(ci_npar) + context_assumptions br.(bcontext))%nat ->
          P  Γ (tCase ci p (mkApps (tConstruct ci.(ci_ind) c u) args) brs)
              (iota_red ci.(ci_npar) p args br)) ->

        (* fix unfolding *)
       (forall  (Γ : context) (mfix : mfixpoint term) (idx : nat) (args : list term) (narg : nat) (fn : term),
        unfold_fix mfix idx = Some (narg, fn) ->
        is_constructor narg args = true -> P Γ (mkApps (tFix mfix idx) args) (mkApps fn args)) ->

      (* cofix unfolding *)
       (forall  (Γ : context) ci (p : predicate term) (mfix : mfixpoint term) (idx : nat)
          (args : list term) (narg : nat) (fn : term) (brs : list (branch term)),
        unfold_cofix mfix idx = Some (narg, fn) ->
        P Γ (tCase ci p (mkApps (tCoFix mfix idx) args) brs) (tCase ci p (mkApps fn args) brs)) ->

       (forall  (Γ : context) (p : projection) (mfix : mfixpoint term) (idx : nat) (args : list term)
          (narg : nat) (fn : term),
        unfold_cofix mfix idx = Some (narg, fn) -> P Γ (tProj p (mkApps (tCoFix mfix idx) args)) (tProj p (mkApps fn args))) ->

        (* constant unfolding *)
       (forall  (Γ : context) c (decl : constant_body) (body : term),
        declared_constant Σ c decl ->
        forall u : Instance.t, cst_body decl = Some body -> P Γ (tConst c u) (subst_instance u body)) ->

        (* Proj *)
       (forall  (Γ : context) p (args : list term) (u : Instance.t)
         (arg : term),
           nth_error args (p.(proj_npars) + p.(proj_arg)) = Some arg ->
           P  Γ (tProj p (mkApps (tConstruct p.(proj_ind) 0 u) args)) arg) ->

        (* transitivity *)
       (forall  (Γ : context) (t u v : term),
          is_closed_context Γ -> is_open_term Γ u ->
          cumulSpec0 Σ Γ Conv t u -> P Γ t u ->
          cumulSpec0 Σ Γ Conv u v -> P Γ u v ->
          P Γ t v) ->

        (* symmetry *)
       (forall  (Γ : context) (t u : term),
        cumulSpec0 Σ Γ Conv u t -> P Γ u t ->
        P Γ t u) ->

        (* reflexivity *)
        (forall  (Γ : context) (t : term),
        P Γ t t) ->

        (* congruence rules *)

        (forall  (Γ : context) (ev : nat) (l l' : list term),
          All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Γ)) l l' -> P Γ (tEvar ev l) (tEvar ev l')) ->

        (forall  (Γ : context) (t t' u u' : term),
          cumulSpec0 Σ Γ Conv t t' -> P Γ t t' ->
          cumulSpec0 Σ Γ Conv u u' -> P Γ u u' ->
          P Γ (tApp t u) (tApp t' u')) ->

        (forall  (Γ : context) (na na' : aname) (ty ty' t t' : term),
          eq_binder_annot na na' ->
          cumulSpec0 Σ Γ Conv ty ty' -> P Γ ty ty' ->
          cumulSpec0 Σ (Γ ,, vass na ty) Conv t t' -> P (Γ ,, vass na ty) t t' ->
          P Γ (tLambda na ty t) (tLambda na' ty' t')) ->

        (forall  (Γ : context) (na na' : binder_annot name) (a a' b b' : term),
          eq_binder_annot na na' ->
          cumulSpec0 Σ Γ Conv a a' -> P Γ a a' ->
          cumulSpec0 Σ (Γ,, vass na a) Conv b b' -> P (Γ,, vass na a) b b' ->
          P Γ (tProd na a b) (tProd na' a' b')) ->

     (forall  (Γ : context) (na na' : binder_annot name) (t t' ty ty' u u' : term),
        eq_binder_annot na na' ->  cumulSpec0 Σ Γ Conv t t' -> P Γ t t' ->
        cumulSpec0 Σ Γ Conv ty ty' -> P Γ ty ty' ->
        cumulSpec0 Σ (Γ,, vdef na t ty) Conv u u' -> P (Γ,, vdef na t ty) u u' ->
        P Γ (tLetIn na t ty u) (tLetIn na' t' ty' u')) ->

      (forall  (Γ : context) (indn : case_info) (p p' : predicate term)
        (c c' : term) (brs brs' : list (branch term)),
        cumul_predicate (fun Γ t u => cumulSpec0 Σ Γ Conv t u * P Γ t u) Γ (compare_universe Conv Σ) p p' ->
        cumulSpec0 Σ Γ Conv c c' -> P Γ c c' ->
        All2
          (Trel_conj (fun br br' : branch term =>
               eq_context_gen eq eq (bcontext br) (bcontext br') *
               cumulSpec0 Σ (Γ,,, inst_case_branch_context p br) Conv
                 (bbody br) (bbody br'))
            (fun br br' => P (Γ,,, inst_case_branch_context p br) (bbody br) (bbody br'))) brs brs' ->
       P Γ (tCase indn p c brs) (tCase indn p' c' brs')) ->

       (forall  (Γ : context)
          (p : projection) (c c' : term),
        cumulSpec0 Σ Γ Conv c c' -> P Γ c c' ->
         P Γ (tProj p c) (tProj p c')) ->

       (forall  (Γ : context)
          (mfix : mfixpoint term) (mfix' : list (def term)) (idx : nat),
          All2
            (fun x y : def term =>
             ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) ×
                P Γ (dtype x) (dtype y)
               × cumulSpec0 Σ (Γ,,, fix_context mfix) Conv
                   (dbody x) (dbody y)) × P (Γ,,, fix_context mfix)
                   (dbody x) (dbody y) × rarg x = rarg y) *
             eq_binder_annot (dname x) (dname y)) mfix mfix' ->
           P Γ (tFix mfix idx) (tFix mfix' idx)) ->

       (forall  (Γ : context)
           (mfix : mfixpoint term) (mfix' : list (def term)) (idx : nat),
           All2
             (fun x y : def term =>
              ((cumulSpec0 Σ Γ Conv (dtype x) (dtype y) ×
                 P Γ (dtype x) (dtype y)
                × cumulSpec0 Σ (Γ,,, fix_context mfix) Conv
                    (dbody x) (dbody y)) × P (Γ,,, fix_context mfix)
                    (dbody x) (dbody y) × rarg x = rarg y) *
              eq_binder_annot (dname x) (dname y)) mfix mfix' ->
            P Γ (tCoFix mfix idx) (tCoFix mfix' idx)) ->

      (* cumulativiity rules *)

      (forall
            (Γ : context) (i : inductive) (u u' : list Level.t)
            (args args' : list term),
      R_global_instance Σ (eq_universe Σ) (eq_universe Σ) (IndRef i) #|args| u u' ->
      All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Γ)) args args' ->
      P Γ (mkApps (tInd i u) args) (mkApps (tInd i u') args')) ->

    (forall
      (Γ : context) (i : inductive) (k : nat)
      (u u' : list Level.t) (args args' : list term),
      R_global_instance Σ (eq_universe Σ) (eq_universe Σ) (ConstructRef i k) #|args| u u' ->
      All2 (Trel_conj (cumulSpec0 Σ Γ Conv) (P Γ)) args args' ->
      P Γ (mkApps (tConstruct i k u) args)
              (mkApps (tConstruct i k u') args')) ->

      (forall
          (Γ : context) (s s' : Universe.t),
          eq_universe Σ s s' -> P Γ (tSort s) (tSort s')) ->

      (forall
          (Γ : context) (c : kername) (u u' : list Level.t),
          R_universe_instance (eq_universe Σ) u u' -> P Γ (tConst c u) (tConst c u') ) ->

       forall  (Γ : context) (t t0 : term), cumulSpec0 Σ Γ Conv t t0 -> P Γ t t0.
Proof.
  intros. rename X24 into Xlast. revert Γ t t0 Xlast.
  fix aux 4. intros Γ t u.
  move aux at top.
  destruct 1.
  - eapply X8; eauto.
  - eapply X9; eauto.
  - eapply X10; eauto.
  - eapply X20; eauto. clear -a aux.
    revert args args' a.
    fix aux' 3; destruct 1; constructor; auto.
  - eapply X21; eauto. clear -a aux.
    revert args args' a.
    fix aux' 3; destruct 1; constructor; auto.
  - eapply X22; eauto.
  - eapply X23; eauto.
  - eapply X11.
    revert args args' a.
    fix aux' 3; destruct 1; constructor; auto.
  - eapply X12; eauto.
  - eapply X13; eauto.
  - eapply X14; eauto.
  - eapply X15; eauto.
  - eapply X16 ; eauto.
    + unfold cumul_predicate in *. destruct c0 as [c0 [cuniv [ccontext creturn]]].
      repeat split ; eauto.
      * revert c0. generalize (pparams p), (pparams p').
        fix aux' 3; destruct 1; constructor; auto.
    + revert brs brs' a.
      fix aux' 3; destruct 1; constructor; intuition auto.
  - eapply X17 ; eauto.
  - eapply X18 ; eauto.
    revert a.
    set (mfixAbs := mfix). unfold mfixAbs at 2 5.
    clearbody mfixAbs.
    revert mfix mfix'.
    fix aux' 3; destruct 1; constructor.
    + intuition auto.
    + auto.
  - eapply X19 ; eauto.
    revert a.
    set (mfixAbs := mfix). unfold mfixAbs at 2 5.
    clearbody mfixAbs.
    revert mfix mfix'.
    fix aux' 3; destruct 1; constructor.
    + intuition auto.
    + auto.
  - eapply X.
  - eapply X0.
  - eapply X1; eauto.
  - eapply X2; eauto.
  - eapply X3; eauto.
  - eapply X4; eauto.
  - eapply X5; eauto.
  - eapply X6; eauto.
  - eapply X7; eauto.
Defined.


Require Import Coqlib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import Mem1 MemOpen.
Require Import EchoHeader.
Require Import IPM HoareDef OpenDef.
Require Import Stack3A.

Set Implicit Arguments.

Section PROOF.

  Context `{Σ: GRA.t}.
  Context `{@GRA.inG stkRA Σ}.

  Definition echo_body: list val -> itree hEs val :=
    fun args =>
      _ <- (pargs [] args)?;;;
      `stk0: list Z    <- (ccallN "input" ([]: list Z));;;
      `_: list Z    <- (ccallN "output" (stk0));;;
      Ret Vundef
  .

  Let is_int_stack (h: mblock) (stk0: list Z): iProp :=
    (OwnM (is_stack h (List.map Vint stk0)) ∧ ⌜Forall (fun z => (z <> (- 1)%Z) /\ (intrange_64 z)) stk0⌝)%I
  .

  Definition input_spec: fspec :=
    mk_fspec (fun _ => ord_top)
             (fun _ h _argh _argl =>
                (∃ (stk0: list Z) (argl: list val),
                  ⌜_argh = stk0↑ ∧ _argl = argl↑ ∧ argl = [Vptr h 0]⌝
                   ** (is_int_stack h stk0))%I)
             (fun _ h _reth _retl => (∃ (stk1: list Z), ⌜_reth = stk1↑ ∧ _retl = Vundef↑⌝ ** is_int_stack h stk1)%I)
  .

  Definition input_body: list Z -> itree hEs (list Z) :=
    fun stk =>
      n <- (ccallU "getint" ([]: list val));;;
      assume(wf_val n);;;
      n <- (parg Tint n)?;;;
      if (dec n (- 1)%Z)
      then Ret stk
      else
        ret <- (ccallN "input" (n :: stk));;; Ret ret
  .

  Definition output_spec: fspec :=
    mk_fspec (fun _ => ord_top)
             (fun _ h _argh _argl =>
                (∃ (stk0: list Z) (argl: list val),
                  ⌜_argh = stk0↑ ∧ _argl = argl↑ ∧ argl = [Vptr h 0]⌝
                   ** is_int_stack h stk0)%I)
             (fun _ h _reth _retl => (∃ (stk1: list Z), ⌜_reth = stk1↑ ∧ _retl = Vundef↑⌝ ** is_int_stack h stk1)%I)
  .

  Definition output_body: list Z -> itree hEs (list Z) :=
    fun stk =>
      ;;;
      match stk with
      | [] => Ret []
      | n :: stk' =>
        `_: val <- (ccallU "putint" ([Vint n]: list val));;;
         ret <- (ccallN "output" (stk'));;;
         Ret ret
      end
  .

  Definition EchoSbtb: list (gname * kspecbody) :=
    [("echo", ksb_trivial (cfunU echo_body));
    ("input",  mk_kspecbody input_spec (fun _ => triggerUB) (cfunN input_body));
    ("output", mk_kspecbody output_spec (fun _ => triggerUB) (cfunN output_body))
    ]
  .

  Definition EchoStb: list (gname * fspec).
    eapply (Seal.sealing "stb").
    let x := constr:(List.map (map_snd (fun ksb => ksb.(ksb_fspec): fspec)) EchoSbtb) in
    let y := eval cbn in x in
    eapply y.
  Defined.

  Definition KEchoSem: KModSem.t := {|
    KModSem.fnsems := EchoSbtb;
    KModSem.mn := "Echo";
    KModSem.initial_mr := ε;
    KModSem.initial_st := (∅: gmap mblock (list Z))↑;
  |}
  .
  Definition EchoSem (stb: gname -> option fspec): ModSem.t :=
    KModSem.transl_tgt stb KEchoSem.

  Definition KEcho: KMod.t := {|
    KMod.get_modsem := fun _ => KEchoSem;
    KMod.sk := [("echo", Sk.Gfun); ("input", Sk.Gfun); ("output", Sk.Gfun)];
  |}
  .
  Definition Echo (stb: Sk.t -> gname -> option fspec): Mod.t :=
    KMod.transl_tgt stb KEcho.

End PROOF.
Global Hint Unfold EchoStb: stb.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Semantics.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import coqutil.Word.Interface.
Require Import coqutil.Map.Interface.
Require Import coqutil.Tactics.Tactics.
Require Import Bedrock2Experiments.ProgramSemantics32.
Require Import Bedrock2Experiments.LibBase.AbsMMIO.
Require Import Bedrock2Experiments.StateMachineSemantics.
Require Import Bedrock2Experiments.StateMachineProperties.
Import Syntax.Coercions List.ListNotations.
Local Open Scope string_scope.

Section Proof.
  Context {word: word.word 32} {mem: map.map word Byte.byte}
          {word_ok: word.ok word} {mem_ok: map.ok mem}
          {M: state_machine.parameters} {M_ok: state_machine.ok M}
          (execution_unique: forall t s1 s2, execution t s1 -> execution t s2 -> s1 = s2).

  Global Instance spec_of_abs_mmio_write8 : spec_of "abs_mmio_write8" :=
    fun function_env =>
      forall (tr : trace) (m : mem) (s : M) (s' : M) (addr : word) (value : word) r,
        state_machine.reg_addr r = addr ->
        state_machine.write_step 1 s r value s' ->
        execution tr s ->
        call function_env abs_mmio_write8 tr m [addr; value]
        (fun tr' m' rets =>
          rets = []
          /\ tr' = ((map.empty, MMIOLabels.WRITE8, [addr; value], (map.empty, [])) :: tr)
          /\ (exists s'', execution tr' s'')
          /\ m = m'
        ).
  Lemma abs_mmio_write8_correct :
    program_logic_goal_for_function! abs_mmio_write8.
  Proof.
    repeat straightline.
    eapply (interact_write 1); repeat straightline.
    - rewrite <- H. reflexivity.
    - do 2 eexists; ssplit; eauto.
    - rewrite <- H; ssplit; eauto.
  Qed.

  Global Instance spec_of_abs_mmio_write32 : spec_of "abs_mmio_write32" :=
    fun function_env =>
      forall (tr : trace) (m : mem) (s : M) (s' : M) (addr : word) (value : word) r,
        state_machine.reg_addr r = addr ->
        state_machine.write_step 4 s r value s' ->
        execution tr s ->
        call function_env abs_mmio_write32 tr m [addr; value]
        (fun tr' m' rets =>
          rets = []
          /\ tr' = ((map.empty, MMIOLabels.WRITE32, [addr; value], (map.empty, [])) :: tr)
          /\ (exists s'', execution tr' s'')
          /\ m = m'
        ).
  Lemma abs_mmio_write32_correct :
    program_logic_goal_for_function! abs_mmio_write32.
  Proof.
    repeat straightline.
    eapply (interact_write 4); repeat straightline.
    - rewrite <- H. reflexivity.
    - do 2 eexists; ssplit; eauto.
    - rewrite <- H; ssplit; eauto.
  Qed.

  Global Instance spec_of_abs_mmio_read8 : spec_of "abs_mmio_read8" :=
    fun function_env =>
      forall (tr : trace) (m : mem) (s : M) (addr : word) r val s',
        state_machine.reg_addr r = addr ->
        state_machine.read_step 1 s r val s' ->
        execution tr s ->
        call function_env abs_mmio_read8 tr m [addr]
        (fun tr' m' rets =>
          exists s' val,
          rets = [val]
          /\ tr' = ((map.empty, MMIOLabels.READ8, [addr], (map.empty, [val])) :: tr)
          /\ execution tr' s'
          /\ m = m'
        ).
  Lemma abs_mmio_read8_correct :
    program_logic_goal_for_function! abs_mmio_read8.
  Proof.
    repeat straightline.
    eapply (interact_read 1); repeat straightline; eauto.
    - rewrite <- H. reflexivity.
    - do 3 eexists; ssplit; eauto.
      rewrite <- H. reflexivity.
  Qed.

  Global Instance spec_of_abs_mmio_read32 : spec_of "abs_mmio_read32" :=
    fun function_env =>
      forall (tr : trace) (m : mem) (s : M) (addr : word) r val s',
        state_machine.reg_addr r = addr ->
        state_machine.read_step 4 s r val s' ->
        execution tr s ->
        call function_env abs_mmio_read32 tr m [addr]
        (fun tr' m' rets =>
          exists s' val,
          rets = [val]
          /\ tr' = ((map.empty, MMIOLabels.READ32, [addr], (map.empty, [val])) :: tr)
          /\ execution tr' s'
          /\ m = m'
        ).
  Lemma abs_mmio_read32_correct :
    program_logic_goal_for_function! abs_mmio_read32.
  Proof.
    repeat straightline.
    eapply (interact_read 4); repeat straightline; eauto.
    - rewrite <- H. reflexivity.
    - do 3 eexists; ssplit; eauto.
      rewrite <- H. reflexivity.
  Qed.

End Proof.


(** Notion of contextual refinement & proof that it is a precongruence wrt the logical relation *)
From Autosubst Require Import Autosubst.
From self.prob_lang Require Export lang.
From self.prob_lang Require Import tactics.
From iris.proofmode Require Import proofmode.
From self.logrel Require Import model.
From self.typing Require Export types interp fundamental.

Inductive ctx_item :=
  (* Base lambda calculus *)
  | CTX_Rec (f x : binder)
  | CTX_AppL (e2 : expr)
  | CTX_AppR (e1 : expr)
  (* Base types and their operations *)
  | CTX_UnOp (op : un_op)
  | CTX_BinOpL (op : bin_op) (e2 : expr)
  | CTX_BinOpR (op : bin_op) (e1 : expr)
  | CTX_IfL (e1 : expr) (e2 : expr)
  | CTX_IfM (e0 : expr) (e2 : expr)
  | CTX_IfR (e0 : expr) (e1 : expr)
  (* Products *)
  | CTX_PairL (e2 : expr)
  | CTX_PairR (e1 : expr)
  | CTX_Fst
  | CTX_Snd
  (* Sums *)
  | CTX_InjL
  | CTX_InjR
  | CTX_CaseL (e1 : expr) (e2 : expr)
  | CTX_CaseM (e0 : expr) (e2 : expr)
  | CTX_CaseR (e0 : expr) (e1 : expr)
  (* Heap *)
  | CTX_Alloc
  | CTX_Load
  | CTX_StoreL (e2 : expr)
  | CTX_StoreR (e1 : expr)
  (* Recursive Types *)
  | CTX_Fold
  | CTX_Unfold
  (* Polymorphic Types *)
  | CTX_TLam
  | CTX_TApp
  (* Existential types *)
    (* Nb: we do not have an explicit PACK operation *)
  | CTX_UnpackL (x : binder) (e2 : expr)
  | CTX_UnpackR (x : binder) (e1 : expr)
  | CTX_Flip
.

Definition fill_ctx_item (ctx : ctx_item) (e : expr) : expr :=
  match ctx with
  (* Base lambda calculus *)
  | CTX_Rec f x => Rec f x e
  | CTX_AppL e2 => App e e2
  | CTX_AppR e1 => App e1 e
  (* Base types and operations *)
  | CTX_UnOp op => UnOp op e
  | CTX_BinOpL op e2 => BinOp op e e2
  | CTX_BinOpR op e1 => BinOp op e1 e
  | CTX_IfL e1 e2 => If e e1 e2
  | CTX_IfM e0 e2 => If e0 e e2
  | CTX_IfR e0 e1 => If e0 e1 e
  (* Products *)
  | CTX_PairL e2 => Pair e e2
  | CTX_PairR e1 => Pair e1 e
  | CTX_Fst => Fst e
  | CTX_Snd => Snd e
  (* Sums *)
  | CTX_InjL => InjL e
  | CTX_InjR => InjR e
  | CTX_CaseL e1 e2 => Case e e1 e2
  | CTX_CaseM e0 e2 => Case e0 e e2
  | CTX_CaseR e0 e1 => Case e0 e1 e
  (* Concurrency *)
  (* Heap & atomic CAS/FAA *)
  | CTX_Alloc => Alloc e
  | CTX_Load => Load e
  | CTX_StoreL e2 => Store e e2
  | CTX_StoreR e1 => Store e1 e
  (* Recursive & polymorphic types *)
  | CTX_Fold => e
  | CTX_Unfold => rec_unfold e
  | CTX_TLam => Λ: e
  | CTX_TApp => TApp e
  | CTX_UnpackL x e1 => unpack: x:=e in e1
  | CTX_UnpackR x e0 => unpack: x:=e0 in e
  | CTX_Flip => Flip e
  end.

Definition ctx := list ctx_item.

(* TODO: consider using foldl here *)
Definition fill_ctx (K : ctx) (e : expr) : expr := foldr fill_ctx_item e K.

(** typed ctx *)
Inductive typed_ctx_item :
    ctx_item → stringmap type → type → stringmap type → type → Prop :=
  (* Base lambda calculus *)
  | TP_CTX_Rec Γ τ τ' f x :
     typed_ctx_item (CTX_Rec f x) (<[f:=TArrow τ τ']>(<[x:=τ]>Γ)) τ' Γ (TArrow τ τ')
  | TP_CTX_AppL Γ e2 τ τ' :
     typed Γ e2 τ →
     typed_ctx_item (CTX_AppL e2) Γ (TArrow τ τ') Γ τ'
  | TP_CTX_AppR Γ e1 τ τ' :
     typed Γ e1 (TArrow τ τ') →
     typed_ctx_item (CTX_AppR e1) Γ τ Γ τ'
  (* Base types and operations *)
  | TP_CTX_UnOp_Nat op Γ τ :
     unop_int_res_type op = Some τ →
     typed_ctx_item (CTX_UnOp op) Γ TInt Γ τ
  | TP_CTX_UnOp_Bool op Γ τ :
     unop_bool_res_type op = Some τ →
     typed_ctx_item (CTX_UnOp op) Γ TBool Γ τ
  | TP_CTX_BinOpL_Nat op Γ e2 τ :
     typed Γ e2 TInt →
     binop_int_res_type op = Some τ →
     typed_ctx_item (CTX_BinOpL op e2) Γ TInt Γ τ
  | TP_CTX_BinOpR_Nat op e1 Γ τ :
     typed Γ e1 TInt →
     binop_int_res_type op = Some τ →
     typed_ctx_item (CTX_BinOpR op e1) Γ TInt Γ τ
  | TP_CTX_BinOpL_Bool op Γ e2 τ :
     typed Γ e2 TBool →
     binop_bool_res_type op = Some τ →
     typed_ctx_item (CTX_BinOpL op e2) Γ TBool Γ τ
  | TP_CTX_BinOpR_Bool op e1 Γ τ :
     typed Γ e1 TBool →
     binop_bool_res_type op = Some τ →
     typed_ctx_item (CTX_BinOpR op e1) Γ TBool Γ τ
  | TP_CTX_BinOpL_UnboxedEq e2 Γ τ :
     UnboxedType τ →
     typed Γ e2 τ →
     typed_ctx_item (CTX_BinOpL EqOp e2) Γ τ Γ TBool
  | TP_CTX_BinOpR_UnboxedEq e1 Γ τ :
     UnboxedType τ →
     typed Γ e1 τ →
     typed_ctx_item (CTX_BinOpR EqOp e1) Γ τ Γ TBool
  | TP_CTX_IfL Γ e1 e2 τ :
     typed Γ e1 τ → typed Γ e2 τ →
     typed_ctx_item (CTX_IfL e1 e2) Γ (TBool) Γ τ
  | TP_CTX_IfM Γ e0 e2 τ :
     typed Γ e0 (TBool) → typed Γ e2 τ →
     typed_ctx_item (CTX_IfM e0 e2) Γ τ Γ τ
  | TP_CTX_IfR Γ e0 e1 τ :
     typed Γ e0 (TBool) → typed Γ e1 τ →
     typed_ctx_item (CTX_IfR e0 e1) Γ τ Γ τ
  (* Products *)
  | TP_CTX_PairL Γ e2 τ τ' :
     typed Γ e2 τ' →
     typed_ctx_item (CTX_PairL e2) Γ τ Γ (TProd τ τ')
  | TP_CTX_PairR Γ e1 τ τ' :
     typed Γ e1 τ →
     typed_ctx_item (CTX_PairR e1) Γ τ' Γ (TProd τ τ')
  | TP_CTX_Fst Γ τ τ' :
     typed_ctx_item CTX_Fst Γ (TProd τ τ') Γ τ
  | TP_CTX_Snd Γ τ τ' :
     typed_ctx_item CTX_Snd Γ (TProd τ τ') Γ τ'
  (* Sums *)
  | TP_CTX_InjL Γ τ τ' :
     typed_ctx_item CTX_InjL Γ τ Γ (TSum τ τ')
  | TP_CTX_InjR Γ τ τ' :
     typed_ctx_item CTX_InjR Γ τ' Γ (TSum τ τ')
  | TP_CTX_CaseL Γ e1 e2 τ1 τ2 τ' :
     typed Γ e1 (TArrow τ1 τ') → typed Γ e2 (TArrow τ2 τ') →
     typed_ctx_item (CTX_CaseL e1 e2) Γ (TSum τ1 τ2) Γ τ'
  | TP_CTX_CaseM Γ e0 e2 τ1 τ2 τ' :
     typed Γ e0 (TSum τ1 τ2) → typed Γ e2 (TArrow τ2 τ') →
     typed_ctx_item (CTX_CaseM e0 e2) Γ (TArrow τ1 τ') Γ τ'
  | TP_CTX_CaseR Γ e0 e1 τ1 τ2 τ' :
     typed Γ e0 (TSum τ1 τ2) → typed Γ e1 (TArrow τ1 τ') →
     typed_ctx_item (CTX_CaseR e0 e1) Γ (TArrow τ2 τ') Γ τ'
  (* Heap *)
  | TPCTX_Alloc Γ τ :
     typed_ctx_item CTX_Alloc Γ τ Γ (TRef τ)
  | TP_CTX_Load Γ τ :
     typed_ctx_item CTX_Load Γ (TRef τ) Γ τ
  | TP_CTX_StoreL Γ e2 τ :
     typed Γ e2 τ → typed_ctx_item (CTX_StoreL e2) Γ (TRef τ) Γ ()
  | TP_CTX_StoreR Γ e1 τ :
     typed Γ e1 (TRef τ) →
     typed_ctx_item (CTX_StoreR e1) Γ τ Γ ()
  (* Polymorphic & recursive types *)
  | TP_CTX_Fold Γ τ :
     typed_ctx_item CTX_Fold Γ τ.[(TRec τ)/] Γ (TRec τ)
  | TP_CTX_Unfold Γ τ :
     typed_ctx_item CTX_Unfold Γ (TRec τ) Γ τ.[(TRec τ)/]
  | TP_CTX_TLam Γ τ :
     typed_ctx_item CTX_TLam (Autosubst_Classes.subst (ren (+1)) <$> Γ) τ Γ (TForall τ)
  | TP_CTX_TApp Γ τ τ' :
     typed_ctx_item CTX_TApp Γ (TForall τ) Γ τ.[τ'/]
  (* | TP_CTX_Pack Γ τ τ' : *)
  (*    typed_ctx_item CTX_Pack Γ τ.[τ'/] Γ (TExists τ) *)
  | TP_CTX_UnpackL x e2 Γ τ τ2 :
     <[x:=τ]>(⤉ Γ) ⊢ₜ e2 : (Autosubst_Classes.subst (ren (+1)) τ2) →
     typed_ctx_item (CTX_UnpackL x e2) Γ (TExists τ) Γ τ2
  | TP_CTX_UnpackR x e1 Γ τ τ2 :
      Γ ⊢ₜ e1 : TExists τ →
     typed_ctx_item (CTX_UnpackR x e1)
                    (<[x:=τ]>(⤉ Γ)) (Autosubst_Classes.subst (ren (+1)) τ2)
                    Γ τ2
  | TP_CTX_Flip Γ :
     typed_ctx_item CTX_Flip Γ TTape Γ (TBool)
.

Inductive typed_ctx: ctx → stringmap type → type → stringmap type → type → Prop :=
  | TPCTX_nil Γ τ :
     typed_ctx nil Γ τ Γ τ
  | TPCTX_cons Γ1 τ1 Γ2 τ2 Γ3 τ3 k K :
     typed_ctx_item k Γ2 τ2 Γ3 τ3 →
     typed_ctx K Γ1 τ1 Γ2 τ2 →
     typed_ctx (k :: K) Γ1 τ1 Γ3 τ3.

(** The main definition of contextual refinement that we use. An
    alternative (equivalent) formulation which observes only
    termination can be found in [contextual_refinement_alt.v] *)
Definition ctx_refines (Γ : stringmap type)
    (e e' : expr) (τ : type) : Prop := ∀ K σ₀ (b : bool),
  typed_ctx K Γ τ ∅ TBool →
  (lim_exec_val (fill_ctx K e, σ₀) #b <= lim_exec_val (fill_ctx K e', σ₀) #b)%R.

Notation "Γ ⊨ e '≤ctx≤' e' : τ" :=
  (ctx_refines Γ e e' τ) (at level 100, e, e' at next level, τ at level 200).

Lemma typed_ctx_item_typed k Γ τ Γ' τ' e :
  typed Γ e τ → typed_ctx_item k Γ τ Γ' τ' →
  typed Γ' (fill_ctx_item k e) τ'.
Proof. induction 2; simpl; eauto using typed. Qed.

Lemma typed_ctx_typed K Γ τ Γ' τ' e :
  typed Γ e τ → typed_ctx K Γ τ Γ' τ' → typed Γ' (fill_ctx K e) τ'.
Proof. induction 2; simpl; eauto using typed_ctx_item_typed. Qed.

Global Instance ctx_refines_reflexive Γ τ :
  Reflexive (fun e1 e2 => ctx_refines Γ e1 e2 τ).
Proof. intros ?????. done. Qed.

Global Instance ctx_refines_transitive Γ τ :
  Transitive (fun e1 e2 => ctx_refines Γ e1 e2 τ).
Proof.
  intros e1 e2 e3 Hctx1 Hctx2 K σ₀ b Hty.
  pose proof (Hctx1 K σ₀ b Hty) as H1.
  pose proof (Hctx2 K σ₀ b Hty) as H2.
  by etrans.
Qed.

Lemma fill_ctx_app (K K' : ctx) (e : expr) :
  fill_ctx K' (fill_ctx K e) = fill_ctx (K' ++ K) e.
Proof. by rewrite /fill_ctx foldr_app. Qed.

Lemma typed_ctx_compose (K K' : ctx) (Γ1 Γ2 Γ3 : stringmap type) (τ1 τ2 τ3 : type) :
  typed_ctx K Γ1 τ1 Γ2 τ2 →
  typed_ctx K' Γ2 τ2 Γ3 τ3 →
  typed_ctx (K' ++ K) Γ1 τ1 Γ3 τ3.
Proof.
  revert Γ1 Γ2 Γ3 τ1 τ2 τ3.
  induction K' as [|k K'] => Γ1 Γ2 Γ3 τ1 τ2 τ3.
  - by inversion 2; simplify_eq/=.
  - intros HK.
    inversion 1 as [|? ? ? ? ? ? ? ? Hx1 Hx2]; simplify_eq/=.
    specialize (IHK' _ _ _ _ _ _ HK Hx2).
    econstructor; eauto.
Qed.

Lemma ctx_refines_congruence Γ e1 e2 τ Γ' τ' K :
  typed_ctx K Γ τ Γ' τ' →
  (Γ ⊨ e1 ≤ctx≤ e2 : τ) →
  Γ' ⊨ fill_ctx K e1 ≤ctx≤ fill_ctx K e2 : τ'.
Proof.
  intros HK Hctx K' σ₀ b Hty.
  rewrite !fill_ctx_app.
  apply (Hctx (K' ++ K) σ₀); auto.
  eapply typed_ctx_compose; eauto.
Qed.

Definition ctx_equiv Γ e1 e2 τ :=
  (Γ ⊨ e1 ≤ctx≤ e2 : τ) ∧ (Γ ⊨ e2 ≤ctx≤ e1 : τ).

Notation "Γ ⊨ e '=ctx=' e' : τ" :=
  (ctx_equiv Γ e e' τ) (at level 100, e, e' at next level, τ at level 200).

Section bin_log_related_under_typed_ctx.
  Context `{!prelogrelGS Σ}.

  (* Precongruence *)
  Lemma bin_log_related_under_typed_ctx Γ e e' τ Γ' τ' K :
    (typed_ctx K Γ τ Γ' τ') →
    (□ ∀ Δ, ({Δ;Γ} ⊨ e ≤log≤ e' : τ)) -∗
      (∀ Δ, {Δ;Γ'} ⊨ fill_ctx K e ≤log≤ fill_ctx K e' : τ')%I.
  Proof.
    revert Γ τ Γ' τ' e e'.
    induction K as [|k K]=> Γ τ Γ' τ' e e'; simpl.
    - inversion_clear 1; trivial. iIntros "#H".
      iIntros (Δ). by iApply "H".
    - inversion_clear 1 as [|? ? ? ? ? ? ? ? Hx1 Hx2].
      specialize (IHK _ _ _ _ e e' Hx2).
      inversion Hx1; subst; simpl; iIntros "#Hrel";
        iIntros (Δ).
      + iApply (bin_log_related_rec with "[-]"); auto.
        iModIntro. iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_app with "[]").
        { iApply (IHK with "[Hrel]"); auto. }
        by iApply fundamental.
      + iApply (bin_log_related_app _ _ _ _ _ _ τ2 with "[]").
        { by iApply fundamental. }
        iApply (IHK with "[Hrel]"); auto.
      + iApply bin_log_related_int_unop; eauto.
        by iApply (IHK with "Hrel").
      + iApply bin_log_related_bool_unop; eauto.
        by iApply (IHK with "Hrel").
      + iApply bin_log_related_int_binop;
          try (by iApply fundamental); eauto.
        by iApply (IHK with "Hrel").
      + iApply bin_log_related_int_binop;
          try (by iApply fundamental); eauto.
        by iApply (IHK with "Hrel"); auto.
      + iApply bin_log_related_bool_binop;
          try (by iApply fundamental); eauto.
        by iApply (IHK with "Hrel").
      + iApply bin_log_related_bool_binop;
          try (by iApply fundamental); eauto.
        by iApply (IHK with "Hrel").
      + iApply bin_log_related_unboxed_eq; try (eassumption || by iApply fundamental).
        by iApply (IHK with "Hrel").
      + iApply bin_log_related_unboxed_eq; try (eassumption || by iApply fundamental).
        by iApply (IHK with "Hrel").
      + iApply (bin_log_related_if with "[] []");
          try by iApply fundamental.
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_if with "[] []");
          try by iApply fundamental.
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_if with "[] []");
          try by iApply fundamental.
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_pair with "[]").
        { iApply (IHK with "[Hrel]"); auto. }
        by iApply fundamental.
      + iApply (bin_log_related_pair with "[]").
        { by iApply fundamental. }
        iApply (IHK with "[Hrel]"); auto.
      + iApply bin_log_related_fst.
        iApply (IHK with "[Hrel]"); auto.
      + iApply bin_log_related_snd.
        iApply (IHK with "[Hrel]"); auto.
      + iApply bin_log_related_injl.
        iApply (IHK with "[Hrel]"); auto.
      + iApply bin_log_related_injr.
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_case with "[] []").
        { iApply (IHK with "[Hrel]"); auto. }
        { by iApply fundamental. }
        by iApply fundamental.
      + iApply (bin_log_related_case with "[] []").
        { by iApply fundamental. }
        { iApply (IHK with "[Hrel]"); auto. }
        by iApply fundamental.
      + iApply (bin_log_related_case with "[] []").
        { by iApply fundamental. }
        { by iApply fundamental. }
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_alloc with "[]").
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_load with "[]").
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_store with "[]");
          try by iApply fundamental.
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_store with "[]");
          try by iApply fundamental.
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_fold with "[]").
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_unfold with "[]").
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_tlam with "[]").
        iIntros (τi). iModIntro.
        iApply (IHK with "[Hrel]"); auto.
      + iApply (bin_log_related_tapp' with "[]").
        iApply (IHK with "[Hrel]"); auto.
      + iApply bin_log_related_unpack.
        * iApply (IHK with "[Hrel]"); auto.
        * iIntros (A). by iApply fundamental.
      + iApply bin_log_related_unpack.
        * by iApply fundamental.
        * iIntros (A). iApply (IHK with "[Hrel]"); auto.
      + iApply bin_log_related_flip.
        iApply (IHK with "[Hrel]"); auto.
  Qed.
End bin_log_related_under_typed_ctx.


From isla Require Import opsem.

Definition a7434 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 16%N)) Mk_annot :t:
  Smt (DeclareConst 92%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R6" [] (RegVal_Base (Val_Symbolic 92%Z)) Mk_annot :t:
  Smt (DefineConst 95%Z (Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Symbolic 92%Z) Mk_annot; Val (Val_Bits (BV 64%N 0xffffffffffff%Z)) Mk_annot] Mk_annot; Binop ((Bvarith Bvshl)) (Unop (ZeroExtend 48%N) (Val (Val_Symbolic 0%Z) Mk_annot) Mk_annot) (Val (Val_Bits (BV 64%N 0x30%Z)) Mk_annot) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R6" [] (RegVal_Base (Val_Symbolic 95%Z)) Mk_annot :t:
  Smt (DeclareConst 96%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 96%Z)) Mk_annot :t:
  Smt (DefineConst 97%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 96%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 97%Z)) Mk_annot :t:
  tnil
.