(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Lia.
Require Import Utils.
Require Import DataRuntime.
Require Import NRARuntime.
Require Import NRAEnvRuntime.
Require Import CAMPRuntime.
Require Import CAMPtoNRA.
Require Import CAMPtocNRAEnv.

Section CAMPtoNRAEnv.
  Context {fruntime:foreign_runtime}.

  (** Functions used to map input/ouput values between CAMP and NRA *)
  (* Input encoding *)

  (* Match failure returns the empty sequence, success returns a singleton sequence *)
  (* Java equivalent: CampToNra.nraenv_fail *)
  Definition nraenv_fail := NRAEnvConst (dcoll nil).
  (* Java equivalent: CampToNra.nraenv_match *)
  Definition nraenv_match op := NRAEnvUnop OpBag op.

  (** Translation from CAMP to EnvNRA *)

  (* Java equivalent: CampToNra.cnraenv_of_camp *)
  Fixpoint nraenv_of_camp (p:camp) : nraenv :=
    match p with
      | pconst d' => nraenv_match (NRAEnvConst d')
      | punop uop p₁ => NRAEnvMap (NRAEnvUnop uop NRAEnvID) (nraenv_of_camp p₁)
      | pbinop bop p₁ p₂ =>
        NRAEnvMap
          (NRAEnvBinop bop (NRAEnvUnop (OpDot "a1") NRAEnvID) (NRAEnvUnop (OpDot "a2") NRAEnvID))
          (NRAEnvProduct (NRAEnvMap (NRAEnvUnop (OpRec "a1") NRAEnvID) (nraenv_of_camp p₁))
                         (NRAEnvMap (NRAEnvUnop (OpRec "a2") NRAEnvID) (nraenv_of_camp p₂)))
      | pmap p₁ =>
        nraenv_match
          (NRAEnvUnop OpFlatten
                  (NRAEnvMap
                     (nraenv_of_camp p₁) NRAEnvID))
      | passert p₁ =>
        NRAEnvMap (NRAEnvConst (drec nil)) (NRAEnvSelect NRAEnvID (nraenv_of_camp p₁))
      | porElse p₁ p₂ => NRAEnvDefault (nraenv_of_camp p₁) (nraenv_of_camp p₂)
      | pit => nraenv_match NRAEnvID
      | pletIt p₁ p₂ =>
        NRAEnvUnop OpFlatten
               (NRAEnvMap (nraenv_of_camp p₂)
                      (nraenv_of_camp p₁))
      | pgetConstant s => nraenv_match (NRAEnvGetConstant s)
      | penv => nraenv_match NRAEnvEnv
      | pletEnv p₁ p₂ =>
        NRAEnvUnop OpFlatten
               (NRAEnvAppEnv
                  (NRAEnvMapEnv (nraenv_of_camp p₂))
                  (NRAEnvUnop OpFlatten
                              (NRAEnvMap
                                 (NRAEnvBinop OpRecMerge NRAEnvEnv NRAEnvID)
                                 (nraenv_of_camp p₁))))
      | pleft =>
        NRAEnvEither (nraenv_match NRAEnvID) (nraenv_fail)
      | pright =>
        NRAEnvEither (nraenv_fail) (nraenv_match NRAEnvID)
    end.

  (** top level version sets up the appropriate input
      (with an empty context)
  *)

  Definition nraenv_of_camp_top p :=
    NRAEnvUnop OpFlatten
           (NRAEnvMap (nraenv_of_camp p) (NRAEnvUnop OpBag NRAEnvID)).

  (** Theorem 4.2: lemma of translation correctness for patterns *)

  Lemma nraenv_of_camp_nraenv_core_of_camp_ident q :
    nraenv_to_nraenv_core (nraenv_of_camp q) = nraenv_core_of_camp q.
  Proof.
    induction q; intros; try reflexivity; simpl;
    try (rewrite IHq; try reflexivity);
    try (rewrite IHq1; rewrite IHq2; try reflexivity).
  Qed.

  Lemma nraenv_of_camp_correct h c q env d:
    lift_failure (camp_eval h c q env d) = nraenv_eval h c (nraenv_of_camp q) (drec env) d.
  Proof.
    rewrite nraenv_core_of_camp_correct.
    unfold nraenv_eval.
    rewrite nraenv_of_camp_nraenv_core_of_camp_ident.
    reflexivity.
  Qed.

  Lemma nraenv_of_camp_equiv_to_nra h c p bind d:
    nra_eval h c (nra_of_camp p) (nra_context_data (drec bind) d) =
    nraenv_eval h c (nraenv_of_camp p) (drec bind) d.
  Proof.
    rewrite <- nraenv_of_camp_correct.
    rewrite camp_trans_correct; reflexivity.
  Qed.

  Lemma nraenv_of_camp_top_id h c p d :
    Forall (fun x => data_normalized h (snd x)) c ->
    nra_eval h c (nra_of_camp_top p) d =
    nraenv_eval h c (nraenv_of_camp_top p) (drec nil) d.
  Proof.
    intros.
    unfold nraenv_of_camp_top.
    generalize nraenv_of_camp_equiv_to_nra; intros Hequiv.
    unfold nraenv_eval in *; simpl in *.
    rewrite <- Hequiv.
    unfold nra_context_data.
    reflexivity.
  Qed.

  Lemma ecamp_trans_top_correct h c p d:
    Forall (fun x => data_normalized h (snd x)) c ->
    lift_failure (camp_eval h c p nil d) = nraenv_eval h c (nraenv_of_camp_top p) (drec nil) d.
  Proof.
    intros.
    rewrite <- (nraenv_of_camp_top_id h c); trivial.
    rewrite camp_trans_correct.
    rewrite camp_trans_top_nra_context; trivial; reflexivity.
  Qed.

  Section Top.
    Context (h:brand_relation_t).

    (* Java equivalent: CampToNra.convert *)
    Definition camp_to_nraenv_top (q:camp) : nraenv :=
      (* Produces the initial plan *)
      NRAEnvAppEnv (nraenv_of_camp q) (NRAEnvConst (drec nil)).

    Theorem camp_to_nraenv_top_correct :
      forall q:camp, forall global_env:bindings,
          camp_eval_top h q global_env =
          nraenv_eval_top h (camp_to_nraenv_top q) global_env.
    Proof.
      intros.
      apply nraenv_of_camp_correct.
    Qed.

  End Top.

  Section size.
    (** Proof showing linear size translation *)
    Lemma camp_trans_size p :
      nraenv_size (nraenv_of_camp p) <= 13 * camp_size p.
    Proof.
      induction p; simpl; lia.
    Qed.

  End size.

  Section sugar.
    Definition nraenv_of_pand (p1 p2:camp) : nraenv :=
      nraenv_of_camp (pand p1 p2).

    Definition nraenv_for_pand (q1 q2: nraenv) : nraenv :=
      NRAEnvUnop OpFlatten
                 (NRAEnvAppEnv (NRAEnvMapEnv q2)
                               (NRAEnvUnop OpFlatten
                                           (NRAEnvMap (NRAEnvBinop OpRecMerge NRAEnvEnv NRAEnvID)
                                                      (NRAEnvMap (NRAEnvConst (drec nil))
                                                                 (NRAEnvSelect NRAEnvID q1))))).

    Lemma nraenv_of_pand_works (p1 p2:camp) :
      nraenv_of_camp (pand p1 p2) = nraenv_for_pand (nraenv_of_camp p1) (nraenv_of_camp p2).
    Proof.
      reflexivity.
    Qed.

    (* WW *)

    Definition nraenv_of_WW (p:camp) :=
      nraenv_of_camp (WW p).

  End sugar.

End CAMPtoNRAEnv.


(* Lifted from https://coq.inria.fr/bugs/show_bug.cgi?id=4187 *)
(* File reduced by coq-bug-finder from original input, then from 715 lines to 696 lines *)
(* coqc version 8.4pl5 (December 2014) compiled on Dec 28 2014 03:23:16 with OCaml 4.01.0
   coqtop version 8.4pl5 (December 2014) *)
Set Asymmetric Patterns.
Axiom proof_admitted : False.
Tactic Notation "admit" := case proof_admitted.
Require Import Coq.Lists.List.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Global Set Implicit Arguments.
Global Generalizable All Variables.
Coercion is_true : bool >-> Sortclass.
Coercion bool_of_sumbool {A B} (x : {A} + {B}) : bool := if x then true else false.
Fixpoint ForallT {T} (P : T -> Type) (ls : list T) : Type
  := match ls return Type with
       | nil => True
       | x::xs => (P x * ForallT P xs)%type
     end.
Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type
  := match ls with
       | nil => P nil
       | x::xs => (P (x::xs) * Forall_tails P xs)%type
     end.

Module Export ADTSynthesis_DOT_Common_DOT_Wf.
Module Export ADTSynthesis.
Module Export Common.
Module Export Wf.

Section wf.
  Section wf_prod.
    Context A B (RA : relation A) (RB : relation B).
Definition prod_relation : relation (A * B).
exact (fun ab a'b' =>
           RA (fst ab) (fst a'b') \/ (fst a'b' = fst ab /\ RB (snd ab) (snd a'b'))).
Defined.

    Fixpoint well_founded_prod_relation_helper
             a b
             (wf_A : Acc RA a) (wf_B : well_founded RB) {struct wf_A}
    : Acc prod_relation (a, b)
      := match wf_A with
           | Acc_intro fa => (fix wf_B_rec b' (wf_B' : Acc RB b') : Acc prod_relation (a, b')
                              := Acc_intro
                                   _
                                   (fun ab =>
                                      match ab as ab return prod_relation ab (a, b') -> Acc prod_relation ab with
                                        | (a'', b'') =>
                                          fun pf =>
                                            match pf with
                                              | or_introl pf'
                                                => @well_founded_prod_relation_helper
                                                     _ _
                                                     (fa _ pf')
                                                     wf_B
                                              | or_intror (conj pfa pfb)
                                                => match wf_B' with
                                                     | Acc_intro fb
                                                       => eq_rect
                                                            _
                                                            (fun a'' => Acc prod_relation (a'', b''))
                                                            (wf_B_rec _ (fb _ pfb))
                                                            _
                                                            pfa
                                                   end
                                            end
                                      end)
                             ) b (wf_B b)
         end.

    Definition well_founded_prod_relation : well_founded RA -> well_founded RB -> well_founded prod_relation.
    Proof.
      intros wf_A wf_B [a b]; hnf in *.
      apply well_founded_prod_relation_helper; auto.
    Defined.
  End wf_prod.

  Section wf_projT1.
    Context A (B : A -> Type) (R : relation A).
Definition projT1_relation : relation (sigT B).
exact (fun ab a'b' =>
           R (projT1 ab) (projT1 a'b')).
Defined.

    Definition well_founded_projT1_relation : well_founded R -> well_founded projT1_relation.
    Proof.
      intros wf [a b]; hnf in *.
      induction (wf a) as [a H IH].
      constructor.
      intros y r.
      specialize (IH _ r (projT2 y)).
      destruct y.
      exact IH.
    Defined.
  End wf_projT1.
End wf.

Section Fix3.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c, D a b c -> Type)
          (F : forall x : A, (forall y : A, R y x -> forall b c d, P y b c d) -> forall b c d, P x b c d).
Definition Fix3 a b c d : @P a b c d.
exact (@Fix { a : A & { b : B a & { c : C b & D c } } }
            (fun x y => R (projT1 x) (projT1 y))
            (well_founded_projT1_relation Rwf)
            (fun abcd => P (projT2 (projT2 (projT2 abcd))))
            (fun x f => @F (projT1 x) (fun y r b c d => f (existT _ y (existT _ b (existT _ c d))) r) _ _ _)
            (existT _ a (existT _ b (existT _ c d)))).
Defined.
End Fix3.

End Wf.

End Common.

End ADTSynthesis.

End ADTSynthesis_DOT_Common_DOT_Wf.

Module Export ADTSynthesis_DOT_Parsers_DOT_StringLike_DOT_Core.
Module Export ADTSynthesis.
Module Export Parsers.
Module Export StringLike.
Module Export Core.
Import Coq.Setoids.Setoid.
Import Coq.Classes.Morphisms.

Module Export StringLike.
  Class StringLike {Char : Type} :=
    {
      String :> Type;
      is_char : String -> Char -> bool;
      length : String -> nat;
      take : nat -> String -> String;
      drop : nat -> String -> String;
      bool_eq : String -> String -> bool;
      beq : relation String := fun x y => bool_eq x y
    }.

  Arguments StringLike : clear implicits.
  Infix "=s" := (@beq _ _) (at level 70, no associativity) : type_scope.
  Notation "s ~= [ ch ]" := (is_char s ch) (at level 70, no associativity) : string_like_scope.
  Local Open Scope string_like_scope.

  Definition str_le `{StringLike Char} (s1 s2 : String)
    := length s1 < length s2 \/ s1 =s s2.
  Infix "≤s" := str_le (at level 70, right associativity).

  Class StringLikeProperties (Char : Type) `{StringLike Char} :=
    {
      singleton_unique : forall s ch ch', s ~= [ ch ] -> s ~= [ ch' ] -> ch = ch';
      length_singleton : forall s ch, s ~= [ ch ] -> length s = 1;
      bool_eq_char : forall s s' ch, s ~= [ ch ] -> s' ~= [ ch ] -> s =s s';
      is_char_Proper :> Proper (beq ==> eq ==> eq) is_char;
      length_Proper :> Proper (beq ==> eq) length;
      take_Proper :> Proper (eq ==> beq ==> beq) take;
      drop_Proper :> Proper (eq ==> beq ==> beq) drop;
      bool_eq_Equivalence :> Equivalence beq;
      bool_eq_empty : forall str str', length str = 0 -> length str' = 0 -> str =s str';
      take_short_length : forall str n, n <= length str -> length (take n str) = n;
      take_long : forall str n, length str <= n -> take n str =s str;
      take_take : forall str n m, take n (take m str) =s take (min n m) str;
      drop_length : forall str n, length (drop n str) = length str - n;
      drop_0 : forall str, drop 0 str =s str;
      drop_drop : forall str n m, drop n (drop m str) =s drop (n + m) str;
      drop_take : forall str n m, drop n (take m str) =s take (m - n) (drop n str);
      take_drop : forall str n m, take n (drop m str) =s drop m (take (n + m) str)
    }.

  Arguments StringLikeProperties Char {_}.
End StringLike.

End Core.

End StringLike.

End Parsers.

End ADTSynthesis.

End ADTSynthesis_DOT_Parsers_DOT_StringLike_DOT_Core.

Module Export ADTSynthesis.
Module Export Parsers.
Module Export ContextFreeGrammar.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Export ADTSynthesis.Parsers.StringLike.Core.
Import ADTSynthesis.Common.

Local Open Scope string_like_scope.

Section cfg.
  Context {Char : Type}.

  Section definitions.

    Inductive item :=
    | Terminal (_ : Char)
    | NonTerminal (_ : string).

    Definition production := list item.
    Definition productions := list production.

    Record grammar :=
      {
        Start_symbol :> string;
        Lookup :> string -> productions;
        Start_productions :> productions := Lookup Start_symbol;
        Valid_nonterminals : list string;
        Valid_productions : list productions := map Lookup Valid_nonterminals
      }.
  End definitions.

  Section parse.
    Context {HSL : StringLike Char}.
    Variable G : grammar.

    Inductive parse_of (str : String) : productions -> Type :=
    | ParseHead : forall pat pats, parse_of_production str pat
                                   -> parse_of str (pat::pats)
    | ParseTail : forall pat pats, parse_of str pats
                                   -> parse_of str (pat::pats)
    with parse_of_production (str : String) : production -> Type :=
    | ParseProductionNil : length str = 0 -> parse_of_production str nil
    | ParseProductionCons : forall n pat pats,
                              parse_of_item (take n str) pat
                              -> parse_of_production (drop n str) pats
                              -> parse_of_production str (pat::pats)
    with parse_of_item (str : String) : item -> Type :=
    | ParseTerminal : forall ch, str ~= [ ch ] -> parse_of_item str (Terminal ch)
    | ParseNonTerminal : forall nt, parse_of str (Lookup G nt)
                                    -> parse_of_item str (NonTerminal nt).
  End parse.
End cfg.

Arguments item _ : clear implicits.
Arguments production _ : clear implicits.
Arguments productions _ : clear implicits.
Arguments grammar _ : clear implicits.

End ContextFreeGrammar.

Module Export BaseTypes.

Section recursive_descent_parser.

  Class parser_computational_predataT :=
    { nonterminals_listT : Type;
      initial_nonterminals_data : nonterminals_listT;
      is_valid_nonterminal : nonterminals_listT -> String.string -> bool;
      remove_nonterminal : nonterminals_listT -> String.string -> nonterminals_listT;
      nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop;
      remove_nonterminal_dec : forall ls nonterminal,
                                 is_valid_nonterminal ls nonterminal
                                 -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls;
      ntl_wf : well_founded nonterminals_listT_R }.

  Class parser_removal_dataT' `{predata : parser_computational_predataT} :=
    { remove_nonterminal_1
      : forall ls ps ps',
          is_valid_nonterminal (remove_nonterminal ls ps) ps'
          -> is_valid_nonterminal ls ps';
      remove_nonterminal_2
      : forall ls ps ps',
          is_valid_nonterminal (remove_nonterminal ls ps) ps' = false
          <-> is_valid_nonterminal ls ps' = false \/ ps = ps' }.
End recursive_descent_parser.

End BaseTypes.
Import Coq.Lists.List.
Import ADTSynthesis.Parsers.ContextFreeGrammar.

Local Open Scope string_like_scope.

Section cfg.
  Context {Char} {HSL : StringLike Char} {G : grammar Char}.
  Context {predata : @parser_computational_predataT}
          {rdata' : @parser_removal_dataT' predata}.

  Inductive minimal_parse_of
  : forall (str0 : String) (valid : nonterminals_listT)
           (str : String),
      productions Char -> Type :=
  | MinParseHead : forall str0 valid str pat pats,
                     @minimal_parse_of_production str0 valid str pat
                     -> @minimal_parse_of str0 valid str (pat::pats)
  | MinParseTail : forall str0 valid str pat pats,
                     @minimal_parse_of str0 valid str pats
                     -> @minimal_parse_of str0 valid str (pat::pats)
  with minimal_parse_of_production
  : forall (str0 : String) (valid : nonterminals_listT)
           (str : String),
      production Char -> Type :=
  | MinParseProductionNil : forall str0 valid str,
                              length str = 0
                              -> @minimal_parse_of_production str0 valid str nil
  | MinParseProductionCons : forall str0 valid str n pat pats,
                               str ≤s str0
                               -> @minimal_parse_of_item str0 valid (take n str) pat
                               -> @minimal_parse_of_production str0 valid (drop n str) pats
                               -> @minimal_parse_of_production str0 valid str (pat::pats)
  with minimal_parse_of_item
  : forall (str0 : String) (valid : nonterminals_listT)
           (str : String),
      item Char -> Type :=
  | MinParseTerminal : forall str0 valid str ch,
                         str ~= [ ch ]
                         -> @minimal_parse_of_item str0 valid str (Terminal ch)
  | MinParseNonTerminal
    : forall str0 valid str (nt : String.string),
        @minimal_parse_of_nonterminal str0 valid str nt
        -> @minimal_parse_of_item str0 valid str (NonTerminal nt)
  with minimal_parse_of_nonterminal
  : forall (str0 : String) (valid : nonterminals_listT)
           (str : String),
      String.string -> Type :=
  | MinParseNonTerminalStrLt
    : forall str0 valid (nt : String.string) str,
        length str < length str0
        -> is_valid_nonterminal initial_nonterminals_data nt
        -> @minimal_parse_of str initial_nonterminals_data str (Lookup G nt)
        -> @minimal_parse_of_nonterminal str0 valid str nt
  | MinParseNonTerminalStrEq
    : forall str0 str valid nonterminal,
        str =s str0
        -> is_valid_nonterminal initial_nonterminals_data nonterminal
        -> is_valid_nonterminal valid nonterminal
        -> @minimal_parse_of str0 (remove_nonterminal valid nonterminal) str (Lookup G nonterminal)
        -> @minimal_parse_of_nonterminal str0 valid str nonterminal.
End cfg.
Import ADTSynthesis.Common.

Section general.
  Context {Char} {HSL : StringLike Char} {G : grammar Char}.

  Class boolean_parser_dataT :=
    { predata :> parser_computational_predataT;
      split_string_for_production
      : item Char -> production Char -> String -> list nat }.

  Global Coercion predata : boolean_parser_dataT >-> parser_computational_predataT.

  Definition split_list_completeT `{data : @parser_computational_predataT}
             {str0 valid}
             (it : item Char) (its : production Char)
             (str : String)
             (pf : str ≤s str0)
             (split_list : list nat)

    := ({ n : nat
              & (minimal_parse_of_item (G := G) (predata := data) str0 valid (take n str) it)
                * (minimal_parse_of_production (G := G) str0 valid (drop n str) its) }%type)
       -> ({ n : nat
                 & (In n split_list)
                   * (minimal_parse_of_item (G := G) str0 valid (take n str) it)
                   * (minimal_parse_of_production (G := G) str0 valid (drop n str) its) }%type).

  Class boolean_parser_completeness_dataT' `{data : boolean_parser_dataT} :=
    { split_string_for_production_complete
      : forall str0 valid str (pf : str ≤s str0) nt,
          is_valid_nonterminal initial_nonterminals_data nt
          -> ForallT
               (Forall_tails
                  (fun prod
                   => match prod return Type with
                        | nil => True
                        | it::its
                          => @split_list_completeT data str0 valid it its str pf (split_string_for_production it its str)
                      end))
               (Lookup G nt) }.
End general.

Module Export BooleanRecognizer.
Import Coq.Numbers.Natural.Peano.NPeano.
Import Coq.Arith.Compare_dec.
Import Coq.Arith.Wf_nat.

Section recursive_descent_parser.
  Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} {G : grammar Char}.
  Context {data : @boolean_parser_dataT Char _}.

  Section bool.
    Section parts.
Definition parse_item
                 (str_matches_nonterminal : String.string -> bool)
                 (str : String)
                 (it : item Char)
      : bool.
Admitted.

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

        Fixpoint parse_production
                 (str : String)
                 (pf : str ≤s str0)
                 (prod : production Char)
        : bool.
        Proof.
          refine
            match prod with
              | nil =>

                Nat.eq_dec (length str) 0
              | it::its
                => let parse_production' := fun str pf => parse_production str pf its in
                   fold_right
                     orb
                     false
                     (map (fun n =>
                             (parse_item
                                (parse_nonterminal (str := take n str) _)
                                (take n str)
                                it)
                               && parse_production' (drop n str) _)%bool
                          (split_string_for_production it its str))
            end;
          revert pf; clear -HSLP; intros; admit.
        Defined.
      End production.

      Section productions.
        Context {str0}
                (parse_nonterminal
                 : forall (str : String)
                          (pf : str ≤s str0),
                     String.string -> bool).
Definition parse_productions
                   (str : String)
                   (pf : str ≤s str0)
                   (prods : productions Char)
        : bool.
exact (fold_right orb
                        false
                        (map (parse_production parse_nonterminal pf)
                             prods)).
Defined.
      End productions.

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

          Definition parse_nonterminal_step
                     (str : String)
                     (pf : str ≤s str0)
                     (nt : String.string)
          : bool.
          Proof.
            refine
              (if lt_dec (length str) (length str0)
               then
                 parse_productions
                   (@parse_nonterminal
                      (str : String, initial_nonterminals_data)
                      (or_introl _))
                   (or_intror (reflexivity _))
                   (Lookup G nt)
               else
                 if Sumbool.sumbool_of_bool (is_valid_nonterminal valid nt)
                 then
                   parse_productions
                     (@parse_nonterminal
                        (str0 : String, remove_nonterminal valid nt)
                        (or_intror (conj eq_refl (remove_nonterminal_dec _ nt _))))
                     (str := str)
                     _
                     (Lookup G nt)
                 else
                   false);
            assumption.
          Defined.
        End step.

        Section wf.
Definition parse_nonterminal_or_abort
          : forall (p : String * nonterminals_listT)
                   (str : String),
              str ≤s fst p
              -> String.string
              -> bool.
exact (Fix3
                 _ _ _
                 (well_founded_prod_relation
                    (well_founded_ltof _ length)
                    ntl_wf)
                 _
                 (fun sl => @parse_nonterminal_step (fst sl) (snd sl))).
Defined.
Definition parse_nonterminal
                     (str : String)
                     (nt : String.string)
          : bool.
exact (@parse_nonterminal_or_abort
                 (str : String, initial_nonterminals_data) str
                 (or_intror (reflexivity _)) nt).
Defined.
        End wf.
      End nonterminals.
    End parts.
  End bool.
End recursive_descent_parser.

Section cfg.
  Context {Char} {HSL : StringLike Char} {HSLP : @StringLikeProperties Char HSL} (G : grammar Char).

  Section definitions.
    Context (P : String -> String.string -> Type).

    Definition Forall_parse_of_item'
               (Forall_parse_of : forall {str pats} (p : parse_of G str pats), Type)
               {str it} (p : parse_of_item G str it)
      := match p return Type with
           | ParseTerminal ch pf => unit
           | ParseNonTerminal nt p'
             => (P str nt * Forall_parse_of p')%type
         end.

    Fixpoint Forall_parse_of {str pats} (p : parse_of G str pats)
      := match p with
           | ParseHead pat pats p'
             => Forall_parse_of_production p'
           | ParseTail _ _ p'
             => Forall_parse_of p'
         end
    with Forall_parse_of_production {str pat} (p : parse_of_production G str pat)
         := match p return Type with
              | ParseProductionNil pf => unit
              | ParseProductionCons pat strs pats p' p''
                => (Forall_parse_of_item' (@Forall_parse_of) p' * Forall_parse_of_production p'')%type
            end.

    Definition Forall_parse_of_item {str it} (p : parse_of_item G str it)
      := @Forall_parse_of_item' (@Forall_parse_of) str it p.
  End definitions.

  End cfg.

Section recursive_descent_parser_list.
  Context {Char} {HSL : StringLike Char} {HLSP : StringLikeProperties Char} {G : grammar Char}.
Definition rdp_list_nonterminals_listT : Type.
exact (list String.string).
Defined.
Definition rdp_list_is_valid_nonterminal : rdp_list_nonterminals_listT -> String.string -> bool.
admit.
Defined.
Definition rdp_list_remove_nonterminal : rdp_list_nonterminals_listT -> String.string -> rdp_list_nonterminals_listT.
admit.
Defined.
Definition rdp_list_nonterminals_listT_R : rdp_list_nonterminals_listT -> rdp_list_nonterminals_listT -> Prop.
exact (ltof _ (@List.length _)).
Defined.
  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.
admit.
Defined.
  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.

  Global Instance rdp_list_predata : parser_computational_predataT
    := { nonterminals_listT := rdp_list_nonterminals_listT;
         initial_nonterminals_data := Valid_nonterminals G;
         is_valid_nonterminal := rdp_list_is_valid_nonterminal;
         remove_nonterminal := rdp_list_remove_nonterminal;
         nonterminals_listT_R := rdp_list_nonterminals_listT_R;
         remove_nonterminal_dec := rdp_list_remove_nonterminal_dec;
         ntl_wf := rdp_list_ntl_wf }.
End recursive_descent_parser_list.

Section sound.
  Section general.
    Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char).
    Context {data : @boolean_parser_dataT Char _}
            {cdata : @boolean_parser_completeness_dataT' Char _ G data}
            {rdata : @parser_removal_dataT' predata}.

    Section parts.

      Section nonterminals.
        Section wf.

          Lemma parse_nonterminal_sound
                (str : String) (nonterminal : String.string)
          : parse_nonterminal (G := G) str nonterminal
            = true
            -> parse_of_item G str (NonTerminal nonterminal).
admit.
Defined.
        End wf.
      End nonterminals.
    End parts.
  End general.
End sound.

Import Coq.Strings.String.
Import ADTSynthesis.Parsers.ContextFreeGrammar.

Fixpoint list_to_productions {T} (default : T) (ls : list (string * T)) : string -> T
  := match ls with
       | nil => fun _ => default
       | (str, t)::ls' => fun s => if string_dec str s
                                   then t
                                   else list_to_productions default ls' s
     end.

Fixpoint list_to_grammar {T} (default : productions T) (ls : list (string * productions T)) : grammar T
  := {| Start_symbol := hd ""%string (map (@fst _ _) ls);
        Lookup := list_to_productions default ls;
        Valid_nonterminals := map (@fst _ _) ls |}.

Section interface.
  Context {Char} (G : grammar Char).
Definition production_is_reachable (p : production Char) : Prop.
admit.
Defined.
Definition split_list_is_complete `{HSL : StringLike Char} (str : String) (it : item Char) (its : production Char)
             (splits : list nat)
  : Prop.
exact (forall n,
         n <= length str
         -> parse_of_item G (take n str) it
         -> parse_of_production G (drop n str) its
         -> production_is_reachable (it::its)
         -> List.In n splits).
Defined.

  Record Splitter :=
    {
      string_type :> StringLike Char;
      splits_for : String -> item Char -> production Char -> list nat;

      string_type_properties :> StringLikeProperties Char;
      splits_for_complete : forall str it its,
                              split_list_is_complete str it its (splits_for str it its)

    }.
  Global Existing Instance string_type_properties.

  Record Parser (HSL : StringLike Char) :=
    {
      has_parse : @String Char HSL -> bool;

      has_parse_sound : forall str,
                          has_parse str = true
                          -> parse_of_item G str (NonTerminal (Start_symbol G));

      has_parse_complete : forall str (p : parse_of_item G str (NonTerminal (Start_symbol G))),
                             Forall_parse_of_item
                               (fun _ nt => List.In nt (Valid_nonterminals G))
                               p
                             -> has_parse str = true
    }.
End interface.

Module Export ParserImplementation.

Section implementation.
  Context {Char} {G : grammar Char}.
  Context (splitter : Splitter G).

  Local Instance parser_data : @boolean_parser_dataT Char _ :=
    { predata := rdp_list_predata (G := G);
      split_string_for_production it its str
      := splits_for splitter str it its }.

  Program Definition parser : Parser G splitter
    := {| has_parse str := parse_nonterminal (G := G) (data := parser_data) str (Start_symbol G);
          has_parse_sound str Hparse := parse_nonterminal_sound G _ _ Hparse;
          has_parse_complete str p Hp := _ |}.
  Next Obligation.
admit.
Defined.
End implementation.

End ParserImplementation.

Section implementation.
  Context {Char} {ls : list (String.string * productions Char)}.
  Local Notation G := (list_to_grammar (nil::nil) ls) (only parsing).
  Context (splitter : Splitter G).

  Local Instance parser_data : @boolean_parser_dataT Char _ := parser_data splitter.

  Goal forall str : @String Char splitter,
         let G' :=
             @BooleanRecognizer.parse_nonterminal Char splitter splitter G parser_data str G = true in
         G'.
    intros str G'.
    timeout 1 assert (pf' : G') by abstract admit || fail 0 "too early".

    Undo.
    Time assert (pf' : G' -> Prop) by abstract admit. (* 2 s *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


Require Import GMuAnnot.Definitions.
Require Import GMuAnnot.Infrastructure.
Require Import GMuAnnot.Equations.
Require Import TLC.LibTactics.
Require Import TLC.LibEnv.
Require Import TLC.LibLN.

  (* Ht : {Σ, empty}⊢ trm_constructor Tparams Name e1 ∈ T1 ** T2 *)
Lemma CanonicalConstructorType : forall Σ Δ E Tparams Name Ctor e1 T,
    {Σ, Δ, E} ⊢(Treg) trm_constructor Tparams (Name, Ctor) e1 ∈ T ->
    exists Typs, T = typ_gadt Typs Name.
  introv Htyp.
  inversions Htyp.
  rewrite rewrite_open_tt_many_gadt.
  eexists.
  f_equal.
Qed.

Lemma CanonicalConstructorTypeGen : forall Σ Δ E Tparams Ctor e1 T,
    {Σ, Δ, E} ⊢(Treg) trm_constructor Tparams Ctor e1 ∈ T ->
    exists Typs Name, T = typ_gadt Typs Name.
  intros.
  destruct Ctor.
  apply CanonicalConstructorType in H; auto.
  destruct H as [Typs Heq].
  eexists. eexists. eauto.
Qed.

Local Hint Resolve CanonicalConstructorTypeGen.

Ltac contradictory_constructor_type :=
  lazymatch goal with
  | H: {?S, ?D, ?E} ⊢(?TT) trm_constructor ?Ts ?C ?e ∈ ?T |- _ =>
    apply CanonicalConstructorTypeGen in H;
    let Hcontradict := fresh "contradict" in
    destruct H as [? [? Hcontradict]];
    inversion Hcontradict
  end.

Lemma CanonicalFormTuple : forall Σ Δ e T1 T2,
    value e ->
    {Σ, Δ, empty} ⊢(Treg) e ∈ T1 ** T2 ->
    exists v1 v2, e = trm_tuple T1 v1 T2 v2.
  introv Hv Ht.
  inversion Hv; inversion Ht; subst; eauto; try congruence.
  inversions H6.
  - false* binds_empty_inv.
  - contradictory_constructor_type.
Qed.

Lemma CanonicalFormAbs : forall Σ Δ e T1 T2,
    value e ->
    {Σ, Δ, empty} ⊢(Treg) e ∈ T1 ==> T2 ->
    exists v1, e = trm_abs T1 v1.
  introv Hv Ht.
  inversion Hv; inversion Ht; subst; eauto; try congruence.
  - false* binds_empty_inv.
  - contradictory_constructor_type.
Qed.

Lemma CanonicalFormTAbs : forall Σ Δ e T,
    value e ->
    {Σ, Δ, empty} ⊢(Treg) e ∈ typ_all T ->
    exists v1, e = trm_tabs v1.
  introv Hv Ht.
  inversion Hv; inversion Ht; subst; eauto; try congruence.
  - false* binds_empty_inv.
  - contradictory_constructor_type.
Qed.

Lemma CanonicalFormUnit : forall Σ Δ e,
    value e ->
    {Σ, Δ, empty} ⊢(Treg) e ∈ typ_unit ->
    e = trm_unit.
  introv Hv Ht.
  inversion Hv; inversion Ht; subst; eauto; try congruence.
  - false* binds_empty_inv.
  - contradictory_constructor_type.
Qed.

Lemma CanonicalFormGadt : forall Σ Δ e Ts N,
    value e ->
    {Σ, Δ, empty} ⊢(Treg) e ∈ typ_gadt Ts N ->
    exists Ts' C v, e = trm_constructor Ts' (N, C) v.
  introv Hv Ht.
  inversion Hv; inversion Ht; subst; eauto; try congruence.
  - false* binds_empty_inv.
  - rewrite rewrite_open_tt_many_gadt in H8.
    inversions H8.
    inversions H13.
    repeat eexists.
Qed.


Require Import Coq.omega.Omega.
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.CountLets.
Require Import Crypto.Reflection.Named.NameUtil.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.RewriteHyp.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.SpecializeBy.

Local Open Scope core_scope.
Section language.
  Context {base_type_code : Type}
          {Name : Type}.

  Section monad.
    Context (MName : Type) (force : MName -> option Name).

    Lemma split_mnames_firstn_skipn
          (t : flat_type base_type_code) (ls : list MName)
      : split_mnames force t ls
        = (fst (split_mnames force t (firstn (count_pairs t) ls)),
           skipn (count_pairs t) ls).
    Proof.
      apply path_prod_uncurried; simpl.
      revert ls; induction t; split; split_prod;
        repeat first [ progress simpl in *
                     | progress intros
                     | rewrite <- skipn_skipn
                     | reflexivity
                     | progress break_innermost_match_step
                     | apply (f_equal2 (@pair _ _))
                     | rewrite_hyp <- !*
                     | match goal with
                       | [ H : forall ls, snd (split_mnames _ _ _) = _, H' : context[snd (split_mnames _ _ _)] |- _ ]
                         => rewrite H in H'
                       | [ H : _ |- _ ] => first [ rewrite <- firstn_skipn_add in H ]
                       | [ H : forall ls', fst (split_mnames _ _ _) = _, H' : context[fst (split_mnames _ _ (skipn ?n ?ls))] |- _ ]
                         => rewrite (H (skipn n ls)) in H'
                       | [ H : forall ls', fst (split_mnames _ _ _) = _, H' : context[fst (split_mnames _ ?t (firstn (count_pairs ?t + ?n) ?ls))] |- _ ]
                         => rewrite (H (firstn (count_pairs t + n) ls)), firstn_firstn in H' by omega
                       | [ H : forall ls', fst (split_mnames _ _ _) = _, H' : context[fst (split_mnames _ ?t ?ls)] |- _ ]
                         => is_var ls; rewrite (H ls) in H'
                       | [ H : ?x = Some _, H' : ?x = None |- _ ] => congruence
                       | [ H : ?x = Some ?a, H' : ?x = Some ?b |- _ ]
                         => assert (a = b) by congruence; (subst a || subst b)
                       end ].
    Qed.

    Lemma snd_split_mnames_skipn
          (t : flat_type base_type_code) (ls : list MName)
      : snd (split_mnames force t ls) = skipn (count_pairs t) ls.
    Proof. rewrite split_mnames_firstn_skipn; reflexivity. Qed.
    Lemma fst_split_mnames_firstn
          (t : flat_type base_type_code) (ls : list MName)
      : fst (split_mnames force t ls) = fst (split_mnames force t (firstn (count_pairs t) ls)).
    Proof. rewrite split_mnames_firstn_skipn at 1; reflexivity. Qed.

    Lemma mname_list_unique_firstn_skipn n ls
      : mname_list_unique force ls
        -> (mname_list_unique force (firstn n ls)
            /\ mname_list_unique force (skipn n ls)).
    Proof.
      unfold mname_list_unique; intro H; split; intros k N;
        rewrite <- ?firstn_map, <- ?skipn_map, ?skipn_skipn, ?firstn_firstn_min, ?firstn_skipn_add;
        intros; eapply H; try eassumption.
      { apply Min.min_case_strong.
        { match goal with H : _ |- _ => rewrite skipn_firstn in H end;
            eauto using In_firstn. }
        { intro; match goal with H : _ |- _ => rewrite skipn_all in H by (rewrite firstn_length; omega * ) end.
          simpl in *; tauto. } }
      { eauto using In_skipn. }
    Qed.
    Definition mname_list_unique_firstn n ls
      : mname_list_unique force ls -> mname_list_unique force (firstn n ls)
      := fun H => proj1 (@mname_list_unique_firstn_skipn n ls H).
    Definition mname_list_unique_skipn n ls
      : mname_list_unique force ls -> mname_list_unique force (skipn n ls)
      := fun H => proj2 (@mname_list_unique_firstn_skipn n ls H).
    Lemma mname_list_unique_nil
      : mname_list_unique force nil.
    Proof.
      unfold mname_list_unique; simpl; intros ??.
      rewrite firstn_nil, skipn_nil; simpl; auto.
    Qed.
  End monad.

  Lemma split_onames_firstn_skipn
        (t : flat_type base_type_code) (ls : list (option Name))
    : split_onames t ls
      = (fst (split_onames t (firstn (count_pairs t) ls)),
         skipn (count_pairs t) ls).
  Proof. apply split_mnames_firstn_skipn. Qed.
  Lemma snd_split_onames_skipn
        (t : flat_type base_type_code) (ls : list (option Name))
    : snd (split_onames t ls) = skipn (count_pairs t) ls.
  Proof. apply snd_split_mnames_skipn. Qed.
  Lemma fst_split_onames_firstn
        (t : flat_type base_type_code) (ls : list (option Name))
    : fst (split_onames t ls) = fst (split_onames t (firstn (count_pairs t) ls)).
  Proof. apply fst_split_mnames_firstn. Qed.

  Lemma oname_list_unique_firstn n (ls : list (option Name))
    : oname_list_unique ls -> oname_list_unique (firstn n ls).
  Proof. apply mname_list_unique_firstn. Qed.
  Lemma oname_list_unique_skipn n (ls : list (option Name))
    : oname_list_unique ls -> oname_list_unique (skipn n ls).
  Proof. apply mname_list_unique_skipn. Qed.
  Lemma oname_list_unique_specialize (ls : list (option Name))
    : oname_list_unique ls
      -> forall k n,
        List.In (Some n) (firstn k ls)
        -> List.In (Some n) (skipn k ls)
        -> False.
  Proof.
    intros H k n; specialize (H k n).
    rewrite map_id in H; assumption.
  Qed.
  Definition oname_list_unique_nil : oname_list_unique (@nil (option Name))
    := mname_list_unique_nil _ (fun x => x).

  Lemma split_names_firstn_skipn
        (t : flat_type base_type_code) (ls : list Name)
    : split_names t ls
      = (fst (split_names t (firstn (count_pairs t) ls)),
         skipn (count_pairs t) ls).
  Proof. apply split_mnames_firstn_skipn. Qed.
  Lemma snd_split_names_skipn
        (t : flat_type base_type_code) (ls : list Name)
    : snd (split_names t ls) = skipn (count_pairs t) ls.
  Proof. apply snd_split_mnames_skipn. Qed.
  Lemma fst_split_names_firstn
        (t : flat_type base_type_code) (ls : list Name)
    : fst (split_names t ls) = fst (split_names t (firstn (count_pairs t) ls)).
  Proof. apply fst_split_mnames_firstn. Qed.

  Lemma name_list_unique_firstn n (ls : list Name)
    : name_list_unique ls -> name_list_unique (firstn n ls).
  Proof.
    unfold name_list_unique; intro H; apply oname_list_unique_firstn with (n:=n) in H.
    rewrite <- firstn_map; assumption.
  Qed.
  Lemma name_list_unique_skipn n (ls : list Name)
    : name_list_unique ls -> name_list_unique (skipn n ls).
  Proof.
    unfold name_list_unique; intro H; apply oname_list_unique_skipn with (n:=n) in H.
    rewrite <- skipn_map; assumption.
  Qed.
  Lemma name_list_unique_specialize (ls : list Name)
    : name_list_unique ls
      -> forall k n,
        List.In n (firstn k ls)
        -> List.In n (skipn k ls)
        -> False.
  Proof.
    intros H k n; specialize (H k n).
    rewrite !map_id, !firstn_map, !skipn_map in H.
    eauto using in_map.
  Qed.
  Definition name_list_unique_nil : name_list_unique nil
    := mname_list_unique_nil _ (@Some Name).

  Lemma length_fst_split_names_Some_iff
        (t : flat_type base_type_code) (ls : list Name)
    : fst (split_names t ls) <> None <-> List.length ls >= count_pairs t.
  Proof.
    revert ls; induction t; intros;
      try solve [ destruct ls; simpl; intuition (omega || congruence) ].
    repeat first [ progress simpl in *
                 | progress break_innermost_match_step
                 | progress specialize_by congruence
                 | progress specialize_by omega
                 | rewrite snd_split_names_skipn in *
                 | progress intros
                 | congruence
                 | omega
                 | match goal with
                   | [ H : forall ls, fst (split_names ?t ls) <> None <-> _, H' : fst (split_names ?t ?ls') = _ |- _ ]
                     => specialize (H ls'); rewrite H' in H
                   | [ H : _ |- _ ] => rewrite skipn_length in H
                   end
                 | progress split_iff
                 | match goal with
                   | [ |- iff _ _ ] => split
                   end ].
  Qed.

  Lemma length_fst_split_names_None_iff
        (t : flat_type base_type_code) (ls : list Name)
    : fst (split_names t ls) = None <-> List.length ls < count_pairs t.
  Proof.
    destruct (length_fst_split_names_Some_iff t ls).
    destruct (le_lt_dec (count_pairs t) (List.length ls)); specialize_by omega;
      destruct (fst (split_names t ls)); split; try intuition (congruence || omega).
  Qed.

  Lemma split_onames_split_names (t : flat_type base_type_code) (ls : list Name)
    : split_onames t (List.map Some ls)
      = (fst (split_names t ls), List.map Some (snd (split_names t ls))).
  Proof.
    revert ls; induction t;
      try solve [ destruct ls; reflexivity ].
    repeat first [ progress simpl in *
                 | progress intros
                 | rewrite snd_split_names_skipn
                 | rewrite snd_split_onames_skipn
                 | rewrite skipn_map
                 | match goal with
                   | [ H : forall ls, split_onames ?t (map Some ls) = _ |- context[split_onames ?t (map Some ?ls')] ]
                     => specialize (H ls')
                   end
                 | break_innermost_match_step
                 | progress inversion_prod
                 | congruence ].
  Qed.
End language.


(** * Dependency state *)

(**
  This module defines a resource dependency state, which is easily mapped
  to a GRG. We define a function to generate a WFG from some
  [dependencies]. *)

Require Import Brenner.Vars.
Require Import Brenner.ResourceDependency.
Require Import Aniceto.Project.

Set Implicit Arguments.

(** The type of map I ranges from resources to sets of tasks. *)
Definition t_impeded_by := Map_EVT.t set_tid.

(** The type of map W ranges tasks to sets of resources. *)
Definition t_wait_on := Map_TID.t set_event.

(** A dependency state *)
Definition dependencies := (t_impeded_by * t_wait_on) % type.
Definition get_wait_on (d:dependencies) : t_wait_on := snd d.
Definition get_impeded_by (d:dependencies) : t_impeded_by := fst d.

(** A w-edge is an edge in the dependency state such that `e in W(t)`. *)
Definition WDep (w:t_wait_on) (t:tid) (e:event) :=
  exists es, Map_TID.MapsTo t es w /\ Set_EVT.In e es.

Definition WEdge d := (WDep (get_wait_on d)).

(* An i-edge is an edge in the dependency state such that `t in I(t)`. *)
Definition IDep (i:t_impeded_by) (e:event) (t:tid) :=
  exists ts, Map_EVT.MapsTo e ts i /\ Set_TID.In t ts.

Definition IEdge d := (IDep (get_impeded_by d)).

(**

  In this section we define the construction of a WFG from a totally deadlocked
  state. More precisely, by definition of [TotallyDeadlocked], every [t] waits
  for some event [e] that impeded_by some [t'], hence there is an outgoing
  WFG-edge from [t] to [t']. Theorem [all_pos_odegree_impl_cycle] states
  that a finite graph in which all vertices have outgoing edges includes a cycle.
  To prove this result we need to provide a WFG defined as a list of pairs
  of [tid]s that represent the WFG-edges.

  The goal of this section is to define an algorithm that constructs a
  WFG from a given [state]. The translation from [state]s into WFG proceeds in
  two steps: first, by converting [state]s into [dependencies];
  and then by converting [depedencies] into the WFG. The conversion from
  a [state] into [dependencies] is handled by Theorem [deps_of_total], so in
  this section we only define the second step of translation.
  *)

(** The [Project] module converts maps of sets into list of pairs. Let [I_Proj]
    for maps of type [impeded_by]. *)

Module I_Proj := Project.Project Map_EVT Set_TID.
(** Function [impeded_by_edges] converts a map of [impeded_by] relation into
    a list of pairs. *)
Definition impeded_by_edges : t_impeded_by -> list (event * tid) := I_Proj.project.

(** Lemma [impeded_by_edges_spec] establishes the correctness of
    Function [impeded_by_edges]: each pair in the outcome of the
    function is in relation [IEdge].

    To prove this result we use Lemma [Project.edges_spec]. *)
Lemma impeded_by_edges_spec:
  forall e t d,
  List.In (e,t) (impeded_by_edges (get_impeded_by d)) <-> IEdge d e t.
Proof.
  intros.
  unfold IDep.
  unfold impeded_by_edges.
  apply I_Proj.project_spec.
  - intros. destruct H, k1, k2.
    auto.
  - auto.
Qed.

(** Similarly, we project the map I into pairs of tasks and resources. *)
Module W_Proj := Project.Project Map_TID Set_EVT.
Definition wait_on_edges : t_wait_on -> list (tid * event) := W_Proj.project.
(** By using lemma [Project.edges_spec], we get that any pair
    in [wait_on_edges] is a [WEdge] (aka impeded_by relation). *)
Lemma wait_on_edges_spec:
  forall t e d,
  List.In (t,e) (wait_on_edges (get_wait_on d)) <-> WEdge d t e.
Proof.
  intros.
  unfold wait_on_edges.
  unfold WDep.
  apply W_Proj.project_spec.
  - auto.
  - intros. destruct H, e1, e2.
    auto.
Qed.

Require Import Coq.Lists.List.

Definition WFGEdge d t t' := exists e, WEdge d t e /\ IEdge d e t'.

(** Given the impeded_by of a dependency state [d], filter the edges
    matching [e]. *)
Definition impeded_by_matching d e :=
  filter
  (fun edge:(event*tid)=>
    let (e', t) := edge in
    if EVT.eq_dec e' e then true else false)
  (impeded_by_edges (get_impeded_by d)).
(** Given a task [t] waiting for event [e], compute WEdges starting
    from [t]. The definition uses function [impeded_by_matching]. *)
Definition build_edges (d:dependencies) (edge:(tid*event)) : list (tid*tid) :=
  let (t, e) := edge in
  map (fun edge':(event*tid)=> (t, snd edge')) (impeded_by_matching d e).
(** For each blocked tasks in the dependency state compute the WEdges
    using function [build_edges].*)
Definition build_wfg (d:dependencies) : list (tid*tid) :=
  flat_map (build_edges d) (wait_on_edges (get_wait_on d)).
(** The first main result is to show that any pair in
     [build_wfg] is a [WEdge]. The proof uses lemmas
     [wait_on_edges_spec] and [impeded_by_edges_spec]. *)
Theorem build_wfg_spec:
  forall d t t',
  List.In (t,t') (build_wfg d) <-> WFGEdge d t t'.
Proof.
  intros.
  unfold build_wfg.
  rewrite in_flat_map.
  unfold build_edges in *.
  split.
  - intros.
    (* We have that there exists a (t1, r) in [wait_edges]. *)
    destruct H as ((t1, r), (Hinw, Hinb)).
    rewrite wait_on_edges_spec in Hinw.
    (* Thus, we have that (t1, r) is a [WEdge]. *)
    exists r.
    rewrite in_map_iff in *.
    destruct Hinb as ((r', t''), (Heq, Hini)).
    simpl in *.
    inversion Heq; subst; clear Heq.
    (* We also know that (r', t') is in [impeded_by_matching d r]. *)
    unfold impeded_by_matching in *.
    rewrite filter_In in *.
    destruct Hini as (Hini, Hcnd).
    remember (Map_EVT_Extra.P.F.eq_dec r' r) as b.
    destruct b.
    assert (r' = r).
    destruct a, r', r.
    auto.
    subst.
    clear a Heqb.
    rewrite impeded_by_edges_spec in *.
    intuition.
    inversion Hcnd.
  - intros.
    destruct H as (r, (Hwf, Him)).
    exists (t, r).
    rewrite wait_on_edges_spec.
    intuition.
    rewrite in_map_iff.
    exists (r, t').
    simpl.
    intuition.
    unfold impeded_by_matching.
    rewrite filter_In.
    split.
    * rewrite impeded_by_edges_spec.
      assumption.
    * destruct (Map_EVT_Extra.P.F.eq_dec r r).
      auto.
      contradiction n.
      auto.
Qed.

(** Let [WFG_of] be the definition of a finite WFG defined
    as a sequence of edges. *)
Definition WFG_of d wfg :=
  forall t t', List.In (t, t') wfg <-> WFGEdge d t t'.
(** Given [build_wfg_spec] it is easy to show that we can
    always obtain a finite WFG from a dependency state [d].*)
Corollary wfg_of_total:
  forall d:dependencies, exists wfg, WFG_of d wfg.
Proof.
  intros.
  unfold WFG_of.
  exists (build_wfg d).
  intros.
  rewrite build_wfg_spec.
  auto with *.
Qed.


(** Typing and conversion in SIRTT

  Conversion is not defined from reduction because reduction only deals with
  relevant terms. We should be able to show however that u ↦ v implies
  that u and v are convertible as relevant terms.
  In fact, because of shape-irrelevant reflection, we need to define conversion
  mutually with typing.
  As such, this file should go away.

  I'm also missing exfalso in the AST, and thus axioms in the target to have
  axiom False.
  More crucially, I'm missing equality it seems.
  I could also be abstract about it, but maybe it's not such a good idea?

  Typing is defined without assumptions on contexts.

  Conversion is not typed, but it could have been.

*)

From Coq Require Import Utf8 List Lia.
Require Import Equations.Prop.DepElim.
Require Import Equations.Prop.Classes.
From Equations Require Import Equations.
Require Import Util Level SAst SSubst SReduction SScoping.

Import ListNotations.

Set Default Goal Selector "!".

Definition arrow A B := Prod R A (lift0 1 B).
Notation "A ⇒ B" := (arrow A B) (at level 70, right associativity) : s_scope.

(** When Γ ⊢[ ℓ ] t : A then A doesn't live in Γ, but really
    in Γ where all bindings have been Level.pred-ed, meaning all irrelevant
    bindings become shape-irrelevant.
    This means that types in typing judgments need to live in the
    transformed context.
    We call this operation [pctx] pending a better name.
*)
Definition pctx (Γ : context) : context :=
  map (λ '(ℓ, A), (▪ ℓ, A)) Γ.

Reserved Notation "Γ ⊢[ l ] t : A"
  (at level 80, l, t, A at next level, format "Γ  ⊢[  l  ]  t  :  A").

Reserved Notation "Γ ⊢[ l ] u ≡ v"
  (at level 80, l, u, v at next level, format "Γ  ⊢[  l  ]  u  ≡  v").

Inductive typing (Γ : context) : level → term → term → Type :=
| type_var :
    ∀ n ℓ ℓ' A,
      nth_error Γ n = Some (ℓ, A) →
      ℓ ⊑ ℓ' →
      Γ ⊢[ ℓ' ] var n : (lift0 (Datatypes.S n) A)

| type_lam :
    ∀ ℓ ℓ' A B t s,
      pctx Γ ⊢[ ▪ (ℓ ⊔ ℓ') ] A : univ s →
      (ℓ', A) :: Γ ⊢[ ℓ ] t : B →
      Γ ⊢[ ℓ ] lam ℓ' A t : Prod ℓ' A B

| type_app :
    ∀ ℓ ℓ' A B u v j,
      Γ ⊢[ ℓ ] u : Prod ℓ' A B →
      Γ ⊢[ ℓ ⊔ ℓ' ] v : A →
      (* The following would usually follow from validity and inversion
         but this way, it's simpler to make the proof.
      *)
      (▪ ℓ', A) :: pctx Γ ⊢[ ▪ ℓ ] B : univ j →
      Γ ⊢[ ℓ ] app ℓ' u v : B{ 0 := ptm v }

| type_Prod :
    ∀ ℓ ℓ' A B i j,
      Γ ⊢[ ℓ ⊔ ▪ ℓ' ] A : univ i →
      (▪ ℓ', A) :: Γ ⊢[ ℓ ] B : univ j →
      (* NOTE: Prod ℓ A B lives in the universe of B when the binder
        is (shape-)irrelevant.
      *)
      Γ ⊢[ ℓ ] Prod ℓ' A B : univ (if relevant ℓ' then Peano.max i j else j)

| type_ex :
    ∀ j ℓ A P u p,
      ((R, A) :: pctx Γ) ⊢[ S ⊔ ▪ ℓ ] P : univ j →
      Γ ⊢[ ℓ ] u : A →
      Γ ⊢[ I ] p : P{ 0 := ptm u } →
      Γ ⊢[ ℓ ] ex u p : Sum A P

| type_wit :
    ∀ ℓ A P p,
      Γ ⊢[ ℓ ] p : Sum A P →
      Γ ⊢[ ℓ ] wit p : A

| type_prf :
    ∀ ℓ A P p,
      Γ ⊢[ I ] p : Sum A P →
      S ⊑ ℓ →
      Γ ⊢[ ℓ ] prf p : P{ 0 := ptm (wit p) }

| type_Sum :
    ∀ ℓ A P i j,
      Γ ⊢[ ℓ ] A : univ i →
      (R, A) :: Γ ⊢[ S ⊔ ℓ ] P : univ j →
      (* NOTE: Sum A P lives in the universe of A, regardless of P *)
      Γ ⊢[ ℓ ] Sum A P : univ i

| type_zero :
    ∀ ℓ,
      Γ ⊢[ ℓ ] zero : Nat

| type_succ :
    ∀ ℓ n,
      Γ ⊢[ ℓ ] n : Nat →
      Γ ⊢[ ℓ ] succ n : Nat

| type_elim_nat :
    ∀ ℓ P z s n i,
      pctx Γ ⊢[ ▪ ℓ ] P : Nat ⇒ univ i →
      Γ ⊢[ ℓ ] z : app R P zero →
      Γ ⊢[ ℓ ] s :
        Prod R Nat
          (app R (lift0 1 P) (var 0) ⇒ app R (lift0 1 P) (succ (var 0))) →
      Γ ⊢[ ℓ ] n : Nat →
      Γ ⊢[ ℓ ] elim_nat P z s n : app R P (ptm n)

| type_Nat :
    ∀ ℓ i,
      Γ ⊢[ ℓ ] Nat : univ i

| type_vnil :
    ∀ ℓ A i,
      pctx Γ ⊢[ ▪ ℓ ] A : univ i →
      Γ ⊢[ ℓ ] vnil A : Vec A zero

| type_vcons :
    ∀ ℓ A a n v i,
      pctx Γ ⊢[ ▪ ℓ ] A : univ i →
      Γ ⊢[ ℓ ] a : A →
      Γ ⊢[ I ] n : Nat →
      Γ ⊢[ ℓ ] v : Vec A n →
      Γ ⊢[ ℓ ] vcons A a n v : Vec A (succ (ptm n))

| type_elim_vec :
    ∀ ℓ A P e c n v i j,
      pctx Γ ⊢[ ▪ ℓ ] A : univ i →
      pctx Γ ⊢[ ▪ ℓ ] P : Prod I Nat (Vec (lift0 1 A) (var 0) ⇒ univ j) →
      Γ ⊢[ ℓ ] e : app R (app I P zero) (vnil A) →
      Γ ⊢[ ℓ ] c :
        Prod R A
          (Prod I Nat (
            Prod R (Vec (lift0 2 A) (var 0)) (
              app R (app I (lift0 3 P) (var 1)) (var 0) ⇒
              app R
                (app I (lift0 3 P) (succ (var 1)))
                (vcons (lift0 3 A) (var 2) (var 1) (var 0))
            )
          )
        ) →
      Γ ⊢[ I ] n : Nat →
      Γ ⊢[ ℓ ] v : Vec A n →
      Γ ⊢[ ℓ ] elim_vec A P e c n v : app R (app I P n) (ptm v)

| type_Vec :
    ∀ ℓ A n i,
      Γ ⊢[ ℓ ] A : univ i →
      Γ ⊢[ S ⊔ ℓ ] n : Nat →
      Γ ⊢[ ℓ ] Vec A n : univ i

| type_refl :
    ∀ ℓ A u i,
      pctx Γ ⊢[ ▪ ℓ ] A : univ i →
      Γ ⊢[ ℓ ] u : A →
      Γ ⊢[ ℓ ] refl A u : Eq A (ptm u) (ptm u)

| type_coe :
    ∀ ℓ A P u v e t i j,
      pctx Γ ⊢[ ▪ ℓ ] A : univ i →
      pctx Γ ⊢[ ▪ ℓ ] P : A ⇒ univ j →
      Γ ⊢[ ℓ ] u : A →
      Γ ⊢[ ℓ ] v : A →
      Γ ⊢[ ℓ ] e : Eq A u v →
      Γ ⊢[ ℓ ] t : app R P u →
      Γ ⊢[ ℓ ] coe A P u v e t : app R P (ptm v)

| type_Eq :
    ∀ ℓ A u v i,
      Γ ⊢[ ℓ ] A : univ i →
      Γ ⊢[ ℓ ] u : A →
      Γ ⊢[ ℓ ] v : A →
      Γ ⊢[ ℓ ] Eq A u v : univ i

| type_exfalso :
    ∀ ℓ A p i,
      pctx Γ ⊢[ ▪ ℓ ] A : univ i →
      Γ ⊢[ I ] p : Empty →
      Γ ⊢[ ℓ ] exfalso A p : A

| type_Empty :
    ∀ ℓ i,
      Γ ⊢[ ℓ ] Empty : univ i

| type_univ :
    ∀ ℓ i j,
      i < j →
      Γ ⊢[ ℓ ] univ i : univ j

| type_conv :
    ∀ t A B ℓ i j,
      Γ ⊢[ ℓ ] t : A →
      pctx Γ ⊢[ ▪ ℓ ] A ≡ B →
      pctx Γ ⊢[ ▪ ℓ ] A : univ i → (* Would follow from validity *)
      pctx Γ ⊢[ ▪ ℓ ] B : univ j →
      Γ ⊢[ ℓ ] t : B

where "Γ ⊢[ l ] t : A" := (typing Γ l t A) : s_scope

with conversion (Γ : context) : level → term → term → Type :=

(* Computation rules *)

| conv_beta :
    ∀ ℓ ℓ' A t u,
      Γ ⊢[ ℓ ] app ℓ' (lam ℓ' A t) u ≡ t{ 0 := u }

| comp_wit :
    ∀ ℓ u p,
      Γ ⊢[ ℓ ] wit (ex u p) ≡ u

| comp_prf :
    ∀ ℓ u p,
      Γ ⊢[ ℓ ] prf (ex u p) ≡ p

| comp_elim_nat_zero :
    ∀ ℓ P z s,
      Γ ⊢[ ℓ ] elim_nat P z s zero ≡ z

| comp_elim_nat_succ :
    ∀ ℓ P z s n,
      Γ ⊢[ ℓ ]
        elim_nat P z s (succ n) ≡ apps s [ (R, n) ; (R, elim_nat P z s n) ]

| comp_elim_vec_vnil :
    ∀ ℓ A P e c n,
      Γ ⊢[ ℓ ] elim_vec A P e c n (vnil A) ≡ e

| comp_elim_vec_vcons :
    ∀ ℓ A P e c n a v,
      Γ ⊢[ ℓ ]
        elim_vec A P e c n (vcons A a n v) ≡
        apps c [ (R, a) ; (I, n) ; (R, v) ; (R, elim_vec A P e c n v) ]

| comp_coe_refl :
    ∀ ℓ A P u t,
      Γ ⊢[ ℓ ] coe A P u u (refl A u) t ≡ t

(* Congruence rules *)

| cong_lam :
    ∀ ℓ ℓ' A A' t t',
      pctx Γ ⊢[ ▪ ℓ ] A ≡ A' →
      (ℓ', A) :: Γ ⊢[ ℓ ] t ≡ t' →
      Γ ⊢[ ℓ ] lam ℓ' A t ≡ lam ℓ' A' t'

| cong_app :
    ∀ ℓ ℓ' u u' v v',
      Γ ⊢[ ℓ ] u ≡ u' →
      Γ ⊢[ ℓ ] v ≡ v' →
      Γ ⊢[ ℓ ] app ℓ' u v ≡ app ℓ' u' v'

| cong_Prod :
    ∀ ℓ ℓ' A A' B B',
      Γ ⊢[ ℓ ] A ≡ A' →
      (▪ ℓ', A) :: Γ ⊢[ ℓ ] B ≡ B' →
      Γ ⊢[ ℓ ] Prod ℓ' A B ≡ Prod ℓ' A' B'

| cong_ex :
    ∀ ℓ u u' p p',
      Γ ⊢[ ℓ ] u ≡ u' →
      Γ ⊢[ ℓ ] ex u p ≡ ex u' p'

| cong_wit :
    ∀ ℓ t t',
      Γ ⊢[ ℓ ] t ≡ t' →
      Γ ⊢[ ℓ ] wit t ≡ wit t'

| cong_Sum :
    ∀ ℓ A A' P P',
      Γ ⊢[ ℓ ] A ≡ A' →
      (R, A) :: Γ ⊢[ S ⊔ ℓ ] P ≡ P' →
      Γ ⊢[ ℓ ] Sum A P ≡ Sum A' P'

| cong_succ :
    ∀ ℓ n n',
      Γ ⊢[ ℓ ] n ≡ n' →
      Γ ⊢[ ℓ ] succ n ≡ succ n'

| cong_elim_nat :
    ∀ ℓ P P' z z' s s' n n',
      pctx Γ ⊢[ ▪ ℓ ] P ≡ P' →
      Γ ⊢[ ℓ ] z ≡ z' →
      Γ ⊢[ ℓ ] s ≡ s' →
      Γ ⊢[ ℓ ] n ≡ n' →
      Γ ⊢[ ℓ ] elim_nat P z s n ≡ elim_nat P' z' s' n'

| cong_vnil :
    ∀ ℓ A A',
      pctx Γ ⊢[ ▪ ℓ ] A ≡ A' →
      Γ ⊢[ ℓ ] vnil A ≡ vnil A'

| cong_vcons :
    ∀ ℓ A A' a a' n n' v v',
      pctx Γ ⊢[ ▪ ℓ ] A ≡ A' →
      Γ ⊢[ ℓ ] a ≡ a' →
      Γ ⊢[ ℓ ] v ≡ v' →
      Γ ⊢[ ℓ ] vcons A a n v ≡ vcons A' a' n' v'

| cong_elim_vec :
    ∀ ℓ A A' P P' e e' c c' n n' v v',
      pctx Γ ⊢[ ▪ ℓ ] A ≡ A' →
      pctx Γ ⊢[ ▪ ℓ ] P ≡ P' →
      Γ ⊢[ ℓ ] e ≡ e' →
      Γ ⊢[ ℓ ] c ≡ c' →
      Γ ⊢[ ℓ ] v ≡ v' →
      Γ ⊢[ ℓ ] elim_vec A P e c n v ≡ elim_vec A' P' e' c' n' v'

| cong_Vec :
    ∀ ℓ A A' n n',
      Γ ⊢[ ℓ ] A ≡ A' →
      Γ ⊢[ S ⊔ ℓ ] n ≡ n' →
      Γ ⊢[ ℓ ] Vec A n ≡ Vec A' n'

| cong_refl :
    ∀ ℓ A A' u u',
      pctx Γ ⊢[ ▪ ℓ ] A ≡ A' →
      Γ ⊢[ ℓ ] u ≡ u' →
      Γ ⊢[ ℓ ] refl A u ≡ refl A' u'

| cong_coe :
    ∀ ℓ A A' P P' u u' v v' e e' t t',
      pctx Γ ⊢[ ▪ ℓ ] A ≡ A' →
      pctx Γ ⊢[ ▪ ℓ ] P ≡ P' →
      Γ ⊢[ ℓ ] u ≡ u' →
      Γ ⊢[ ℓ ] v ≡ v' →
      Γ ⊢[ ℓ ] e ≡ e' →
      Γ ⊢[ ℓ ] t ≡ t' →
      Γ ⊢[ ℓ ] coe A P u v e t ≡ coe A' P' u' v' e' t'

| cong_Eq :
    ∀ ℓ A A' u u' v v',
      Γ ⊢[ ℓ ] A ≡ A' →
      Γ ⊢[ ℓ ] u ≡ u' →
      Γ ⊢[ ℓ ] v ≡ v' →
      Γ ⊢[ ℓ ] Eq A u v ≡ Eq A' u' v'

| cong_exfalso :
    ∀ ℓ A A' p p',
      pctx Γ ⊢[ ▪ ℓ ] A ≡ A' →
      Γ ⊢[ ℓ ] exfalso A p ≡ exfalso A' p'

(* Specific rules *)

| conv_I :
    ∀ u v,
      Γ ⊢[ I ] u ≡ v

| conv_S :
    ∀ A u v e,
      Γ ⊢[ I ] e : Eq A u v →
      Γ ⊢[ S ] u ≡ v

(* Strucutral rules *)

| conv_refl :
    ∀ ℓ u,
      Γ ⊢[ ℓ ] u ≡ u

| conv_sym :
    ∀ ℓ u v,
      Γ ⊢[ ℓ ] v ≡ u →
      Γ ⊢[ ℓ ] u ≡ v

(**
  For transitivity I couldn't find another solution than requirement
  well-scopedness of v.
  Indeed, otherwise we cannot recovert this fact from scopedness of u and w
  alone, resulting in a difficulty to erase conversion.
  This might be moral as we want to avoid transitivity to be used to consume
  irrelevant beta-redexes or so.

  (Maybe another solution would be to only conclude conversion at level ℓ of
  terms at level ℓ? We're kinda forcing it here.)
*)
| conv_trans :
    ∀ ℓ u v w,
      scoping Γ ℓ v →
      Γ ⊢[ ℓ ] u ≡ v →
      Γ ⊢[ ℓ ] v ≡ w →
      Γ ⊢[ ℓ ] u ≡ w

(* TOOD Should it be admissible instead? *)
| conv_sub :
    ∀ ℓ ℓ' u v,
      Γ ⊢[ ℓ ] u ≡ v →
      ℓ ⊑ ℓ' →
      Γ ⊢[ ℓ' ] u ≡ v

where "Γ ⊢[ l ] u ≡ v" := (conversion Γ l u v) : s_scope.

Scheme typing_rect' := Minimality for typing Sort Type
with conversion_rect' := Minimality for conversion Sort Type.
Combined Scheme typing_mutrect from typing_rect', conversion_rect'.

Lemma type_sub :
  ∀ Γ ℓ ℓ' t A,
    Γ ⊢[ ℓ ] t : A →
    ℓ ⊑ ℓ' →
    Γ ⊢[ ℓ' ] t : A.
Proof.
  intros Γ ℓ ℓ' t A ht hs.
  induction ht in ℓ', hs |- *.
  all: try solve [ constructor ; intuition eauto ].
  all: try solve [ econstructor ; intuition eauto ].
  - econstructor. 1: eauto.
    etransitivity. all: eauto.
  - econstructor. 2: eauto.
    eapply IHht1. apply pred_pred_le. apply max_le_cong_l. auto.
  - econstructor. 1: eauto.
    + eapply IHht2. apply max_le_cong_l. auto.
    + eapply IHht3. apply pred_pred_le. auto.
  - econstructor. 2: eauto.
    eapply IHht1. apply max_le_cong_l. auto.
  - econstructor. 2-3: eauto.
    eapply IHht1. apply max_le_cong_r. apply pred_pred_le. auto.
  - econstructor. 1: eauto.
    etransitivity. all: eauto.
  - econstructor. 1: auto.
    eapply IHht2. apply max_le_cong_r. auto.
  - econstructor. 2-4: eauto.
    eapply IHht1. apply pred_pred_le. auto.
  - econstructor. eapply IHht. apply pred_pred_le. auto.
  - econstructor. 2-4: eauto.
    eapply IHht1. apply pred_pred_le. auto.
  - econstructor. 3-6: eauto.
    + eapply IHht1. apply pred_pred_le. auto.
    + eapply IHht2. apply pred_pred_le. auto.
  - econstructor. 1: auto.
    eapply IHht2. apply max_le_cong_r. auto.
  - econstructor. 2: eauto.
    eapply IHht1. apply pred_pred_le. auto.
  - econstructor. 3-6: eauto.
    + eapply IHht1. apply pred_pred_le. auto.
    + eapply IHht2. apply pred_pred_le. auto.
  - econstructor. 2: eauto.
    eapply IHht1. apply pred_pred_le. auto.
  - econstructor. 1: eauto.
    + eapply conv_sub. 1: eauto.
      apply pred_pred_le. auto.
    + eapply IHht2. apply pred_pred_le. auto.
    + eapply IHht3. apply pred_pred_le. auto.
Qed.

Inductive wf_context ℓ : context → Type :=
| wf_nil : wf_context ℓ []
| wf_cons :
    ∀ Γ A ℓ' s,
      wf_context ℓ Γ →
      pctx Γ ⊢[ ℓ ⊔ ▪ ℓ' ] A : univ s →
      wf_context ℓ ((ℓ', A) :: Γ).

Lemma psc_context_to_scope :
  ∀ Γ, psc (context_to_scope Γ) = pctx Γ.
Proof.
  intros Γ. induction Γ as [| [ℓ A] Γ ih].
  - reflexivity.
  - cbn. f_equal. auto.
Qed.

Lemma typed_scoped :
  ∀ Γ ℓ t A,
    Γ ⊢[ ℓ ] t : A →
    scoping Γ ℓ t.
Proof.
  intros Γ ℓ t A h.
  induction h.
  all: try assumption.
  all: try solve [ constructor ; eauto ].
  all: try solve [ constructor ; rewrite ?psc_context_to_scope ; eauto ].
  econstructor. 2: eauto.
  unfold context_to_scope. rewrite nth_error_map.
  rewrite e. cbn. reflexivity.
Qed.

Lemma wf_context_scoped :
  ∀ ℓ Γ,
    wf_context ℓ Γ →
    scoping_context ℓ Γ.
Proof.
  intros ℓ Γ h.
  induction h.
  - constructor.
  - constructor. 1: auto.
    rewrite psc_context_to_scope. eapply typed_scoped. eauto.
Qed.

Lemma typed_type_scoped :
  ∀ Γ ℓ t A,
    scoping_context (▪ ℓ) Γ →
    Γ ⊢[ ℓ ] t : A →
    scoping (psc Γ) (▪ ℓ) A.
Proof.
  intros Γ ℓ t A hΓ h.
  induction h.
  all: try solve [ constructor ; eauto ].
  - eapply scoping_context_nth_error in e as h. 2: eauto.
    eapply lift_scoping with (Ξ := []) in h.
    cbn - [skipn] in h.
    rewrite firstn_skipn in h.
    rewrite firstn_length_le in h.
    2:{
      eapply nth_error_Some_length in e as ?.
      rewrite psc_length. rewrite context_to_scope_length. lia.
    }
    rewrite max_pred in h.
    rewrite max_l_le in h. 2: auto.
    auto.
  - constructor.
    + rewrite psc_context_to_scope. rewrite max_pred.
      eapply typed_scoped. eauto.
    + eapply IHh2. constructor. 1: auto.
      rewrite psc_context_to_scope. eapply scope_sub.
      * eapply typed_scoped. eauto.
      * rewrite max_pred. reflexivity.
  - forward IHh1 by auto. scope_inv IHh1 hs. destruct hs as [_ hsB].
    eapply subst_scoping with (Ξ := []) (Δ := [ _ ]) in hsB.
    + cbn in hsB. eauto.
    + constructor. 2: constructor.
      rewrite max_pred. eapply scoping_ptm.
      eapply typed_scoped. eauto.
  - constructor. 1: eauto.
    eapply typed_scoped in h1.
    rewrite psc_context_to_scope.
    auto.
  - forward IHh by auto. scope_inv IHh hs. intuition eauto.
  - assert (e : ▪ ℓ = S).
    { destruct ℓ. 2-3: reflexivity.
      inversion p0. inversion H.
    }
    rewrite e. rewrite e in hΓ.
    forward IHh by assumption.
    simpl in IHh. scope_inv IHh hs. destruct hs as [_ hs]. simpl in hs.
    eapply subst_scoping with (Ξ := []) (Δ := [ _ ]) in hs.
    + cbn in hs. eauto.
    + constructor. 2: constructor.
      simpl. constructor.
      eapply typed_scoped in h. eapply scoping_ptm in h.
      eauto.
  - constructor.
    + rewrite psc_context_to_scope. eapply typed_scoped. eauto.
    + change R with (▪ R). rewrite max_pred. eapply scoping_ptm.
      eapply scope_sub.
      * eapply typed_scoped. eauto.
      * rewrite max_l_R. reflexivity.
  - constructor.
    + rewrite psc_context_to_scope. eapply typed_scoped. eauto.
    + constructor.
  - constructor.
    + rewrite psc_context_to_scope. eapply typed_scoped. eauto.
    + constructor.
      change S with (▪ I). rewrite max_pred.
      apply scoping_ptm. eapply typed_scoped. eauto.
  - constructor. 1: constructor.
    + rewrite psc_context_to_scope. eapply typed_scoped. eauto.
    + rewrite max_l_I. eapply scoping_psc. eapply typed_scoped. eauto.
    + rewrite max_l_R. apply scoping_ptm. eapply typed_scoped. eauto.
  - constructor.
    + eauto.
    + apply scoping_ptm. eapply typed_scoped. eauto.
    + apply scoping_ptm. eapply typed_scoped. eauto.
  - constructor.
    + rewrite psc_context_to_scope. eapply typed_scoped. eauto.
    + rewrite max_l_R. apply scoping_ptm. eapply typed_scoped. eauto.
  - rewrite psc_context_to_scope. eapply typed_scoped. eauto.
  - rewrite psc_context_to_scope. eapply typed_scoped. eauto.
Qed.

Lemma meta_conv :
  ∀ Γ ℓ t A B,
    Γ ⊢[ ℓ ] t : A →
    A = B →
    Γ ⊢[ ℓ ] t : B.
Proof.
  intros Γ ℓ t A B h e. subst. auto.
Qed.

Lemma context_to_scope_pctx :
  ∀ Γ,
    context_to_scope (pctx Γ) = psc Γ.
Proof.
  intro Γ. unfold pctx, psc.
  unfold context_to_scope.
  rewrite !map_map. eapply map_ext.
  intros [ℓ t]. reflexivity.
Qed.

Lemma scoping_context_pctx :
  ∀ ℓ Γ,
    scoping_context ℓ Γ →
    scoping_context ℓ (pctx Γ).
Proof.
  intros ℓ Γ h.
  induction h.
  - cbn. constructor.
  - cbn. fold (pctx Γ). constructor. 1: auto.
    rewrite context_to_scope_pctx. rewrite psc_idemp.
    rewrite pred_idemp. auto.
Qed.

Derive Signature for typing.

Lemma inversion_type_var :
  ∀ Γ n ℓ T,
    scoping_context (▪ ℓ) Γ →
    Γ ⊢[ ℓ ] var n : T →
    ∑ ℓ' A,
      nth_error Γ n = Some (ℓ', A) ×
      ℓ' ⊑ ℓ ×
      pctx Γ ⊢[ ▪ ℓ ] lift0 (Datatypes.S n) A ≡ T.
Proof.
  intros Γ n ℓ T hΓ h.
  dependent induction h.
  - eexists _, _. intuition eauto.
    apply conv_refl.
  - forward IHh1 by assumption.
    destruct IHh1 as [ℓ' [A' [e [? ?]]]].
    eexists _,_. intuition eauto.
    eapply conv_trans. all: eauto.
    rewrite <- psc_context_to_scope.
    eapply typed_type_scoped. all: eauto.
Qed.

Lemma pctx_app :
  ∀ Γ Δ,
    pctx (Γ ++ Δ) = pctx Γ ++ pctx Δ.
Proof.
  intros Γ Δ. apply map_app.
Qed.

Lemma pctx_length :
  ∀ Γ,
    #| pctx Γ | = #|Γ|.
Proof.
  apply map_length.
Qed.

Lemma pctx_lift_context :
  ∀ n k Γ,
    pctx (lift_context n k Γ) = lift_context n k (pctx Γ).
Proof.
  intros n k Γ.
  induction Γ as [| [ℓ A] Γ ih] in n, k |- *.
  - reflexivity.
  - simpl. rewrite ih. rewrite pctx_length. reflexivity.
Qed.

#[local] Ltac lift_typing_ih :=
  lazymatch goal with
  | ih : ∀ Γ Δ Ξ, _ → _ ⊢[ _ ] lift _ _ ?t : _ |-
    ?Γ ⊢[ _ ] lift #| ?Δ | _ ?t : _ =>
    lazymatch Γ with
    | context [ pctx ] =>
      rewrite ?pctx_app in ih ;
      repeat change (?x :: ?l ++ ?l') with ((x :: l) ++ l') in ih ;
      specialize ih with (1 := eq_refl) ;
      specialize (ih (pctx Δ)) ;
      rewrite ?pctx_app ; rewrite ?pctx_lift_context ;
      cbn - [Level.max] in ih ;
      rewrite ?pctx_length in ih ;
      apply ih
    | _ =>
      repeat change (?x :: ?l ++ ?l') with ((x :: l) ++ l') in ih ;
      specialize ih with (1 := eq_refl) ;
      specialize (ih Δ) ;
      apply ih
    end
  | ih : ∀ Γ Δ Ξ, _ → _ ⊢[ _ ] lift _ _ ?t ≡ _ |-
    ?Γ ⊢[ _ ] lift #| ?Δ | _ ?t ≡ _ =>
    lazymatch Γ with
    | context [ pctx ] =>
      rewrite ?pctx_app in ih ;
      repeat change (?x :: ?l ++ ?l') with ((x :: l) ++ l') in ih ;
      specialize ih with (1 := eq_refl) ;
      specialize (ih (pctx Δ)) ;
      rewrite ?pctx_app ; rewrite ?pctx_lift_context ;
      cbn - [Level.max] in ih ;
      rewrite ?pctx_length in ih ;
      apply ih
    | _ =>
      repeat change (?x :: ?l ++ ?l') with ((x :: l) ++ l') in ih ;
      specialize ih with (1 := eq_refl) ;
      specialize (ih Δ) ;
      apply ih
    end
  end.

Lemma lift_typing_conversion :
  ∀ Θ,
    (∀ ℓ t A,
      Θ ⊢[ ℓ ] t : A →
      ∀ Γ Δ Ξ,
        Θ = Ξ ++ Γ →
        (lift_context #|Δ| 0 Ξ ++ Δ ++ Γ) ⊢[ ℓ ]
        (lift #|Δ| #|Ξ| t) : (lift #|Δ| #|Ξ| A)
    ) *
    (∀ ℓ u v,
      Θ ⊢[ ℓ ] u ≡ v →
      ∀ Γ Δ Ξ,
        Θ = Ξ ++ Γ →
        (lift_context #|Δ| 0 Ξ ++ Δ ++ Γ) ⊢[ ℓ ]
        (lift #|Δ| #|Ξ| u) ≡ (lift #|Δ| #|Ξ| v)
    ).
Proof.
  pose (P := λ Θ ℓ t A,
  ∀ Γ Δ Ξ,
    Θ = Ξ ++ Γ →
    (lift_context #|Δ| 0 Ξ ++ Δ ++ Γ) ⊢[ ℓ ]
    (lift #|Δ| #|Ξ| t) : (lift #|Δ| #|Ξ| A)
  ).
  pose (P0 := λ Θ ℓ u v,
    ∀ Γ Δ Ξ,
      Θ = Ξ ++ Γ →
      (lift_context #|Δ| 0 Ξ ++ Δ ++ Γ) ⊢[ ℓ ]
      (lift #|Δ| #|Ξ| u) ≡ (lift #|Δ| #|Ξ| v)
  ).
  intro Θ.
  eapply typing_mutrect with (P := P) (P0 := P0).
  all: subst P P0.
  all: simpl.
  all: try solve [ subst ; econstructor ; eauto ].
  all: try solve [
    intros ; subst ; simpl ; econstructor ; eauto ; lift_typing_ih
  ].
  all: clear Θ.
  - intros Θ n ℓ ℓ' A e ? Γ Δ Ξ ?. subst.
    destruct (PeanoNat.Nat.leb_spec0 #|Ξ| n) as [h1|h1].
    + rewrite nth_error_app2 in e. 2: lia.
      rewrite simpl_lift. 2,3: lia.
      eapply meta_conv.
      * econstructor. 2: eauto.
        rewrite nth_error_app2.
        2:{ rewrite lift_context_length. lia. }
        rewrite lift_context_length.
        rewrite nth_error_app2. 2: lia.
        rewrite <- e. f_equal. lia.
      * f_equal. lia.
    + rewrite nth_error_app1 in e. 2: lia.
      assert (h :
        ∀ t,
          lift0 (Datatypes.S n) (lift #|Δ| (#|Ξ| - Datatypes.S n) t) =
          lift #|Δ| #|Ξ| (lift0 (Datatypes.S n) t)
      ).
      { intro t.
        replace #|Ξ| with (Datatypes.S n + (#|Ξ| - Datatypes.S n)) at 2 by lia.
        rewrite permute_lift. 2: lia.
        f_equal. lia.
      }
      rewrite <- h. clear h.
      econstructor. 2: eauto.
      rewrite nth_error_app1.
      2:{ rewrite lift_context_length. lia. }
      rewrite nth_error_lift_context. rewrite e. simpl. reflexivity.
  - intros. subst. rewrite distr_lift_subst10. rewrite <- ptm_lift. simpl.
    econstructor. all: lift_typing_ih.
  - intros. subst. simpl. econstructor. 1,2: lift_typing_ih.
    rewrite ptm_lift. rewrite <- distr_lift_subst10.
    lift_typing_ih.
  - intros. subst. simpl. rewrite distr_lift_subst10. simpl.
    rewrite <- ptm_lift. econstructor. 2: auto.
    lift_typing_ih.
  - intros. subst. simpl. rewrite <- ptm_lift. econstructor.
    1,2,4: lift_typing_ih.
    rewrite permute_lift. 2: lia.
    unfold "⇒". simpl.
    rewrite (permute_lift (lift0 _ _)). 2: lia.
    replace (#|Ξ| + 1 + 1) with (Datatypes.S (Datatypes.S #|Ξ|)) by lia.
    replace (#|Ξ| + 1) with (Datatypes.S #|Ξ|) by lia.
    lift_typing_ih.
  - intros. subst. simpl. rewrite <- ptm_lift. econstructor.
    all: lift_typing_ih.
  - intros. subst. simpl. rewrite <- ptm_lift. econstructor.
    1,3,5,6: lift_typing_ih.
    + rewrite permute_lift. 2: lia.
      replace (#|Ξ| + 1) with (Datatypes.S #|Ξ|) by lia.
      lift_typing_ih.
    + rewrite permute_lift. 2: lia.
      unfold "⇒". simpl.
      repeat rewrite (permute_lift _ #|Δ|). 2-5: lia.
      replace (#|Ξ| + 3 + 1) with (4 + #|Ξ|) by lia.
      replace (#|Ξ| + 3) with (3 + #|Ξ|) by lia.
      replace (#|Ξ| + 2) with (2 + #|Ξ|) by lia.
      simpl.
      lift_typing_ih.
  - intros. subst. simpl. rewrite <- ptm_lift. econstructor.
    all: lift_typing_ih.
  - intros. subst. simpl. rewrite <- ptm_lift. econstructor.
    all: lift_typing_ih.
  - intros. subst. rewrite distr_lift_subst10. econstructor.
  - intros ? ? ? ? ? hs ? ? ? ? ? Δ ? ?.
    subst. eapply conv_trans. 2,3: lift_typing_ih.
    rewrite !context_to_scope_app.
    rewrite context_to_scope_lift_context.
    rewrite context_to_scope_app in hs.
    eapply lift_scoping with (Δ := context_to_scope Δ) in hs.
    rewrite !context_to_scope_length in hs.
    exact hs.
Qed.

Lemma lift_typing :
  ∀ Γ Δ Ξ t A ℓ,
    (Ξ ++ Γ) ⊢[ ℓ ] t : A →
    (lift_context #|Δ| 0 Ξ ++ Δ ++ Γ) ⊢[ ℓ ]
    (lift #|Δ| #|Ξ| t) : (lift #|Δ| #|Ξ| A).
Proof.
  intros Γ Δ Ξ t A ℓ h.
  eapply lift_typing_conversion. all: eauto.
Qed.

Lemma lift_conversion :
  ∀ Γ Δ Ξ u v ℓ,
    (Ξ ++ Γ) ⊢[ ℓ ] u ≡ v →
    (lift_context #|Δ| 0 Ξ ++ Δ ++ Γ) ⊢[ ℓ ]
    (lift #|Δ| #|Ξ| u) ≡ (lift #|Δ| #|Ξ| v).
Proof.
  intros. eapply lift_typing_conversion. all: eauto.
Qed.

Inductive typing_subst ℓ Γ : context → list term → Type :=
| typing_subst_cons :
    ∀ A ℓ' Δ u σ,
      Γ ⊢[ ℓ ⊔ ℓ' ] u : subst0 σ A →
      typing_subst ℓ Γ Δ σ →
      typing_subst ℓ Γ ((ℓ', A) :: Δ) (u :: σ)

| typing_subst_nil :
    typing_subst ℓ Γ [] [].

Lemma typing_subst_nth_error :
  ∀ Γ Δ σ n ℓ ℓ' A u,
    typing_subst ℓ Γ Δ σ →
    nth_error Δ n = Some (ℓ',A) →
    nth_error σ n = Some u →
    Γ ⊢[ ℓ ⊔ ℓ' ] u : subst0 (skipn (Datatypes.S n) σ) A.
Proof.
  intros Γ Δ σ n ℓ ℓ' A u h eΔ eσ.
  induction h in n, ℓ', A, u, eΔ, eσ |- *.
  2:{ destruct n. all: discriminate. }
  destruct n.
  - cbn in eΔ, eσ. inversion eΔ. inversion eσ. subst. clear eΔ eσ.
    auto.
  - cbn in eΔ, eσ. eapply IHh. all: eauto.
Qed.

Lemma typing_subst_length :
  ∀ ℓ Γ Δ σ,
    typing_subst ℓ Γ Δ σ →
    #|Δ| = #|σ|.
Proof.
  intros ℓ Γ Δ σ h.
  induction h.
  - simpl. eauto.
  - reflexivity.
Qed.

(* #[local] Ltac subst_typing_ih :=
  lazymatch goal with
  | ih : ∀ Γ Δ Ξ, _ → _ ⊢[ _ ] lift _ _ ?t : _ |-
    ?Γ ⊢[ _ ] lift #| ?Δ | _ ?t : _ =>
    lazymatch Γ with
    | context [ pctx ] =>
      rewrite ?pctx_app in ih ;
      repeat change (?x :: ?l ++ ?l') with ((x :: l) ++ l') in ih ;
      specialize ih with (1 := eq_refl) ;
      specialize (ih (pctx Δ)) ;
      rewrite ?pctx_app ; rewrite ?pctx_lift_context ;
      cbn - [Level.max] in ih ;
      rewrite ?pctx_length in ih ;
      apply ih
    | _ =>
      repeat change (?x :: ?l ++ ?l') with ((x :: l) ++ l') in ih ;
      specialize ih with (1 := eq_refl) ;
      specialize (ih Δ) ;
      apply ih
    end
  | ih : ∀ Γ Δ Ξ, _ → _ ⊢[ _ ] lift _ _ ?t ≡ _ |-
    ?Γ ⊢[ _ ] lift #| ?Δ | _ ?t ≡ _ =>
    lazymatch Γ with
    | context [ pctx ] =>
      rewrite ?pctx_app in ih ;
      repeat change (?x :: ?l ++ ?l') with ((x :: l) ++ l') in ih ;
      specialize ih with (1 := eq_refl) ;
      specialize (ih (pctx Δ)) ;
      rewrite ?pctx_app ; rewrite ?pctx_lift_context ;
      cbn - [Level.max] in ih ;
      rewrite ?pctx_length in ih ;
      apply ih
    | _ =>
      repeat change (?x :: ?l ++ ?l') with ((x :: l) ++ l') in ih ;
      specialize ih with (1 := eq_refl) ;
      specialize (ih Δ) ;
      apply ih
    end
  end. *)

Lemma subst_typing_conversion :
  ∀ Θ,
    (∀ ℓ t A,
      Θ ⊢[ ℓ ] t : A →
      ∀ Γ Δ Ξ σ,
        Θ = Ξ ++ Δ ++ Γ →
        typing_subst ℓ Γ Δ σ →
        (subst_context σ Ξ ++ Γ) ⊢[ ℓ ]
        (subst σ #|Ξ| t) : (subst σ #|Ξ| A)
    ) *
    (∀ ℓ u v,
      Θ ⊢[ ℓ ] u ≡ v →
      ∀ Γ Δ Ξ σ,
        Θ = Ξ ++ Δ ++ Γ →
        (subst_context σ Ξ ++ Γ) ⊢[ ℓ ]
        (subst σ #|Ξ| u) ≡ (subst σ #|Ξ| v)
    ).
Proof.
  pose (P := λ Θ ℓ t A,
    ∀ Γ Δ Ξ σ,
      Θ = Ξ ++ Δ ++ Γ →
      typing_subst ℓ Γ Δ σ →
      (subst_context σ Ξ ++ Γ) ⊢[ ℓ ]
      (subst σ #|Ξ| t) : (subst σ #|Ξ| A)
  ).
  pose (P0 := λ Θ ℓ u v,
    ∀ Γ Δ Ξ σ,
      Θ = Ξ ++ Δ ++ Γ →
      (subst_context σ Ξ ++ Γ) ⊢[ ℓ ]
      (subst σ #|Ξ| u) ≡ (subst σ #|Ξ| v)
  ).
  intro Θ.
  eapply typing_mutrect with (P := P) (P0 := P0).
  all: subst P P0.
  all: simpl.
  all: try solve [ subst ; econstructor ; eauto ].
  (* all: try solve [
    intros ; subst ; simpl ; econstructor ; eauto ; subst_typing_ih
  ]. *)
  all: clear Θ.
  - intros ? n ℓ ℓ' A hn hℓ Γ Δ Ξ σ ? hσ. subst.
    destruct (PeanoNat.Nat.leb_spec0 #|Ξ| n) as [h1|h1].
    + rewrite nth_error_app2 in hn. 2: lia.
      destruct (nth_error σ) eqn:e.
      * rewrite nth_error_app1 in hn.
        2:{
          apply nth_error_Some_length in e.
          apply typing_subst_length in hσ.
          lia.
        }
        eapply typing_subst_nth_error in hσ. 2,3: eauto.
        rewrite max_l_le in hσ. 2: auto.
        eapply lift_typing with (Ξ := []) (Δ := subst_context σ Ξ) in hσ.
        cbn - [skipn] in hσ. rewrite subst_context_length in hσ.
        rewrite commut_lift_subst_rec in hσ. 2: auto.
        cbn - [skipn] in hσ.
        replace (subst σ)
        with (subst (firstn (Datatypes.S (n - #|Ξ|)) σ ++ skipn (Datatypes.S (n - #|Ξ|)) σ)).
        2:{ f_equal. apply firstn_skipn. }
        rewrite subst_app_decomp.
        eapply meta_conv. 1: eauto.
        f_equal.
        replace (Datatypes.S n) with ((Datatypes.S n - #|Ξ|) + #|Ξ|) by lia.
        assert (eq :
          #|map (lift0 #|skipn (Datatypes.S (n - #|Ξ|)) σ|) (firstn (Datatypes.S (n - #|Ξ|)) σ)| =
          Datatypes.S n - #|Ξ|
        ).
        { rewrite map_length. rewrite firstn_length by lia.
          apply nth_error_Some_length in e.
          lia.
        }
        rewrite <- eq.
        rewrite simpl_subst_rec. 2-3: lia.
        reflexivity.
      * {
        apply typing_subst_length in hσ as lσ.
        apply nth_error_None in e.
        rewrite nth_error_app2 in hn. 2: lia.
        replace (Datatypes.S n) with (#|σ| + (Datatypes.S n - #|σ|)). 2: lia.
        rewrite simpl_subst. 2: lia.
        eapply meta_conv.
        - econstructor. 2: eauto.
          rewrite nth_error_app2.
          2:{ rewrite subst_context_length. lia. }
          rewrite subst_context_length. rewrite <- hn. f_equal. lia.
        - f_equal. lia.
      }
    + rewrite nth_error_app1 in hn. 2: lia.
      eapply meta_conv.
      * econstructor. 2: eauto.
        rewrite nth_error_app1.
        2:{ rewrite subst_context_length. lia. }
        rewrite nth_error_subst_context. rewrite hn. simpl.
        reflexivity.
      * rewrite commut_lift_subst_rec. 2: lia.
        f_equal. lia.
Abort.


Require Export Adjoint UniversalProperties.
Require Import Common.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section AdjunctionUniversal.
  Context `{C : @SpecializedCategory objC}.
  Context `{D : @SpecializedCategory objD}.
  Variable F : SpecializedFunctor C D.
  Variable G : SpecializedFunctor D C.

  Definition InitialMorphismOfAdjunction (A : Adjunction F G) Y : InitialMorphism Y G.
    pose (projT1 (A : AdjunctionCounit F G)) as ε.
    pose (projT1 (A : AdjunctionUnit F G)) as η.
    apply Build_InitialMorphism'.
    rename η into i, Y into c, G into R, F into L.
    clear ε.
    exists (L c).
    exists (AComponentsOf A c (L c) (Identity (L c))).
    refine (fun d f => exist _ (proj1_sig (AIsomorphism A _ _) f) _).
    abstract (
        let H := fresh in
        pose proof (fun x0 => fg_equal (ACommutes A c (L c) c d (Identity _) x0) (Identity (L c))) as H;
        pose proof (fg_equal (RightInverse (AIsomorphism A c d)));
        pose proof (fg_equal (LeftInverse (AIsomorphism A c d)));
        simpl in *;
          repeat rewrite FIdentityOf in H;
        repeat rewrite LeftIdentity in H;
        repeat rewrite RightIdentity in H;
        split; repeat (intro || apply functional_extensionality_dep);
        subst;
        simpl in *;
          rewrite <- H;
        autorewrite with morphism;
        trivial; symmetry; trivial
      ).
  Defined.

  (* TODO(jgross): Automate this more *)
  Definition TerminalMorphismOfAdjunction (A : Adjunction F G) X : TerminalMorphism F X.
    pose (projT1 (A : AdjunctionCounit F G)) as ε.
    pose (projT1 (A : AdjunctionUnit F G)) as η.
    apply Build_TerminalMorphism'.
    rename ε into i, X into d, G into R, F into L.
    clear η.
    exists (R d).
    exists (proj1_sig (AIsomorphism A (R d) d) (Identity (R d))).
    refine (fun c g => exist _ ((AComponentsOf A _ _) g) _).
    abstract (
        pose proof (fg_equal (RightInverse (AIsomorphism A (R d) d)));
        pose proof (fg_equal (RightInverse (AIsomorphism A c d)));
        pose proof (fg_equal (LeftInverse (AIsomorphism A (R d) d)));
        pose proof (fg_equal (LeftInverse (AIsomorphism A c d)));
        let H := fresh in
        split;
        [ pose proof (let m := (A (c, d) g) in
                      fg_equal (ACommutes_Inverse A (R d) d c d m (Identity _)) (Identity _)) as H
        | intro m';
          pose proof (fg_equal (ACommutes A (R d) _ c d m' (Identity _))
                               (Inverse (NaturalIsomorphism_Isomorphism A (R d, d)) (Identity (R d)))) as H ];
        simpl in *;
          repeat rewrite FIdentityOf in H;
        repeat rewrite LeftIdentity in H;
        repeat rewrite RightIdentity in H;
        repeat (intro || apply functional_extensionality_dep);
        subst;
        simpl in *;
          etransitivity; try (apply H || (symmetry; apply H));
        try match goal with
              | [ H : _ |- _ ] => rewrite H; autorewrite with morphism; solve [ trivial ]
            end
      ).
  Defined.
End AdjunctionUniversal.

Section AdjunctionFromUniversal.
  Context `{C : @SpecializedCategory objC}.
  Context `{D : @SpecializedCategory objD}.

  Local Ltac diagonal_transitivity_pre_then tac :=
    repeat rewrite AssociativityNoEvar by noEvar;
    match goal with
      | [ |- Compose ?a (Compose ?b ?c) = Compose ?a' (Compose ?b' ?c') ] =>
        eapply (@eq_trans _ _ (Compose a (Compose _ c')) _); tac
      | [ |- Compose ?a (Compose ?b ?c) = Compose ?a' (Compose ?b' ?c') ] =>
        eapply (@eq_trans _ _ (Compose a' (Compose _ c)) _); tac
    end.

  Local Ltac post_diagonal_transitivity_tac :=
    first [ try_associativity ltac:(apply f_equal2; try reflexivity; [])
          | symmetry; (* I'm confused why I need this.  But if I don't have it, [rewrite <- AssociativityNoEvar at 2] fails *)
            try_associativity ltac:(apply f_equal2; try reflexivity; []) ].

  Local Ltac diagonal_transitivity_then tac :=
    diagonal_transitivity_pre_then ltac:(post_diagonal_transitivity_tac; tac).

  Local Ltac diagonal_transitivity_then_solve_rewrite :=
    diagonal_transitivity_then ltac:(solve [ rewrite_hyp'; reflexivity | rewrite_rev_hyp'; reflexivity ]).

  Local Ltac solve_adjoint_functor UniversalObject :=
    repeat intro;
    repeat match goal with
             | [ |- context[UniversalObject ?o] ] => generalize (UniversalObject o); intro
           end;
    clear UniversalObject;
    intro_universal_properties;
    unfold unique in *;
    split_and;
    apply_hyp';
    repeat rewrite FCompositionOf;
    repeat rewrite FIdentityOf;
    autorewrite with morphism;
    try reflexivity;
    diagonal_transitivity_then_solve_rewrite.

  Section initial.
    Variable G : SpecializedFunctor D C.
    Variable M : forall Y, InitialMorphism Y G.

    Definition AdjointFunctorOfInitialMorphism : SpecializedFunctor C D.
      refine (Build_SpecializedFunctor C D
                                       (fun Y => let ηY := InitialMorphism_Morphism (M Y) in
                                                 let F0Y := InitialMorphism_Object (M Y) in
                                                 F0Y)
                                       (fun Y0 Y1 f => let ηY1 := InitialMorphism_Morphism (M Y1) in
                                                       (InitialProperty_Morphism (M Y0) _ (Compose ηY1 f)))
                                       _
                                       _);
      simpl in *;
      abstract solve_adjoint_functor M.
    Defined.

    Definition AdjunctionOfInitialMorphism : Adjunction AdjointFunctorOfInitialMorphism G.
      refine (_ : AdjunctionUnit AdjointFunctorOfInitialMorphism G).
      exists (Build_SpecializedNaturalTransformation (IdentityFunctor C)
                                                     (ComposeFunctors G AdjointFunctorOfInitialMorphism)
                                                     (fun x => InitialMorphism_Morphism (M x))
                                                     (fun s d m => eq_sym (proj1 (InitialProperty (M s) _ _)))).
      simpl.
      exact (fun c d f => exist _ (InitialProperty_Morphism (M c) d f) (InitialProperty (M c) d f)).
    Defined.
  End initial.

  Section terminal.
    Variable F : SpecializedFunctor C D.
    Variable M : forall X, TerminalMorphism F X.

    Definition AdjointFunctorOfTerminalMorphism : SpecializedFunctor D C.
      refine (Build_SpecializedFunctor D C
                                       (fun X => let εX := TerminalMorphism_Morphism (M X) in
                                                 let G0X := TerminalMorphism_Object (M X) in
                                                 G0X)
                                       (fun X0 X1 g => let εX0 := TerminalMorphism_Morphism (M X0) in
                                                       let εX1 := TerminalMorphism_Morphism (M X1) in
                                                       (TerminalProperty_Morphism (M X1) _ (Compose g εX0)))
                                       _
                                       _);
      simpl in *;
      abstract solve_adjoint_functor M.
    Defined.

    Definition AdjunctionOfTerminalMorphism : Adjunction F AdjointFunctorOfTerminalMorphism.
      refine (_ : AdjunctionCounit F AdjointFunctorOfTerminalMorphism).
      hnf.
      exists (Build_SpecializedNaturalTransformation (ComposeFunctors F AdjointFunctorOfTerminalMorphism)
                                                     (IdentityFunctor D)
                                                     (fun x => TerminalMorphism_Morphism (M x))
                                                     (fun s d m => proj1 (TerminalProperty (M d) _ _))).
      simpl.
      exact (fun c d g => exist _ (TerminalProperty_Morphism (M d) c g) (TerminalProperty (M d) c g)).
    Defined.
  End terminal.
End AdjunctionFromUniversal.


From mathcomp Require Import
     all_ssreflect.

From AUChain Require Import
     Parameters
     Blocks.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Messages
      This file contains the basic message type used for communication.
**)

Inductive Message :=
  | BlockMsg of Block.

Definition Messages := seq Message.

Module MsgEq.
Definition eq_msg a b :=
 match a, b with
 | BlockMsg bA, BlockMsg bB => (bA == bB)
  end.

Lemma eq_msgP : Equality.axiom eq_msg.
Proof. by move=> /= [] ? [] ? /=; apply/(iffP idP)=> [/eqP ->| [] -> ] //. Qed.

Canonical Msg_eqMixin := Eval hnf in EqMixin eq_msgP.
Canonical Msg_eqType := Eval hnf in EqType Message Msg_eqMixin.

End MsgEq.

Export MsgEq.


Require Import PeanoNat.

Require Export SystemFR.ErasedTermLemmas.
Require Export SystemFR.EquivalenceLemmas.

Open Scope list_scope.

Definition reducibility_candidate (P: tree -> Prop): Prop :=
  forall v, P v ->
    is_erased_term v /\
    cbv_value v /\
    wf v 0 /\
    pfv v term_var = nil /\
    (
      forall v1 v2,
        P v1 ->
        [ v1 ≡ v2 ] ->
        cbv_value v2 ->
        P v2
    )
.

(* an interpretation is a map from type variables to reducibility candidates *)
Definition interpretation: Type := list (nat * (tree -> Prop)).

Definition pre_interpretation: Type := list (nat * (tree -> tree -> Prop)).

Fixpoint valid_interpretation (ρ: interpretation): Prop :=
  match ρ with
  | nil => True
  | (x,P) :: ρ' => valid_interpretation ρ' /\ reducibility_candidate P
  end.

Lemma valid_interpretation_cons:
  forall ρ RC X,
    valid_interpretation ρ ->
    reducibility_candidate RC ->
    valid_interpretation ((X, RC) :: ρ).
Proof.
  steps.
Qed.

Lemma in_valid_interpretation_erased: forall ρ v X P,
  valid_interpretation ρ ->
  lookup PeanoNat.Nat.eq_dec ρ X = Some P ->
  P v ->
  is_erased_term v.
Proof.
  induction ρ; repeat step || eauto || apply_any.
Qed.

Lemma in_valid_interpretation_wf: forall ρ v X P,
  valid_interpretation ρ ->
  lookup PeanoNat.Nat.eq_dec ρ X = Some P ->
  P v ->
  wf v 0.
Proof.
  induction ρ; repeat step || eauto || apply_any.
Qed.

Lemma in_valid_interpretation_value: forall ρ v X P,
  valid_interpretation ρ ->
  lookup PeanoNat.Nat.eq_dec ρ X = Some P ->
  P v ->
  cbv_value v.
Proof.
  induction ρ; repeat step || eauto || apply_any.
Qed.

Lemma in_valid_interpretation_fv: forall ρ v X P,
  valid_interpretation ρ ->
  lookup PeanoNat.Nat.eq_dec ρ X = Some P ->
  P v ->
  pfv v term_var = nil.
Proof.
  induction ρ; repeat step || eauto || apply_any.
Qed.

Lemma in_valid_interpretation_tfv: forall ρ v X P,
  valid_interpretation ρ ->
  lookup PeanoNat.Nat.eq_dec ρ X = Some P ->
  P v ->
  pfv v type_var = nil.
Proof.
  intros; eauto using is_erased_term_tfv, in_valid_interpretation_erased.
Qed.

Lemma in_valid_interpretation_pfv: forall ρ v X P tag,
  valid_interpretation ρ ->
  lookup PeanoNat.Nat.eq_dec ρ X = Some P ->
  P v ->
  pfv v tag = nil.
Proof.
  destruct tag; eauto using in_valid_interpretation_fv, in_valid_interpretation_tfv.
Qed.

Lemma in_valid_interpretation_twf: forall ρ v X P,
  valid_interpretation ρ ->
  lookup PeanoNat.Nat.eq_dec ρ X = Some P ->
  P v ->
  twf v 0.
Proof.
  eauto using is_erased_term_twf, in_valid_interpretation_erased.
Qed.

Lemma in_valid_interpretation_equiv: forall ρ v1 v2 X P,
  valid_interpretation ρ ->
  lookup PeanoNat.Nat.eq_dec ρ X = Some P ->
  P v1 ->
  [ v1 ≡ v2 ] ->
  cbv_value v2 ->
  P v2.
Proof.
  induction ρ; repeat step || unfold reducibility_candidate in * || instantiate_any;
    try solve [ eapply_any; eauto ].
Qed.

Lemma in_valid_interpretation_equiv2: forall ρ v1 v2 X P,
  valid_interpretation ρ ->
  lookup PeanoNat.Nat.eq_dec ρ X = Some P ->
  P v1 ->
  [ v2 ≡ v1 ] ->
  cbv_value v2 ->
  P v2.
Proof.
  intros.
  eapply in_valid_interpretation_equiv; eauto using equivalent_sym.
Qed.

Fixpoint valid_pre_interpretation (P: tree -> Prop) (ρ: list (nat * (tree -> tree -> Prop))) : Prop :=
  match ρ with
  | nil => True
  | (_, RC) :: ρ' => valid_pre_interpretation P ρ' /\ forall a, P a -> reducibility_candidate (RC a)
  end.

Lemma valid_interpretation_equiv:
  forall P1 P2 pre_ρ,
    valid_pre_interpretation P1 pre_ρ ->
    (forall x, P1 x <-> P2 x) ->
    valid_pre_interpretation P2 pre_ρ.
Proof.
  induction pre_ρ; steps; eauto with eapply_any.
Qed.

Ltac t_valid_interpretation_equiv :=
  match goal with
  | H1: valid_pre_interpretation ?P1 ?pre_ρ |- valid_pre_interpretation _ ?pre_ρ => apply valid_interpretation_equiv with P1
  end.

Definition push_one (a: tree) (l: list (nat * (tree -> tree -> Prop))): interpretation :=
  map_values (fun rc => rc a) l.
Definition push_all (P: tree -> Prop) (l: list (nat * (tree -> tree -> Prop))): interpretation :=
  map_values (fun (rc: tree -> tree -> Prop) (v: tree) => (forall a, P a -> rc a v)) l.

Lemma valid_interpretation_one:
  forall a (P: tree -> Prop) ρ,
    P a ->
    valid_pre_interpretation P ρ ->
    valid_interpretation (push_one a ρ).
Proof.
  induction ρ; steps.
Qed.

Lemma valid_interpretation_append:
  forall ρ1 ρ2,
    valid_interpretation ρ1 ->
    valid_interpretation ρ2 ->
    valid_interpretation (ρ1 ++ ρ2).
Proof.
  induction ρ1; steps.
Qed.

#[export]
Hint Resolve valid_interpretation_cons: b_valid_interp.
#[export]
Hint Resolve valid_interpretation_one: b_valid_interp.

#[export]
Hint Resolve valid_interpretation_append: b_valid_interp.
#[export]
Hint Extern 1 => eapply valid_interpretation_one; eauto: b_valid_interp.


Section stream.
  Variable A : Type.
  CoInductive stream : Type :=
  | Cons : A -> stream -> stream.
Set Implicit Arguments.
End stream.

CoFixpoint zeroes : stream nat := Cons nat 0 zeroes.
(*CoFixpoint trues_falses : stream bool := Cons True*)