From Undecidability Require Export BSM BSM_sss bsm_defs.

From Coq Require Import List Vector.
Import ListNotations Vector.VectorNotations.

Lemma BSM_computable_iff {k} (R : Vector.t nat k -> nat -> Prop) :
  BSM_computable R <->
  exists n : nat, exists i : nat, exists P : list (bsm_instr (1 + k + n)),
    (forall v : Vector.t nat k,forall m, R v m -> exists c v', BSM.eval (1 + k + n) (i, P) (i, (@List.nil bool :: Vector.map (fun n => List.repeat true n) v) ++ Vector.const (@List.nil bool) n) (c, List.repeat true m :: v'))
    /\ (forall v, sss.sss_terminates (@bsm_sss _) (i, P) (i, (@List.nil bool :: Vector.map (fun n => List.repeat true n) v) ++ Vector.const (@List.nil bool) n) -> exists m, R v m).
Proof.
  split.
  - intros (n & i & P & H). exists n, i, P. split.
    + intros v m ? % H; eauto.
    + intros v [(c, v') H1].
      pose proof (H2 := H1). eapply eval_iff in H2 as (m & v'' & H2) % H.
      subst. eapply eval_iff in H1. eexists. eapply H. eexists. eexists. eapply H1.
  - intros (n & i & P & H1 & H2).
    exists n, i, P. intros v. split.
    + intros m. split.
      * intros (c & v' & Hvm) % H1. fold plus in *. exists c, v'. eapply Hvm.
      * intros (c & v' & Hvm % eval_iff). fold plus in *.
        edestruct H2 as [m' H'].
        -- eexists. eassumption.
        -- enough (m' = m) as -> by assumption.
           eapply H1 in H' as (c' & v'' & H' % eval_iff).
           destruct Hvm as [Hvm1 Hvm2].
           eapply sss.sss_compute_fun in Hvm1. 5: eapply H'. 3: eapply H'. 3: eapply Hvm2.
           2: eapply bsm_sss_fun.
           inversion Hvm1. eapply (f_equal (@length bool)) in H3.
           now rewrite !repeat_length in H3.
    + intros c v' H % eval_iff. edestruct H2 as [m Hm]. { eexists. eauto. }
      eapply H1 in Hm as (c' & v'' & [Hm1 Hm2] % eval_iff). fold plus in *. exists m, v''.
      eapply sss.sss_compute_fun in Hm1. 5: eapply H. 3: eapply H. 3: eapply Hm2.
      2: eapply bsm_sss_fun.
      inversion Hm1. congruence.
Qed.


Require Import Coq.Init.Byte Coq.Strings.Byte Coq.Bool.Bvector.
Require Import Coq.Lists.List.
Require Import Coq.Init.Nat.
Import ListNotations.

From CHIP8 Require Import HelperDataTypes.

Fixpoint create_list {A : Type} (default : A) (n : nat) : list A :=
  match n with
    |0 => []
    |S n' => default :: create_list default n'
  end.

Fixpoint init_memory' (n : nat) : list byte :=
  create_list (x00) n.

Definition init_memory : list byte :=
  init_memory'  4096.

(* Reading memory is done by using the nth function *)

Fixpoint write_memory {A : Type}(data : A) (address : nat) (ram : list A) : list A :=
  match address, ram with
    |0, head :: tail => data :: tail
    |0, [] => []
    |S address', [] => []
    |S address', head :: tail => head :: write_memory data address' tail
  end.

Definition write_instruction (inst : byte * byte) (address : nat) (ram : list byte) : list byte :=
  match inst with
  | (b1, b2) =>
    write_memory b2 (S(address)) (write_memory b1 address ram)
  end.

Fixpoint write_all_instructions (insts : list (byte * byte)) (address : nat) (ram : list byte) : list byte :=
  match insts with
  | []              => ram
  | inst::insts' =>
    let new_ram := write_instruction inst address ram in
    write_all_instructions insts' (S(S(address))) new_ram
  end.

Definition write_instruction_nib (inst : (nibble * nibble * nibble * nibble)) (address : nat) (ram : list byte) : list byte :=
  match inst with
  | (n1', n2', n3', n4') =>
    let b1 := nib_to_byte (n1', n2') in
    let b2 := nib_to_byte (n3', n4') in
    write_instruction (b1, b2) address ram
  end.


Require Import List.

Definition sublist `{t : Type} (l l' : list t) : Prop :=
 forall e, In e l -> In e l'.

Definition disjoint {A : Type} (L1 L2 : list A) : Prop :=
 forall x, ~(In x L1 /\ In x L2).

Fixpoint nth_op {A : Type} (i : nat) (l : list A): option A :=
 match l with
 | nil => None
 | a::l' => match i with
            | 0 => Some a
            | S n => nth_op n l'
            end
  end.

Class varsable (A B : Type) : Type := Varsable {
  vars : A -> list B
}.
Implicit Arguments Varsable [A B].

Class EqDec (A : Type) : Type :=
 eq_dec : forall a a' : A, {a = a'} + {a <> a'}.

Definition vars_list {A} {B} `{varsable A B} : (list A) -> (list B) :=
  fold_right (fun a L' => (vars a) ++ L') nil.
Instance varsable_list {A} {B} `{varsable A B} : varsable (list A) B :=
  Varsable vars_list.

Definition var_list_extract {A B: Type} `{varsable A B} (l : list A) :
 list (list B) := map (fun e => vars e) l.

Definition disjoint_pwise {A : Type} (L : list (list A)) : Prop :=
 forall l l' i j, i <> j -> nth_op i L = Some l -> nth_op j L = Some l' -> disjoint l l'.

Fixpoint disjoint_pwise_fun {A : Type} (L : list (list A)) : Prop :=
 match L with
 | nil => True
 | l::L' => (forall l', In l' L' -> disjoint l l') /\ disjoint_pwise_fun L'
 end.

Delimit Scope part_scope with part_scope.

Open Scope part_scope.

Class evalable (A : Type) (B : Type) : Type := Evalable {
  eval : A -> B -> Prop
}.
Implicit Arguments Evalable [A B].
Notation " rho '|=' obj " := (eval rho obj) (at level 30) : part_scope.

Class overridable (A : Type) (B : Type) : Type := Overridable {
  override : A -> A -> (list B) -> A
}.
Implicit Arguments Overridable [A B].
Notation " [ E '=>' ctx2 ']' ctx1 " := (override ctx1 ctx2 E) (at level 10) : part_scope.

Definition eval_list {A} {B} `{evalable A B} : A -> list B -> Prop :=
    fun a => fold_right (fun e t => t /\ a |= e) True.
Instance evalable_list {A} {B} `{evalable A B} : evalable A (list B):=
  Evalable eval_list.

Module Type PARTITION_INPUT.

  Parameter equation : Type.
  Parameter eqn_eq_dec : EqDec equation.
  Existing Instance eqn_eq_dec.
  Parameter var : Type.
  Parameter var_eq_dec : EqDec var.
  Existing Instance var_eq_dec.
  Parameter varsable_equation: varsable equation var.
  Existing Instance varsable_equation.

  Parameter context : Type.
  Parameter a_context : context.
  Parameter context_override : overridable context var.
  Parameter eval : evalable context equation.
  Existing Instance eval.

  Axiom eval_override_disjoint: forall
    (l : list var) (ctx ctx' : context) (eqn : equation),
    disjoint l (vars eqn) ->
    (ctx |= eqn <-> ([l => ctx'] ctx) |= eqn).

  Axiom eval_override_sublist: forall
    (l : list var) (ctx ctx' : context) (eqn : equation),
    ctx |= eqn -> sublist (vars eqn) l ->
    ([l => ctx] ctx') |= eqn.

End PARTITION_INPUT.

Module Type PARTITION (Import pi : PARTITION_INPUT).

  Parameter partition : list equation -> list (list equation).

  Axiom partition_sublist : forall (l : list equation),
   forall l', In l' (partition l) -> sublist l' l.

  Axiom partition_exist : forall (l : list equation),
   forall e, In e l -> exists l', In l' (partition l) /\ In e l'.

  Axiom partition_disjoint : forall (l:list equation),
   disjoint_pwise (var_list_extract (partition l)).

  Axiom partition_eval: forall l rho,
   rho |= l <-> (forall l', In l' (partition l) -> rho |= l').

End PARTITION.

Module Type PARTITION_SAT (Import pi : PARTITION_INPUT).

  Declare Module Part : PARTITION pi.
  Import Part.

  Definition SAT := fun (l : list equation) => exists rho, rho |= l.

  Definition partition_SAT : list equation -> list (list equation) := partition.

  Axiom partition_SAT_correct1: forall l,
   SAT l -> forall l', In l' (partition_SAT l) -> SAT l'.

  Axiom partition_SAT_correct2 : forall l,
    (forall l', In l' (partition_SAT l) -> SAT l') -> SAT l.

End PARTITION_SAT.

Module Type PARTITION_IMPL (Import pi : PARTITION_INPUT).

  Definition IMPL := fun (l1 l2 : list equation) => forall rho, rho |= l1 -> rho |= l2.
  Definition IMPL_pair (p : (list equation*list equation)): Prop := IMPL (fst p) (snd p).
  Parameter partition_IMPL : list equation -> list equation -> list (list equation*list equation).
  Parameter SAT : list equation -> Prop.

  Axiom partition_IMPL_sublist1: forall l1 l2 l1' l2',
   In (l1',l2') (partition_IMPL l1 l2) -> sublist l1' l1.

  Axiom partition_IMPL_sublist2: forall l1 l2 l1' l2',
   In (l1',l2') (partition_IMPL l1 l2) -> sublist l2' l2.

  Axiom partition_IMPL_correct1: forall l1 l2,
   (forall pl', In pl' (partition_IMPL l1 l2) -> IMPL_pair pl') ->
   IMPL l1 l2.

  Axiom partition_IMPL_In1: forall l1 l2 eqn,
   In eqn l1 -> exists l1' l2', In eqn l1' /\ In (l1',l2') (partition_IMPL l1 l2).

  Axiom partition_IMPL_In2: forall l1 l2 eqn,
   In eqn l2 -> exists l1' l2', In eqn l2' /\ In (l1',l2') (partition_IMPL l1 l2).

  Axiom partition_IMPL_disjoint: forall l1 l2 l1' l2' l1'' l2'' i j,
   nth_op i (partition_IMPL l1 l2) = Some (l1',l2') ->
   nth_op j (partition_IMPL l1 l2) = Some (l1'',l2'') ->
   i <> j -> disjoint (vars (l1'++l2')) (vars (l1''++l2'')).

  Axiom partition_IMPL_correct2 : forall l1 l2,
   SAT l1 -> IMPL l1 l2 ->
   forall pl', In pl' (partition_IMPL l1 l2) -> IMPL_pair pl'.

End PARTITION_IMPL.

Close Scope part_scope.


(** * Adjunctions *)
(** ** Definitions *)
Require Adjoint.Core.
(** *** unit+UMP *)
(** *** counit+UMP *)
(** *** unit+counit+zig+zag *)
Require Adjoint.UnitCounit.
(** *** universal morphisms *)
Require Adjoint.UniversalMorphisms.
(** *** hom-set isomorphism *)
Require Adjoint.Hom.
(** ** Coercions between various definitions *)
Require Adjoint.UnitCounitCoercions.
Require Adjoint.HomCoercions.
(** ** Opposite adjunctions *)
Require Adjoint.Dual.
(** ** Path spaces of adjunctions *)
Require Adjoint.Paths.
(** ** Composition *)
Require Adjoint.Composition.
(** ** Pointwise adjunctions *)
Require Adjoint.Pointwise.
(** ** Functoriality of any adjoint construction *)
Require Adjoint.Functorial.

Include Adjoint.Core.
Include Adjoint.UnitCounit.
Include Adjoint.UniversalMorphisms.Core.
Include Adjoint.Hom.
Include Adjoint.UnitCounitCoercions.
Include Adjoint.HomCoercions.
Include Adjoint.Dual.
Include Adjoint.Paths.
Include Adjoint.Composition.
Include Adjoint.Pointwise.
Include Adjoint.Functorial.Core.

Require Export Adjoint.Notations.


Require Import VST.floyd.proofauto.
Require Import pile.
Instance PileCompSpecs : compspecs. make_compspecs prog. Defined.
Require Import simple_spec_stdlib.
Require Import PileModel.

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

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

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

Hint Resolve listrep_local_facts : saturate_local.

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

Hint Resolve listrep_valid_pointer : valid_pointer.

Opaque listrep.

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

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

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

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

Hint Resolve pilerep_local_facts : saturate_local.
Hint Resolve pilerep_valid_pointer : valid_pointer.

Local Open Scope assert.

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

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

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

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

Definition PileASI:funspecs := [ Pile_new_spec; Pile_add_spec; Pile_count_spec; Pile_free_spec].


From Coq Require Import List String Arith.
From minilog Require Import utils data set operators.
Import ListNotations.

(** * Substitutions and Unifiers *)

(** Closed substitutions (functions from variables to [datum]) *)
Definition csubstitution := nat -> datum.

(** Open substitutions (functions from variables to [pattern]) *)
Definition psubstitution := nat -> pattern.

(** Apply a closed substitution to a pattern *)
Fixpoint csubst (p : pattern) (sub : csubstitution) : datum :=
  match p with
  | Papp f pats =>
    Dapp f (map (fun p => csubst p sub) pats)
  | Pvar n => sub n
  end.

(** Apply an open substitution to a pattern *)
Fixpoint psubst (p : pattern) (sub : psubstitution) : pattern :=
  match p with
  | Papp f pats =>
    Papp f (map (fun p => psubst p sub) pats)
  | Pvar n => sub n
  end.

Definition dom (sub : psubstitution) : pset nat :=
  fun x => sub x <> Pvar x.

Definition codom (sub : psubstitution) : pset nat :=
  fun x => exists y, free_var (sub y) x.

Definition fin_csubst := (fin_map datum).
Definition fin_psubst := (fin_map pattern).

(** Intepreting a finite map as a csubstitution *)
Definition cinterp (sub : fin_csubst) : csubstitution :=
  fun x => match get sub x with None => Dcst "" | Some vx => vx end.

(** Intepreting a finite map as a psubstitution *)
Definition pinterp (sub : fin_psubst) : psubstitution :=
  fun x => match get sub x with None => Pvar x | Some vx => vx end.

Coercion cinterp : fin_csubst >-> csubstitution.
Coercion pinterp : fin_psubst >-> psubstitution.

Definition replace (p : pattern) (x : nat) (q : pattern) :=
  psubst p (pinterp [(x, q)]).

Notation "p '.[' x ':=' q ']'" := (replace p x q) (at level 60).
Notation "p '.[' s ']'" := (psubst p s) (at level 60).

Lemma subst_replace_var:
  forall x y sub pat,
    sub x = sub y ->
    pat.[sub] = pat.[x := Pvar y].[sub].
Proof.
  intros x y sub.
  refine (pattern_induction _ _ _).
  - intros z Heq1. unfold replace, pinterp. simpl.
    destruct (x =? z)%nat eqn:Heq2; auto.
    now apply Nat.eqb_eq in Heq2; subst.
  - intros f dats Hdats Heq1. simpl. f_equal.
    induction Hdats; auto.
    specialize (H Heq1). simpl. now f_equal.
Qed.

Lemma subst_replace:
  forall x px sub pat,
    sub x = px.[sub] ->
    pat.[sub] = pat.[x := px].[sub].
Proof.
  intros x px sub.
  refine (pattern_induction _ _ _).
  - intros y Heq1.
    unfold replace, pinterp. simpl.
    destruct (x =? y)%nat eqn:Heq2; auto.
    now apply Nat.eqb_eq in Heq2; subst.
  - intros f dats H1 H2.
    simpl. f_equal.
    rewrite map_map.
    apply map_ext_in.
    intros p Hp.
    rewrite Forall_forall in H1.
    now specialize (H1 _ Hp H2).
Qed.

Lemma map_in:
  forall A B (f : A -> B) (l : list A) b,
    In b (List.map f l) -> exists a, In a l /\ b = f a.
Proof.
  intros. induction l; try easy.
  destruct H as [<- | H].
  - repeat econstructor.
  - specialize (IHl H) as (a' & Ha' & ->).
    exists a'. split; auto. now right.
Qed.

Theorem free_subst_1:
  forall pat x vx,
    ~free_var vx x ->
    ~free_var (pat .[ x := vx]) x.
Proof.
  refine (pattern_induction _ _ _).
  - intros y x vx Hfree Hcontr.
    unfold replace, pinterp in Hcontr. simpl in Hcontr.
    destruct (x =? y)%nat eqn:Heq; try easy.
    apply Nat.eqb_neq in Heq. now inversion Hcontr; subst.
  - intros f dats IH x vx Hfree Hcontr.
    inversion Hcontr as [|? ? ? H]; subst. clear Hcontr.
    apply Exists_exists in H as [pat' [Hpat1 Hpat2]].
    apply map_in in Hpat1 as [pat [Hpat1 ->]].
    rewrite Forall_forall in IH.
    now specialize (IH _ Hpat1 _ _ Hfree).
Qed.

Theorem free_subst_2:
  forall pat x y vy,
    ~free_var vy y ->
    ~free_var pat y ->
    ~free_var (pat .[ x := vy]) y.
Proof.
  refine (pattern_induction _ _ _).
  - intros x y z vz Hfree1 Hfree2 Hcontr.
    unfold replace, pinterp in Hcontr. simpl in Hcontr.
    destruct (y =? x)%nat eqn:Heq; try easy.
  - intros f dats IH x y vy Hfree1 Hfree2 Hcontr.
    inversion Hcontr as [|? ? ? H]; subst. clear Hcontr.
    apply Exists_exists in H as [pat' [Hpat1 Hpat2]].
    apply map_in in Hpat1 as [pat [Hpat1 ->]].
    rewrite Forall_forall in IH.
    assert (~free_var pat y).
    { intros Hcontr. apply Hfree2.
      econstructor. apply Exists_exists.
      now exists pat.
    }
    apply (IH _ Hpat1 _ _ _ Hfree1 H Hpat2).
Qed.

Theorem free_subst_3:
  forall pat x vx y,
    free_var (pat.[x := vx]) y ->
    ~free_var vx y ->
    free_var pat y.
Proof.
  refine (pattern_induction _ _ _).
  - intros x y vy z H Hcontr.
    inversion H; subst.
    unfold replace, pinterp in H1. simpl in *.
    destruct (y =? x)%nat eqn:Heq.
    apply Nat.eqb_eq in Heq; subst.
    exfalso. apply Hcontr. econstructor.
    apply Nat.eqb_neq in Heq; subst.
    injection H1 as ->. econstructor.
    unfold replace, pinterp in H0. simpl in *.
    destruct (y =? x)%nat eqn:Heq; try easy.
    apply Nat.eqb_eq in Heq; subst.
    exfalso. apply Hcontr. now econstructor.
  - intros. inversion H0; subst.
    apply Exists_exists in H5 as [w [[p [Hw1 Hw2]]%map_in Hw3]].
    rewrite Hw2 in Hw3.
    rewrite Forall_forall in H.
    specialize (H _ Hw1 _ _ _ Hw3).
    econstructor. apply Exists_exists.
    exists p. split; auto.
Qed.

Lemma free_dom_subst:
  forall pat sub,
    ((free_var pat ∩ dom sub) ⊆ ∅)%ops -> pat.[sub] = pat.
Proof.
  refine (pattern_induction _ _ _).
  - intros x sub H. simpl.
    destruct (sub x) eqn:Heq1.
    destruct (Nat.eq_dec n x); subst; auto.
    exfalso. apply (H x). split.
    econstructor. red. intros Hcontr.
    rewrite Hcontr in Heq1. now injection Heq1 as ->.
    exfalso. apply (H x). split. econstructor.
    red. now rewrite Heq1.
  - intros f dats H sub Hsub. simpl. f_equal.
    induction dats; try easy.
    inversion H; subst. simpl.
    specialize (IHdats H3). f_equal.
    apply H2. intros x [Hx1 Hx2].
    apply Hsub. repeat constructor; auto.
    apply IHdats. intros x [Hx1 Hx2].
    apply Hsub. constructor; auto.
    inversion Hx1; subst.
    apply free_var_app. now apply Exists_cons_tl.
Qed.

Lemma dom_cons:
  forall (sub : fin_psubst) y x vx,
    dom (((x, vx)::sub) : fin_psubst) y ->
    x = y \/ dom sub y.
Proof.
  intros sub y x vx H.
  unfold dom, pinterp in *. simpl in *.
  destruct (x =? y)%nat eqn:Heq.
  - apply Nat.eqb_eq in Heq as ->.
    now left.
  - right. apply H.
Qed.

Definition fin_dom (sub : fin_psubst) : pset nat :=
  fun x => get sub x <> None.

Lemma dom_fin_dom:
  forall (sub : fin_psubst), (dom sub ⊆ fin_dom sub)%ops.
Proof.
  intros sub x Hx.
  unfold dom, fin_dom, pinterp in *.
  destruct (get sub x) eqn:Heq; try easy.
Qed.

Lemma fin_dom_cons:
  forall (sub : fin_psubst) y x vx,
    fin_dom (((x, vx)::sub)) y ->
    x = y \/ fin_dom sub y.
Proof.
  intros sub y x vx H.
  unfold fin_dom, pinterp in *. simpl in *.
  destruct (x =? y)%nat eqn:Heq.
  - apply Nat.eqb_eq in Heq as ->.
    now left.
  - right. apply H.
Qed.

Lemma fin_dom_in:
  forall x sub, fin_dom sub x -> exists vx, get sub x = Some vx.
Proof.
  intros. induction sub as [| [y vy] sol IH]; try easy.
  apply fin_dom_cons in H as [-> | H].
  exists vy. simpl. now rewrite Nat.eqb_refl.
  specialize (IH H) as [vx Hvx].
  simpl. destruct (y =? x)%nat.
  repeat econstructor.
  now exists vx.
Qed.

(** ** Operations on substitutions *)

Declare Scope subst.
Delimit Scope subst with subst.

(** Composing two subtitutions ([s2] after [s1]) *)
Definition compose (s2 s1 : psubstitution) (n : nat) : pattern :=
  psubst (s1 n) s2.

Infix "•" := compose (at level 80) : subst.

Definition equ (s1 s2 : psubstitution) :=
  forall n, s1 n = s2 n.

Infix "≡" := equ (at level 90) : subst.

Definition subst_le (s1 s2 : psubstitution) : Prop :=
  exists s3, (s3 • s1 ≡ s2)%subst.

Infix "<=" := subst_le (at level 70).

(** ** Matching *)

(** What is means that a substitution is a matching for a [datum] and a [pattern] *)
Definition Matching sub (dat : datum) (pat : pattern) : Prop :=
  dat = csubst pat sub.

(** What is means that a [pattern] matches a [datum] *)
Definition Match (dat : datum) (pat : pattern) : Prop :=
  exists sub, Matching sub dat pat.

(** ** Unifiers *)

(** What is means that to be a unifier *)
Definition Unifier (sub : psubstitution) (pat1 pat2 : pattern) : Prop :=
  psubst pat1 sub = psubst pat2 sub.

Definition Mgu (sub : psubstitution) (pat1 pat2 : pattern) : Prop :=
  Unifier sub pat1 pat2 /\ forall sub', Unifier sub' pat1 pat2 -> (sub <= sub')%subst.

(** What is means that two patterns are unifiable *)
Definition Unifiable (pat1 pat2 : pattern) : Prop :=
  exists sub, Unifier sub pat1 pat2.

Lemma psubst_compose :
  forall s1 s2 t, psubst t (s2 • s1)%subst = psubst (psubst t s1) s2.
Proof.
  intros s1 s2. apply pattern_induction; simpl; try easy.
  intros f ts Hts. induction ts; simpl; auto.
  f_equal. inversion Hts; subst. rewrite H1.
  specialize (IHts H2). clear H2.
  simpl in IHts. now injection IHts as ->.
Qed.


From iris.base_logic Require Import base_logic.
From stdpp Require fin_map_dom.
From iris.proofmode Require Export tactics.
Import uPred.

Section definition.
  Context `{Countable K}.
  Context {PROP : bi}.

  Definition big_sepSS(s : gset K) (Φ : K -> K -> PROP) : PROP:=
    [∗ set] x1 ∈ s, [∗ set] x2 ∈ s, Φ x1 x2.

  Definition big_sepSS_singleton(s : gset K) (x0: K) (Φ : K -> K -> PROP) : PROP:=
    if decide (x0 ∈ s) then
    (Φ x0 x0 ∗ ([∗ set] x ∈ (s∖ {[x0]}), Φ x0 x ∗ Φ x x0))%I
    else ([∗ set] x ∈ (s∖ {[x0]}), Φ x0 x ∗ Φ x x0)%I.

  Definition big_sepSS_except(s : gset K) (x0: K) (Φ : K -> K -> PROP) : PROP:=
    big_sepSS (s ∖ {[x0]}) Φ.

End definition.

Section lemmas.
  Context `{Countable K}.
  Context {PROP : bi}.
  Implicit Types s : gset K.
  Implicit Type Φ : (K -> K -> PROP).

  Lemma big_sepSS_union_singleton s (x:K) Φ:
    x ∉ s ->
    big_sepSS s Φ ∗ big_sepSS_singleton (s ∪ {[x]}) x Φ ⊢ big_sepSS (s ∪ {[x]}) Φ.
  Proof.
    iIntros (Hnin) "[SS single]".
    rewrite /big_sepSS.
    rewrite big_sepS_union.
    rewrite big_sepS_singleton.
    rewrite (big_sepS_proper (λ y, [∗ set] x2 ∈ (s ∪ {[x]}), Φ y x2)%I).
    2:{
      intros.
      iApply big_sepS_union.
      set_solver.
    }
    rewrite big_sepS_sep.
    iFrame "SS".
    rewrite /big_sepSS_singleton.
    rewrite 2?big_sepS_union.
    rewrite 2?big_sepS_singleton.
    rewrite (big_sepS_proper (λ y, [∗ set] y0 ∈ {[x]}, Φ y y0)%I).
    2:{
      intros.
      iApply big_sepS_singleton.
    }
    assert ((s ∪ {[x]}) ∖ {[x]} = s) as ->. set_solver.
    case_decide.
    rewrite big_sepS_sep.
    iDestruct ("single") as "[$ [$ $]]".
    set_solver.
    set_solver.
    set_solver.
  Qed.

  Lemma big_sepSS_difference_singleton s (x0:K) Φ:
    x0 ∈ s ->
    big_sepSS s Φ ⊢ big_sepSS_except s x0 Φ ∗ big_sepSS_singleton s x0 Φ.
  Proof.
    iIntros (Hin) "SS".
    rewrite /big_sepSS_except /big_sepSS.
    rewrite /big_sepSS_singleton.
    assert (s = s ∖ {[x0]} ∪ {[x0]}). rewrite difference_union_L. set_solver + Hin.
    rewrite H0 in Hin.
    rewrite H0.
    assert ((s ∖ {[x0]} ∪ {[x0]}) ∖ {[x0]} = s ∖ {[x0]}) as ->.
    set_solver +.
    rewrite big_sepS_union.
    rewrite big_sepS_singleton.
    rewrite big_sepS_union.
    rewrite big_sepS_singleton.
    rewrite (big_sepS_proper (λ y, [∗ set] x2 ∈ (s ∖ {[x0]} ∪ {[x0]}), Φ y x2)%I).
    2:{
      intros.
      iApply big_sepS_union.
      set_solver.
    }
    rewrite big_sepS_sep.
    rewrite (big_sepS_proper (λ y, [∗ set] y0 ∈ {[x0]}, Φ y y0)%I).
    2:{
      intros.
      iApply big_sepS_singleton.
    }
    case_decide.
    rewrite big_sepS_sep.
    iDestruct ("SS") as "(($&$)&$&$)".
    done.
    set_solver.
    set_solver.
  Qed.

  Lemma big_sepSS_sep s Φ Φ1 Φ2 :
    (∀ x y, Φ x y ⊣⊢ Φ1 x y ∗ Φ2 x y) ->
    big_sepSS s Φ ⊣⊢ big_sepSS s Φ1 ∗ big_sepSS s Φ2.
  Proof.
    intros.
    rewrite /big_sepSS.
    rewrite (big_sepS_proper (λ x1, [∗ set] x2 ∈ s, Φ x1 x2)%I).
    2:{
      intros.
      rewrite (big_sepS_proper (λ x2, Φ x x2)%I).
      2:{
        intros.
        apply H0.
      }
      iApply big_sepS_sep.
    }
    rewrite big_sepS_sep.
    done.
  Qed.

  Lemma big_sepSS_singletion_union s v v' Φ :
    v ∈ s ->
    big_sepSS_singleton (s ∖ {[v]}) v' Φ ∗ big_sepSS_singleton {[v]} v' Φ
    ⊣⊢ big_sepSS_singleton s v' Φ.
  Proof.
    intro.
    rewrite /big_sepSS_singleton.
    case_decide.
    case_decide;first set_solver.
    case_decide;last set_solver.
    rewrite -sep_assoc.
    rewrite -big_sepS_union.
    rewrite -difference_union_distr_l_L.
    assert ((s ∖ {[v]} ∪ {[v]}) = s) as ->.
    rewrite difference_union_L. set_solver.
    done.
    set_solver.
    case_decide.
    case_decide;last set_solver.
    rewrite sep_comm .
    rewrite -sep_assoc.
    rewrite -big_sepS_union.
    rewrite -difference_union_distr_l_L.
    assert (({[v]} ∪ s ∖ {[v]}) = s) as ->.
    rewrite union_comm_L. rewrite difference_union_L. set_solver.
    done.
    set_solver.
    case_decide. set_solver.
    rewrite -big_sepS_union.
    rewrite -difference_union_distr_l_L.
    assert ((s ∖ {[v]} ∪ {[v]}) = s) as ->.
    rewrite difference_union_L. set_solver.
    done.
    set_solver.
  Qed.

  Lemma big_sepSS_later (s : gset K) (Φ : K -> K -> PROP) `{!BiAffine PROP}:
    ▷ big_sepSS s Φ ⊣⊢ big_sepSS s (λ i j, ▷ (Φ i j)).
  Proof.
    rewrite /big_sepSS.
    rewrite (big_sepS_later (λ x1, [∗ set] x2 ∈ s, Φ x1 x2)%I s).
    iApply big_sepS_proper.
    intros. iApply big_sepS_later.
  Qed.

  Lemma big_sepSS_except_later (s : gset K) i (Φ : K -> K -> PROP) `{!BiAffine PROP}:
    ▷ big_sepSS_except s i Φ ⊣⊢ big_sepSS_except s i (λ i j, ▷ (Φ i j)).
  Proof.
    rewrite /big_sepSS_except.
    iApply big_sepSS_later.
  Qed.

  Lemma big_sepSS_singleton_later (s : gset K) i (Φ : K -> K -> PROP) `{!BiAffine PROP}:
    ▷ big_sepSS_singleton s i Φ ⊣⊢ big_sepSS_singleton s i (λ i j, ▷ (Φ i j)).
  Proof.
    rewrite /big_sepSS_singleton.
    case_decide.
    rewrite later_sep.
    rewrite big_sepS_later.
    iSplitL; iIntros "[$ ?]".
    iApply big_sepS_proper.
    intros. symmetry. iApply later_sep. done.
    iApply big_sepS_proper.
    intros. iApply later_sep. done.
    rewrite big_sepS_later.
    iApply big_sepS_proper.
    intros. iApply later_sep.
  Qed.

End lemmas.


From Undecidability.Shared.Libs.PSL Require Export Prelim EqDec.

Export ListNotations.
Notation "x 'el' A" := (In x A) (at level 70).
Notation "A <<= B" := (incl A B) (at level 70).
Notation "| A |" := (length A) (at level 65).
Definition equi X (A B : list X) : Prop := incl A B /\ incl B A.
Notation "A === B" := (equi A B) (at level 70).
Hint Unfold equi : core.

Hint Extern 4 =>
match goal with
|[ H: ?x el nil |- _ ] => destruct H
end : core.

(* ** Lists *)

(* Register additional simplification rules with autorewrite / simpl_list *)
(* Print Rewrite HintDb list. *)
Hint Rewrite <- app_assoc : list.
Hint Rewrite rev_app_distr map_app prod_length : list.

Lemma list_cycle  (X : Type) (A : list X) x :
  x::A <> A.
Proof.
  intros B.
  assert (C: |x::A| <> |A|) by (cbn; lia).
  apply C. now rewrite B.
Qed.

(* *** Decisions for lists *)

Instance list_in_dec X (x : X) (A : list X) :
  eq_dec X -> dec (x el A).
Proof.
  intros D. apply in_dec. exact D.
Qed.

(* Certifying find *)

Lemma cfind X A (p: X -> Prop) (p_dec: forall x, dec (p x)) :
  {x | x el A /\ p x} + {forall x, x el A -> ~ p x}.
Proof.
  destruct (find (fun x => Dec (p x)) A) eqn:E.
  - apply find_some in E. firstorder.
  - right. intros. eapply find_none in E; eauto.
Qed.

Arguments cfind {X} A p {p_dec}.

Instance list_forall_dec X A (p : X -> Prop) :
  (forall x, dec (p x)) -> dec (forall x, x el A -> p x).
Proof.
  intros p_dec.
  destruct (find (fun x => Dec (~ p x)) A) eqn:Eq.
  - apply find_some in Eq as [H1 H0 %Dec_true]; right; auto.
  - left. intros x E. apply find_none with (x := x) in Eq. apply dec_DN; auto. auto.
Qed.

Instance list_exists_dec X A (p : X -> Prop) :
  (forall x, dec (p x)) -> dec (exists x, x el A /\ p x).
Proof.
  intros p_dec.
  destruct (find (fun x => Dec (p x)) A) eqn:Eq. (* New: eta expansion needed *)
  - apply find_some in Eq as [H0 H1 %Dec_true]. firstorder. (* New: Need firstorder here *)
  - right. intros [x [E F]]. apply find_none with (x := x) in Eq; auto. eauto. (* New: Why can't auto solve this? *)
Qed.

Lemma list_exists_DM X A  (p : X -> Prop) :
  (forall x, dec (p x)) ->
  ~ (forall x, x el A -> ~ p x) -> exists x, x el A /\ p x.
Proof.
  intros D E.
  destruct (find (fun x => Dec (p x)) A) eqn:Eq.
  + apply find_some in Eq as [? ?%Dec_true]. eauto.
  + exfalso. apply E. intros. apply find_none with (x := x) in Eq;  eauto.
Qed.

Lemma list_exists_not_incl (X: eqType) (A B : list X) :
  ~ A <<= B -> exists x, x el A /\ ~ x el B.
Proof.
  intros E.
  apply list_exists_DM; auto.
  intros F. apply E. intros x G.
  apply dec_DN; auto.
Qed.

Lemma list_cc X (p : X -> Prop) A :
  (forall x, dec (p x)) ->
  (exists x, x el A /\ p x) -> {x | x el A /\ p x}.
Proof.
  intros D E.
  destruct (cfind A p) as [[x [F G]]|F].
  - eauto.
  - exfalso. destruct E as [x [G H]]. apply (F x); auto.
Qed.

(* *** Membership

We use the following lemmas from Coq's standard library List.
- [in_eq :  x el x::A]
- [in_nil :  ~ x el nil]
- [in_cons :  x el A -> x el y::A]
- [in_or_app :  x el A \/ x el B -> x el A++B]
- [in_app_iff :  x el A++B <-> x el A \/ x el B]
- [in_map_iff :  y el map f A <-> exists x, f x = y /\ x el A]
*)

Hint Resolve in_eq in_nil in_cons in_or_app : core.

Section Membership.
  Variable X : Type.
  Implicit Types (x y: X) (A B: list X).

  Lemma in_sing x y :
    x el [y] -> x = y.
  Proof.
    cbn. intros [[]|[]]. reflexivity.
  Qed.

  Lemma in_cons_neq x y A :
    x el y::A -> x <> y -> x el A.
  Proof.
    cbn. intros [[]|D] E; congruence.
  Qed.

  Lemma not_in_cons x y A :
    ~ x el y :: A -> x <> y /\ ~ x el A.
  Proof.
    intuition; subst; auto.
  Qed.

(* *** Disjointness *)

  Definition disjoint A B :=
    ~ exists x, x el A /\ x el B.

  Lemma disjoint_forall A B :
    disjoint A B <-> forall x, x el A -> ~ x el B.
  Proof.
    split.
    - intros D x E F. apply D. exists x. auto.
    - intros D [x [E F]]. exact (D x E F).
  Qed.

  Lemma disjoint_symm A B :
    disjoint A B -> disjoint B A.
  Proof.
    firstorder.
  Qed.

  Lemma disjoint_incl A B B' :
    B' <<= B -> disjoint A B -> disjoint A B'.
  Proof.
    firstorder.
  Qed.

  Lemma disjoint_nil B :
    disjoint nil B.
  Proof.
    firstorder.
  Qed.

  Lemma disjoint_nil' A :
    disjoint A nil.
  Proof.
    firstorder.
  Qed.

  Lemma disjoint_cons x A B :
    disjoint (x::A) B <-> ~ x el B /\ disjoint A B.
  Proof.
    split.
    - intros D. split.
      + intros E. apply D. eauto.
      + intros [y [E F]]. apply D. eauto.
    - intros [D E] [y [[F|F] G]].
      + congruence.
      + apply E. eauto.
  Qed.

  Lemma disjoint_app A B C :
    disjoint (A ++ B) C <-> disjoint A C /\ disjoint B C.
  Proof.
    split.
    - intros D. split.
      + intros [x [E F]]. eauto 6.
      + intros [x [E F]]. eauto 6.
    - intros [D E] [x [F G]].
      apply in_app_iff in F as [F|F]; eauto.
  Qed.

End Membership.

Hint Resolve disjoint_nil disjoint_nil' : core.

(* *** Inclusion

We use the following lemmas from Coq's standard library List.
- [incl_refl :  A <<= A]
- [incl_tl :  A <<= B -> A <<= x::B]
- [incl_cons : x el B -> A <<= B -> x::A <<= B]
- [incl_appl : A <<= B -> A <<= B++C]
- [incl_appr : A <<= C -> A <<= B++C]
- [incl_app : A <<= C -> B <<= C -> A++B <<= C]
*)

Hint Resolve incl_refl incl_tl incl_cons incl_appl incl_appr incl_app : core.

Lemma incl_nil X (A : list X) :
  nil <<= A.

Proof. intros x []. Qed.

Hint Resolve incl_nil : core.

Lemma incl_map X Y A B (f : X -> Y) :
  A <<= B -> map f A <<= map f B.

Proof.
  intros D y E. apply in_map_iff in E as [x [E E']].
  subst y. apply in_map_iff. eauto.
Qed.

Section Inclusion.
  Variable X : Type.
  Implicit Types A B : list X.

  Lemma incl_nil_eq A :
    A <<= nil -> A=nil.

  Proof.
    intros D. destruct A as [|x A].
    - reflexivity.
    - exfalso. apply (D x). auto.
  Qed.

  Lemma incl_shift x A B :
    A <<= B -> x::A <<= x::B.

  Proof. auto. Qed.

  Lemma incl_lcons x A B :
    x::A <<= B <-> x el B /\ A <<= B.
  Proof.
    split.
    - intros D. split; hnf; auto.
    - intros [D E] z [F|F]; subst; auto.
  Qed.

  Lemma incl_sing x A y :
    x::A <<= [y] -> x = y /\ A <<= [y].
  Proof.
    rewrite incl_lcons. intros [D E].
    apply in_sing in D. auto.
  Qed.

  Lemma incl_rcons x A B :
    A <<= x::B -> ~ x el A -> A <<= B.

  Proof. intros C D y E. destruct (C y E) as [F|F]; congruence. Qed.

  Lemma incl_lrcons x A B :
    x::A <<= x::B -> ~ x el A -> A <<= B.

  Proof.
    intros C D y E.
    assert (F: y el x::B) by auto.
    destruct F as [F|F]; congruence.
  Qed.

  Lemma incl_app_left A B C :
    A ++ B <<= C -> A <<= C /\ B <<= C.
  Proof.
    firstorder.
  Qed.

End Inclusion.

Definition inclp (X : Type) (A : list X) (p : X -> Prop) : Prop :=
  forall x, x el A -> p x.

(* *** Setoid rewriting with list inclusion and list equivalence *)

Instance incl_preorder X :
  PreOrder (@incl X).
Proof.
  constructor; hnf; unfold incl; auto.
Qed.

Instance equi_Equivalence X :
  Equivalence (@equi X).
Proof.
  constructor; hnf; firstorder.
Qed.

Instance incl_equi_proper X :
  Proper (@equi X ==> @equi X ==> iff) (@incl X).
Proof.
  hnf. intros A B D. hnf. firstorder.
Qed.

Instance cons_incl_proper X x :
  Proper (@incl X ==> @incl X) (@cons X x).
Proof.
  hnf. apply incl_shift.
Qed.

Instance cons_equi_proper X x :
  Proper (@equi X ==> @equi X) (@cons X x).
Proof.
  hnf. firstorder.
Qed.

Instance in_incl_proper X x :
  Proper (@incl X ==> Basics.impl) (@In X x).
Proof.
  intros A B D. hnf. auto.
Qed.

Instance in_equi_proper X x :
  Proper (@equi X ==> iff) (@In X x).
Proof.
  intros A B D. firstorder.
Qed.

Instance app_incl_proper X :
  Proper (@incl X ==> @incl X ==> @incl X) (@app X).
Proof.
  intros A B D A' B' E. auto.
Qed.

Instance app_equi_proper X :
  Proper (@equi X ==> @equi X ==> @equi X) (@app X).
Proof.
  hnf. intros A B D. hnf. intros A' B' E.
  destruct D, E; auto.
Qed.

Section Equi.
  Variable X : Type.
  Implicit Types A B : list X.

  Lemma equi_push x A :
    x el A -> A === x::A.
  Proof.
    auto.
  Qed.

  Lemma equi_dup x A :
    x::A === x::x::A.

  Proof.
    auto.
  Qed.

  Lemma equi_swap x y A:
    x::y::A === y::x::A.
  Proof.
    split; intros z; cbn; tauto.
  Qed.

  Lemma equi_shift x A B :
    x::A++B === A++x::B.
  Proof.
    split; intros y.
    - intros [D|D].
      + subst; auto.
      + apply in_app_iff in D as [D|D]; auto.
    - intros D. apply in_app_iff in D as [D|D].
      + auto.
      + destruct D; subst; auto.
  Qed.

  Lemma equi_rotate x A :
    x::A === A++[x].
  Proof.
    split; intros y; cbn.
    - intros [D|D]; subst; auto.
    - intros D. apply in_app_iff in D as [D|D].
      + auto.
      + apply in_sing in D. auto.
  Qed.

End Equi.

Lemma in_concat_iff A l (a:A) : a el concat l <-> exists l', a el l' /\ l' el l.
Proof.
  induction l; cbn.
  - intuition. now destruct H.
  - rewrite in_app_iff, IHl. firstorder subst. auto.
Qed.

Lemma app_comm_cons' (A : Type) (x y : list A) (a : A) :
  x ++ a :: y = (x ++ [a]) ++ y.
Proof. rewrite <- app_assoc. cbn. trivial. Qed.

(* skipn *)

Lemma skipn_nil (X : Type) (n : nat) : skipn n nil = @nil X.
Proof. destruct n; cbn; auto. Qed.

Lemma skipn_app (X : Type) (xs ys : list X) (n : nat) :
  n = (| xs |) ->
  skipn n (xs ++ ys) = ys.
Proof.
  intros ->. revert ys. induction xs; cbn; auto.
Qed.

Lemma skipn_length (X : Type) (n : nat) (xs : list X) :
  length (skipn n xs) = length xs - n.
Proof.
  revert xs. induction n; intros; cbn.
  - lia.
  - destruct xs; cbn; auto.
Qed.

(* Repeat *)

Lemma map_repeat (X Y : Type) (f : X -> Y) (n : nat) (a : X) :
  map f (repeat a n) = repeat (f a) n.
Proof. induction n; cbn in *; f_equal; auto. Qed.

Lemma repeat_add_app (X : Type) (m n : nat) (a : X) :
  repeat a (m + n) = repeat a m ++ repeat a n.
Proof. induction m; cbn; f_equal; auto. Qed.

Lemma repeat_S_cons (X : Type) (n : nat) (a : X) :
  a :: repeat a n = repeat a n ++ [a].
Proof.
  replace (a :: repeat a n) with (repeat a (S n)) by trivial. replace (S n) with (n+1) by lia.
  rewrite repeat_add_app. cbn. trivial.
Qed.

Lemma repeat_app_eq (X : Type) (m n : nat) (a : X) :
  repeat a n ++ repeat a m = repeat a m ++ repeat a n.
Proof. rewrite <- !repeat_add_app. f_equal. lia. Qed.

Lemma repeat_eq_iff (X : Type) (n : nat) (a : X) x :
  x = repeat a n <-> length x = n /\ forall y, y el x -> y = a.
Proof.
  split.
  {
    intros ->. split. apply repeat_length. apply repeat_spec.
  }
  {
    revert x. induction n; intros x (H1&H2); cbn in *.
    - destruct x; cbn in *; congruence.
    - destruct x; cbn in *; inv H1. f_equal.
      + apply H2. auto.
      + apply IHn. auto.
  }
Qed.

Lemma rev_repeat (X : Type) (n : nat) (a : X) :
  rev (repeat a n) = repeat a n.
Proof.
  apply repeat_eq_iff. split.
  - rewrite rev_length. rewrite repeat_length. auto.
  - intros y Hx % in_rev. eapply repeat_spec; eauto.
Qed.

Lemma concat_repeat_repeat (X : Type) (n m : nat) (a : X) :
  concat (repeat (repeat a n) m) = repeat a (m*n).
Proof.
  induction m as [ | m' IHm]; cbn.
  - auto.
  - rewrite repeat_add_app. f_equal. auto.
Qed.

Corollary skipn_repeat_add (X : Type) (n m : nat) (a : X) :
  skipn n (repeat a (n + m)) = repeat a m.
Proof.
  rewrite repeat_add_app. erewrite skipn_app; eauto. symmetry. apply repeat_length.
Qed.

Corollary skipn_repeat (X : Type) (n : nat) (a : X) :
  skipn n (repeat a n) = nil.
Proof.
  rewrite <- (app_nil_r (repeat a n)). erewrite skipn_app; eauto. symmetry. apply repeat_length.
Qed.

(* Facts about equality for [map] and [rev] *)
Lemma rev_eq_nil (Z: Type) (l: list Z) :
  rev l = nil -> l = nil.
Proof. intros. destruct l; cbn in *. reflexivity. symmetry in H. now apply app_cons_not_nil in H. Qed.

Lemma map_eq_nil (Y Z: Type) (f: Y->Z) (l: list Y) :
  map f l = nil -> l = nil.
Proof. intros. destruct l; cbn in *. reflexivity. congruence. Qed.

Lemma map_eq_nil' (Y Z: Type) (f: Y->Z) (l: list Y) :
  nil = map f l -> l = nil.
Proof. now intros H % eq_sym % map_eq_nil. Qed.

Lemma map_eq_cons (A B: Type) (f: A->B) (xs: list A) (y: B) (ys: list B) :
  map f xs = y :: ys ->
  exists x xs', xs = x :: xs' /\
          y = f x /\
          ys = map f xs'.
Proof. induction xs; intros H; cbn in *; inv H; eauto. Qed.

Lemma map_eq_cons' (A B: Type) (f: A -> B) (xs: list A) (y: B) (ys: list B) :
  y :: ys = map f xs ->
  exists x xs', xs = x :: xs' /\
          y = f x /\
          ys = map f xs'.
Proof. now intros H % eq_sym % map_eq_cons. Qed.

Lemma map_eq_app (A B: Type) (f: A -> B) (ls : list A) (xs ys : list B) :
  map f ls = xs ++ ys ->
  exists ls1 ls2, ls = ls1 ++ ls2 /\
             xs = map f ls1 /\
             ys = map f ls2.
Proof.
  revert xs ys. induction ls; intros; cbn in *.
  - symmetry in H. apply app_eq_nil in H as (->&->). exists nil, nil. cbn. tauto.
  - destruct xs; cbn in *.
    + exists nil. eexists. repeat split. cbn. now subst.
    + inv H. specialize IHls with (1 := H2) as (ls1&ls2&->&->&->).
      repeat econstructor. 2: instantiate (1 := a :: ls1). all: reflexivity.
Qed.

Lemma rev_eq_cons (A: Type) (ls: list A) (x : A) (xs: list A) :
  rev ls = x :: xs ->
  ls = rev xs ++ [x].
Proof. intros H. rewrite <- rev_involutive at 1. rewrite H. cbn. reflexivity. Qed.

(* Injectivity of [map], if the function is injective *)
Lemma map_injective (X Y: Type) (f: X -> Y) :
  (forall x y, f x = f y -> x = y) ->
  forall xs ys, map f xs = map f ys -> xs = ys.
Proof.
  intros HInj. hnf. intros x1. induction x1 as [ | x x1' IH]; intros; cbn in *.
  - now apply map_eq_nil' in H.
  - now apply map_eq_cons' in H as (l1&l2&->&->%HInj&->%IH).
Qed.

Instance map_ext_proper A B: Proper (@ pointwise_relation A B (@eq B) ==> (@eq (list A)) ==> (@eq (list B))) (@map A B).
Proof.
  intros f f' Hf a ? <-. induction a;cbn;congruence.
Qed.

(* ** Lemmas about [hd], [tl] and [removelast] *)

Lemma tl_map (A B: Type) (f: A -> B) (xs : list A) :
  tl (map f xs) = map f (tl xs).
Proof. now destruct xs; cbn. Qed.

(* Analogous to [removelast_app] *)

Lemma tl_app (A: Type) (xs ys : list A) :
  xs <> nil ->
  tl (xs ++ ys) = tl xs ++ ys.
Proof. destruct xs; cbn; congruence. Qed.

Lemma tl_rev (A: Type) (xs : list A) :
  tl (rev xs) = rev (removelast xs).
Proof.
  induction xs; cbn; auto.
  destruct xs; cbn in *; auto.
  rewrite tl_app; cbn in *.
  - now rewrite IHxs.
  - intros (H1&H2) % app_eq_nil; inv H2.
Qed.

Lemma hd_map (A B: Type) (f: A -> B) (xs : list A) (a : A) :
  hd (f a) (map f xs) = f (hd a xs).
Proof. destruct xs; cbn; auto. Qed.

Lemma hd_app (A: Type) (xs ys : list A) a :
  xs <> nil ->
  hd a (xs ++ ys) = hd a xs.
Proof. intros H. destruct xs; auto. now contradiction H. Qed.

Lemma hd_rev (A: Type) (xs : list A) (a : A) :
  hd a (rev xs) = last xs a.
Proof.
  induction xs; cbn; auto.
  destruct xs; cbn; auto.
  rewrite hd_app. now apply IHxs.
  intros (H1&H2)%app_eq_nil; inv H2.
Qed.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo115:
  prime  10492504530720708046338171434923129->
  prime  2224424442783039323682545799822955619261761489.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      2224424442783039323682545799822955619261761489
      212001284943
      ((10492504530720708046338171434923129,1)::nil)
      0
      221184
      48
      576)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


(* * Natural Deduction *)

From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability.FOL Require Import Syntax.Facts Syntax.Theories Syntax.Asimpl.
From Undecidability.FOL Require Export Deduction.FragmentND.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Import ListAutomationHints.
Import ListAutomationInstances.
Require Import Lia.
Require Import EqdepFacts.
Import FragmentSyntax.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

#[local] Ltac comp := repeat (progress (cbn in *; autounfold in *)).

Section ND_def.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {ff : falsity_flag}.
  Context {p : peirce}.

  Lemma impl_prv A B phi :
    (rev B ++ A) ⊢ phi -> A ⊢ (B ==> phi).
  Proof.
    revert A; induction B; intros A; cbn; simpl_list; intros.
    - firstorder.
    - eapply II. now eapply IHB.
  Qed.

  Theorem Weak A B phi :
    A ⊢ phi -> A <<= B -> B ⊢ phi.
  Proof.
    intros H. revert B.
    induction H; intros B HB; try unshelve (solve [econstructor; auto with datatypes]); try now econstructor.
  Qed.

  Hint Constructors prv : core.

  Theorem subst_Weak A phi xi :
    A ⊢ phi -> [phi[xi] | phi ∈ A] ⊢ phi[xi].
  Proof.
    induction 1 in xi |-*; comp.
    1-7:eauto using in_map.
    - apply AllI. setoid_rewrite map_map in IHprv. erewrite map_map, map_ext.
      apply IHprv. intros ?. cbn. now rewrite up_form.
    - specialize (IHprv xi). apply AllE with (t := t`[xi]) in IHprv. rewrite subst_comp in *.
      erewrite subst_ext; try apply IHprv. intros [|]; cbn; trivial.
      unfold funcomp. now setoid_rewrite subst_term_shift.
  Qed.

  Definition cycle_shift n x :=
    if Dec (n = x) then $0 else $(S x).
  Lemma cycle_shift_shift n phi :
    bounded n phi -> phi[cycle_shift n] = phi[↑].
  Proof.
    intros H. apply (bounded_subst H). intros k. unfold cycle_shift. destruct (Dec _); trivial; lia.
  Qed.

  Lemma cycle_shift_subject n phi :
    bounded (S n) phi -> phi[$n..][cycle_shift n] = phi.
  Proof.
    intros H. erewrite subst_comp, (bounded_subst H), subst_id; trivial.
    intros []; cbn; unfold cycle_shift; destruct (Dec _); trivial; lia.
  Qed.

  Lemma nameless_equiv_all' A phi n :
    bounded_L n A -> bounded (S n) phi -> [f[↑] | f ∈ A] ⊢ phi <-> A ⊢ phi[$n..].
  Proof.
    intros H1 H2. split; intros H.
    - apply (subst_Weak ($n..)) in H. rewrite map_map in *.
      erewrite map_ext, map_id in H; try apply H. intros. apply subst_shift.
    - apply (subst_Weak (cycle_shift n)) in H. rewrite (map_ext_in _ (subst_form ↑)) in H.
      + now rewrite cycle_shift_subject in H.
      + intros psi HP. now apply cycle_shift_shift, H1.
  Qed.

  Lemma nameless_equiv_all A phi :
    { t : nat | map (subst_form ↑) A ⊢ phi <-> A ⊢ phi[$t..] }.
  Proof.
    destruct (find_bounded_L (phi::A)) as [n H].
    exists n. apply nameless_equiv_all'.
    - intros ? ?. apply H. auto.
    - eapply bounded_up; try apply H; auto.
  Qed.

  Lemma AllI_named (A : list form) (phi : form) :
    (forall t, A ⊢ phi[t..]) -> A ⊢ ∀phi.
  Proof.
    intros H. apply AllI.
    destruct (nameless_equiv_all A phi) as [t Ht].
    apply Ht, H.
  Qed.

  Lemma imps T phi psi :
    T ⊢ (phi → psi) <-> (phi :: T) ⊢ psi.
  Proof.
    split; try apply II.
    intros H. apply IE with phi; auto. apply (Weak H). auto.
  Qed.

  Lemma big_imps A B phi : (A ++ B) ⊢ phi <-> B ⊢ (impl A phi).
  Proof.
    induction A as [|psi A IH] in B,phi|-*; cbn; try tauto.
    split; intros Hprv.
    - apply II. apply IH. eapply Weak. 1: apply Hprv.
      intros x [->|[HA|HB]%in_app_iff]; apply in_app_iff.
      + right; now left.
      + now left.
      + right; now right.
    - eapply Weak. 1: apply (IH (psi::B)).
      + eapply IE. 1: eapply Weak; [apply Hprv|firstorder]. apply Ctx; now left.
      + intros x [HA|[->|HB]]%in_app_iff.
        * right. apply in_app_iff. now left.
        * now left.
        * right. apply in_app_iff. now right.
  Qed.

  Lemma big_imps_nil A phi : A ⊢ phi <-> [] ⊢ (impl A phi).
  Proof.
    specialize (big_imps A nil phi). rewrite <- (app_nil_end). easy.
  Qed.

  Lemma subst_forall_prv phi {N Gamma} :
    Gamma ⊢ (forall_times N phi) -> bounded N phi -> forall sigma, Gamma ⊢ phi[sigma].
  Proof.
    induction N in phi |-*; intros ?? sigma; cbn in *.
    - change sigma with (iter up 0 sigma).
      now rewrite (subst_bounded 0).
    - specialize (IHN (∀ phi) ).
      rewrite <-up_decompose.
      apply AllE. apply IHN. unfold forall_times.
      now rewrite <-iter_switch.
      now apply bounded_S_quant.
  Qed.

  Lemma prv_cut A B phi :
    A ⊢ phi -> (forall psi, psi el A -> B ⊢ psi) -> B ⊢ phi.
  Proof.
    induction A in phi |- *; intros H1 H2.
    - eapply Weak; eauto.
    - rewrite <- imps in H1. apply IHA in H1; auto. apply IE with a; trivial. now apply H2.
  Qed.

  Lemma prv_intu_peirce T φ : T ⊢I φ -> T ⊢ φ.
  Proof using.
    remember intu. induction 1. all: now eauto.
  Qed.

End ND_def.

Local Hint Constructors prv : core.

(* ** Rudimentary tactics for ND manipulations *)

Ltac subsimpl_in H :=
  rewrite ?up_term, ?subst_term_shift in H.

Ltac subsimpl :=
  rewrite ?up_term, ?subst_term_shift.

Ltac assert1 H :=
  match goal with |- (?phi :: ?T) ⊢ _ => assert (H : (phi :: T) ⊢ phi) by auto end.

Ltac assert2 H :=
  match goal with |- (?phi :: ?psi :: ?T) ⊢ _ => assert (H : (phi :: psi :: T) ⊢ psi) by auto end.

Ltac assert3 H :=
  match goal with |- (?phi :: ?psi :: ?theta :: ?T) ⊢ _ => assert (H : (phi :: psi :: theta :: T) ⊢ theta) by auto end.

Ltac assert4 H :=
  match goal with |- (?f :: ?phi :: ?psi :: ?theta :: ?T) ⊢ _ => assert (H : (f :: phi :: psi :: theta :: T) ⊢ theta) by auto end.

Ltac prv_all x :=
  apply AllI; edestruct (@nameless_equiv_all) as [x ->]; cbn; subsimpl.

(* ** Custom induction principle *)
Lemma prv_ind_full {Σ_funcs : funcs_signature} {Σ_preds : preds_signature} :
  forall P : peirce -> list (form falsity_on) -> (form falsity_on) -> Prop,
    (forall (p : peirce) (A : list form) (phi psi : form),
        (phi :: A) ⊢ psi -> P p (phi :: A) psi -> P p A (phi → psi)) ->
    (forall (p : peirce) (A : list form) (phi psi : form),
        A ⊢ (phi → psi) -> P p A (phi → psi) -> A ⊢ phi -> P p A phi -> P p A psi) ->
    (forall (p : peirce) (A : list form) (phi : form),
        (map (subst_form ↑) A) ⊢ phi -> P p (map (subst_form ↑) A) phi -> P p A (∀ phi)) ->
    (forall (p : peirce) (A : list form) (t : term) (phi : form),
        A ⊢ (∀ phi) -> P p A (∀ phi) -> P p A (phi[t..])) ->
    (forall (p : peirce) (A : list form) (phi : form), A ⊢ ⊥ -> P p A ⊥ -> P p A phi) ->
    (forall (p : peirce) (A : list form) (phi : form), phi el A -> P p A phi) ->
    (forall (A : list form) (phi psi : form), P class A (((phi → psi) → phi) → phi)) ->
    forall (p : peirce) (l : list form) (f14 : form), l ⊢ f14 -> P p l f14.
Proof.
  intros. specialize (@prv_ind _ _ (fun ff => match ff with falsity_on => P | _ => (fun _ _ _ => True) end)). intros H'.
  apply H' with (ff := falsity_on); clear H'. all: intros; try destruct ff; trivial. all: intuition eauto 2.
Qed.

(* ** Enumerability of proofs *)

Section Enumerability.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Variable list_Funcs : nat -> list syms.
  Hypothesis enum_Funcs' : list_enumerator__T list_Funcs syms.

  Variable list_Preds : nat -> list preds.
  Hypothesis enum_Preds' : list_enumerator__T list_Preds preds.

  Hypothesis eq_dec_Funcs : eq_dec syms.
  Hypothesis eq_dec_Preds : eq_dec preds.

  Instance eqdec_binop : eq_dec binop.
  Proof.
    intros x y. unfold dec. decide equality.
  Qed.

  Instance eqdec_quantop : eq_dec quantop.
  Proof.
    intros x y. unfold dec. decide equality.
  Qed.

  Definition list_binop (n : nat) := [Impl].

  Instance enum_binop :
    list_enumerator__T list_binop binop.
  Proof.
    intros []; exists 0; cbn; tauto.
  Qed.

  Definition list_quantop (n : nat) := [All].

  Instance enum_quantop :
    list_enumerator__T list_quantop quantop.
  Proof.
    intros []; exists 0; cbn; tauto.
  Qed.

  Lemma enumT_binop :
    enumerable__T binop.
  Proof.
    apply enum_enumT. exists list_binop. apply enum_binop.
  Qed.

  Lemma enumT_quantop :
    enumerable__T quantop.
  Proof.
    apply enum_enumT. exists list_quantop. apply enum_quantop.
  Qed.

  Instance enum_term' :
    list_enumerator__T (L_term _) term :=
    enum_term _.

  Instance enum_form' {ff : falsity_flag} :
    list_enumerator__T (L_form _ _ _ _) form :=
    enum_form _ _ _ _.

  Fixpoint L_ded {p : peirce} {b : falsity_flag} (A : list form) (n : nat) : list form :=
    match n with
    | 0 => A
    | S n =>   L_ded A n ++
    (* II *)   concat ([ [ phi → psi | psi ∈ L_ded (phi :: A) n ] | phi ∈ L_T form n ]) ++
    (* IE *)   [ psi | (phi, psi) ∈ (L_ded A n × L_T form n) , (phi → psi el L_ded A n) ] ++
    (* AllI *) [ ∀ phi | phi ∈ L_ded (map (subst_form ↑) A) n ] ++
    (* AllE *) [ phi[t..] | (phi, t) ∈ (L_T form n × L_T term n), (∀ phi) el L_ded A n ] ++
    (* Exp *)  (match b with falsity_on => fun A =>
                [ phi | phi ∈ L_T form n, ⊥ el @L_ded _ falsity_on A n ]
                | _ => fun _ => nil end A) ++
    (* Pc *)   (if p then
                [ (((phi → psi) → phi) → phi) | (pair phi psi) ∈ (L_T form n × L_T form n) ]
                else nil)
    end.

  Opaque in_dec.

  Lemma enum_prv {p : peirce} {b : falsity_flag} A :
    list_enumerator (L_ded A) (prv A).
  Proof with try (eapply cum_ge'; eauto; lia).
    split.
    - rename x into phi. induction 1; try congruence; subst.
      + destruct IHprv as [m1], (el_T phi) as [m2]. exists (1 + m1 + m2). cbn. in_app 2.
        eapply in_concat. eexists. split. 1: eapply in_map.
        2: eapply in_map. 1:idtac... idtac...
      + destruct IHprv1 as [m1], IHprv2 as [m2], (el_T psi) as [m3]; eauto.
        exists (1 + m1 + m2 + m3).
        cbn. in_app 3. in_collect (phi, psi)...
      + destruct IHprv as [m]. exists (1 + m). cbn. in_app 4. in_collect phi...
      + destruct IHprv as [m1], (el_T t) as [m2], (el_T phi) as [m3]. exists (1 + m1 + m2 + m3).
        cbn. in_app 5. in_collect (phi, t)...
      + destruct IHprv as [m1], (el_T phi) as [m2]. exists (1 + m1 + m2). cbn. in_app 6. in_collect phi...
      + now exists 0.
      + destruct (el_T phi) as [m1], (el_T psi) as [m2]. exists (1 + m1 + m2). cbn. in_app 7. in_collect (phi, psi)...
    - intros [m H]; induction m in A, x, H |-*; cbn in *.
      + now apply Ctx.
      + repeat invert_list_in.
        * eauto.
        * eapply II; eauto.
        * eapply IE; eapply IHm; eauto.
        * eapply AllI; eapply IHm; eauto.
        * eapply AllE; eapply IHm; eauto.
        * destruct b; repeat invert_list_in. eapply Exp, IHm; eauto.
        * destruct p; repeat invert_list_in. eapply Pc.
  Qed.

  Fixpoint L_con `{falsity_flag} (L : nat -> list form) (n : nat) : list (list form) :=
    match n with
    | 0 => [ nil ]
    | S n => L_con L n ++ [ phi :: A | (pair phi A) ∈ (L n × L_con L n) ]
    end.

  Lemma enum_el X (p : X -> Prop) L x :
    list_enumerator L p -> p x -> exists m, x el L m.
  Proof.
    firstorder.
  Qed.
  Arguments enum_el {X p L} x _ _.

  Lemma enum_p X (p : X -> Prop) L x m :
    list_enumerator L p -> x el L m -> p x.
  Proof.
    firstorder.
  Qed.

  Definition containsL `{falsity_flag} A (T : form -> Prop) :=
    forall psi, psi el A -> T psi.

  Lemma enum_containsL `{falsity_flag} T L :
    cumulative L -> list_enumerator L T -> list_enumerator (L_con L) (fun A => containsL A T).
  Proof with try (eapply cum_ge'; eauto; lia).
    intros HL He. split.
    - induction x as [| phi A]; intros HT.
      + exists 0. firstorder.
      + destruct IHA as [m1], (enum_el phi He) as [m2]. 1,2,3: firstorder.
        exists (1 + m1 + m2). cbn. in_app 2. in_collect (phi, A)...
    - intros [m]. induction m in x, H0 |-*; cbn in *.
      + destruct H0 as [<- | []]. firstorder.
      + repeat invert_list_in.
        1: now apply IHm. apply IHm in H1. apply (enum_p He) in H0. unfold containsL in *. firstorder congruence.
  Qed.

  Fixpoint L_tded {p : peirce} {b : falsity_flag} (L : nat -> list form) (n : nat) : list form :=
    match n with
    | 0 => nil
    | S n => L_tded L n ++ concat ([ L_ded A n | A ∈ L_con L n ])
    end.

  Lemma enum_tprv {p : peirce} {b : falsity_flag} T L :
    list_enumerator L T -> list_enumerator (L_tded (cumul L)) (tprv T).
  Proof with try (eapply cum_ge'; eauto; lia).
    intros He.
    assert (HL : list_enumerator (cumul L) T) by now apply list_enumerator_to_cumul.
    split.
    - intros (A & [m1] % (enum_el A (@enum_containsL _ _ (cumul L) (to_cumul_cumulative L) HL)) & [m2] % (enum_el x (enum_prv A))).
      exists (1 + m1 + m2). cbn. in_app 2. eapply in_concat. eexists. split. in_collect A... idtac...
    - intros [m]. induction m in x, H |-*; cbn in *. 1: contradiction. repeat invert_list_in. 1: now eapply IHm.
      exists x1; split.
      + eapply (enum_p (enum_containsL (to_cumul_cumulative L) HL)); eauto.
      + eapply (enum_p (enum_prv x1)); eassumption.
  Qed.

End Enumerability.

Section TheoryManipulation.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {p : peirce} {ff : falsity_flag}.
  Context {HF : eq_dec syms} {HP : eq_dec preds}.
  Lemma prv_T_impl T phi psi :
    (T ⋄ phi) ⊢T psi -> T ⊢T (phi → psi).
  Proof using HF HP ff p Σ_funcs Σ_preds.
    intros (A & HA1 & HA2). exists (remove (dec_form _ _ _ _) phi A); split.
    - intros f [[] % HA1 Hf2] % in_remove; subst; intuition.
    - eapply II, Weak. 1: apply HA2. transitivity (phi :: A). 1: eauto. intros a [-> | Ha].
      + now left.
      + destruct (dec_form _ _ _ _ a phi) as [->|Hr]. 1:now left.
        right. now eapply in_in_remove.
  Qed.

  Lemma prv_T_remove T phi psi :
    T ⊢T phi -> T ⋄ phi ⊢T psi -> T ⊢T psi.
  Proof using HF HP ff p Σ_funcs Σ_preds.
    intros (A & HA1 & HA2) (B & HB1 & HB2) % prv_T_impl.
    use_theory (A ++ B).
    - now intros psi1 [H1|H2]%in_app_iff; [apply HA1 | apply HB1].
    - eapply IE; eapply Weak. 1,3: eassumption.
      all: intros x Hx; apply in_app_iff; eauto.
  Qed.

  Lemma prv_T_comp T phi psi xi :
    T ⋄ phi ⊢T xi -> T ⋄ psi ⊢T phi -> T ⋄ psi ⊢T xi.
  Proof using HF HP.
    intros (A & HA1 & HA2) % prv_T_impl (B & HB1 & HB2) % prv_T_impl.
    use_theory (psi :: A ++ B).
    - now intros psi1 [->|[H1|H2]%in_app_iff]; [now right | |]; left; [apply HA1 | apply HB1].
    - eapply IE. 1: eapply Weak. 1: apply HA2. 2: eapply IE.
      2-3: eapply Weak. 2: eapply HB2. 3: apply (@Ctx _ _ _ _ (psi::nil)); now left.
      + intros a Ha; right; apply in_app_iff; now left.
      + intros b Hb; right; apply in_app_iff; now right.
      + intros x [->|[]]; now left.
  Qed.

  Lemma elem_prv T phi :
    phi ∈ T -> T ⊢T phi.
  Proof.
    intros ?. use_theory [phi]. 2:apply Ctx; now left.
    intros psi [->|[]]. apply H.
  Qed.

  Lemma Weak_T T1 T2 phi :
    T1 ⊢T phi -> T1 ⊑ T2 -> T2 ⊢T phi.
  Proof.
    intros (A & HA1 & HA2) HT2. exists A. split. 2:easy. intros psi H; now apply HT2, HA1.
  Qed.
End TheoryManipulation.

Section Closedness.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {p : peirce} {ff : falsity_flag}.

  Definition capture_subs n x := $(x + n).

  Lemma capture_extract n A phi :
    A ⊢ subst_form (capture_subs n) (capture All n phi) -> A ⊢ subst_form (capture_subs 0) phi.
  Proof.
    induction n; comp; intuition. apply IHn. apply (AllE (var n)) in H. rewrite subst_comp in H.
    erewrite subst_ext. 1: apply H. intros [| x]; unfold capture_subs; cbn; f_equal; lia.
  Qed.

  Context {Funcs_eq_dec : eq_dec Σ_funcs}.
  Context {Preds_eq_dec : eq_dec Σ_preds}.

  Lemma close_extract A phi :
    A ⊢ close All phi -> A ⊢ phi.
  Proof.
    intros H. assert (Hclosed : closed (close All phi)) by apply close_closed.
    unfold close in *. destruct (find_bounded phi) as [n Hn]; cbn in *.
    erewrite <- subst_id with (sigma := fun x => $x) in H.
    erewrite (@bounded_subst _ _ _ _ _ _ _ (capture_subs n)) in H.
    2: exact Hclosed. 3:easy. 2: lia.
    apply capture_extract in H. rewrite subst_id in H; intuition. unfold capture_subs. f_equal. lia.
  Qed.

End Closedness.

Section DNFacts.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Lemma DN A phi: A ⊢C (¬ (¬ phi)) -> A ⊢C phi.
  Proof.
    intros H. eapply IE. 1: apply Pc. eapply II.
    apply Exp. eapply IE. 2: apply Ctx; now left.
    eapply Weak. 1: apply H. intros a Ha; now right.
  Qed.
  Lemma DN_into {p:peirce} A phi: A ⊢ phi -> A ⊢ (¬ (¬ phi)).
  Proof.
    intros H. apply II. eapply IE. 1: apply Ctx; now left. eapply Weak; [apply H|].
    firstorder.
  Qed.

  Lemma XMc A (phi chi : form) : (phi::A) ⊢C chi -> ((¬ phi)::A) ⊢C chi -> A ⊢C chi.
  Proof.
    intros HA HB. eapply IE with ((phi → chi) → (¬phi → chi) → chi).
    - eapply II. eapply IE. 1: eapply IE. 1: apply Ctx; now left.
      1-2: eapply Weak; [eapply II|]. 1: apply HA. 2: apply HB. 1-2: intros a Ha; now right.
    - eapply DN. apply II. eapply IE. 1: apply Ctx; now left. eapply II. eapply II.
      eapply IE. 1: apply Ctx; now left.
      eapply II. eapply IE. 1: apply Ctx; do 3 right; now left. do 2 eapply II.
      eapply IE. 1: apply Ctx; right; now left.
      apply Ctx; now eauto.
  Qed.

  Lemma DN_T T phi : T ⊢TC (¬¬phi) -> T ⊢TC phi.
  Proof.
    intros (A & HT & HA). exists A. split; [apply HT|now apply DN].
  Qed.

End DNFacts.

Section RefutationComp.
  Context {Σ_funcs : funcs_signature} {Σ_preds : preds_signature}.
  Context {HF : eq_dec Σ_funcs} {HP : eq_dec Σ_preds}.

  Lemma refutation_prv T phi :
    T ⊢TC phi <-> (T ⋄ ¬ phi) ⊢TC ⊥.
  Proof using HF HP.
    split.
    - intros (A & HA1 & HA2). use_theory (¬ phi :: A).
      + intros psi [<-|Ha]. 1: now right. left. now apply HA1.
      + eapply IE. 1: apply Ctx; now left. eapply Weak. 1: apply HA2. intros a Ha; now right.
    - intros (A & HA1 & HA2) % prv_T_impl. use_theory A. now apply DN.
  Qed.
End RefutationComp.

Section FlagsTransport.
  Context {Σ_funcs : funcs_signature} {Σ_preds : preds_signature}.
  Context {p : peirce}.
  Context {ff : falsity_flag}.

  Lemma prv_transport_to_falsity  A phi :
    A ⊢ phi -> (map to_falsity A) ⊢ (to_falsity phi).
  Proof.
    intros H; induction H.
    - cbn. apply II. apply IHprv.
    - cbn. eapply IE. 1: now apply IHprv1. now apply IHprv2.
    - cbn. apply AllI. rewrite map_map in *.
      erewrite map_ext. 1: now apply IHprv.
      intros a. rewrite <- ! subst_falsity_id.
      rewrite subst_falsity_comm. now cbn.
    - rewrite <- subst_falsity_id.
      change (⊥) with (⊥[t..]). rewrite <- subst_falsity_comm.
      apply AllE. rewrite subst_falsity_id. now apply IHprv.
    - apply Exp. apply IHprv.
    - apply Ctx. now apply in_map.
    - apply Pc.
  Qed.

  Lemma prv_transport_to_class A phi :
    A ⊢ phi -> A ⊢C phi.
  Proof.
    induction 1.
    - now apply II.
    - eapply IE. 1: apply IHprv1. easy.
    - now apply AllI.
    - now apply AllE.
    - now apply Exp.
    - now apply Ctx.
    - apply Pc.
  Qed.
(*
  Ltac resolve_existT :=
    inversion 1; subst;
    repeat match goal with
             H : existT _ _ _ = existT _ _ _ |- _ => try apply Eqdep_dec.inj_pair2_eq_dec in H; [|try decide equality]
           end.

  Lemma prv_transport_from_falsity'
    {ff1 ff2 : falsity_flag}
    A' (phi' : @form _ _ _ ff2)
    A (phi : @form _ _ _ ff1)
    (Heqn : ff2 = falsity_on) : A' ⊢ phi' -> match ff2
      as ff return list (@form _ _ _ ff) -> @form _ _ _ ff -> Prop
      with falsity_off => fun A' phi' => False
         | falsity_on => fun A' phi' => A' = map to_falsity A -> phi' = to_falsity phi -> A ⊢ phi
    end A' phi'.
  Proof.
    induction 1 in A,phi,Heqn|-*; try (destruct ff; try congruence); intros HeqA Heqphi.
    - destruct phi as [|t1 t2|ff [] phi psi'|ff [] phi]; cbn in Heqphi; try congruence.
      apply II. apply IHprv. 1:easy. cbn. f_equal. 2: easy.
      all: injection Heqphi; intros He1 He2.
      all: apply Eqdep_dec.inj_pair2_eq_dec in He1; [|decide equality].
      all: apply Eqdep_dec.inj_pair2_eq_dec in He2; [|decide equality].
      all: congruence.
    - eapply IE. *)
End FlagsTransport.

Section NegativeTranslation.
  Context {Σ_funcs : funcs_signature} {Σ_preds : preds_signature}.

  Fixpoint negative_translation {ff:falsity_flag} (phi : @form _ _ _ ff) : @form _ _ _ falsity_on := match phi with
    falsity => falsity
  | atom P v => ¬¬(atom P v)
  | bin Impl phi psi => (negative_translation phi) → (negative_translation psi)
  | quant All phi => ∀ (negative_translation phi)
  end.

  Lemma nt_impl {ff:falsity_flag} A phi : negative_translation (impl A phi) = impl (map negative_translation A) (negative_translation phi).
  Proof.
    induction A as [|psi A IH]; cbn; congruence.
  Qed.

  Lemma nt_subst {ff:falsity_flag} phi σ : negative_translation (phi[σ]) = (negative_translation phi)[σ].
  Proof.
    induction phi as [| |?[]|?[]] in σ|-*; try easy.
    - cbn. now rewrite IHphi1, IHphi2.
    - cbn. now rewrite IHphi.
  Qed.

  Lemma nt_dn_float' {p:peirce} {ff:falsity_flag} A phi:
   A ⊢ ((¬¬negative_translation phi) → negative_translation phi).
  Proof.
  revert A. induction phi as [| |?[]|?[]]; intros A; cbn.
  - apply II. eapply IE. 1: apply Ctx; now left. apply II. apply Ctx; now left.
  - apply II. apply II. eapply IE. 1: apply Ctx; right; now left.
    apply II. eapply IE. 1: apply Ctx; now left. apply Ctx; right; now left.
  - apply II. apply II. eapply IE. 1: apply IHphi2. apply II.
    eapply IE. 1: apply Ctx; right; right; now left. apply II.
    eapply IE. 1: apply Ctx; right; now left.
    eapply IE. 1: apply Ctx; now left.
    apply Ctx; right; right; now left.
  - apply II. apply AllI. cbn. eapply IE. 1: apply IHphi.
    apply II. eapply IE. 1: apply Ctx; right; now left.
    apply II. eapply IE. 1: apply Ctx; right; now left.
    assert ((negative_translation phi)[up ↑][$0..] = negative_translation phi) as <- by now asimpl.
    apply AllE. apply Ctx; left; now asimpl.
  Qed.

  Lemma nt_dn_float {p:peirce} {ff:falsity_flag} A phi :
    A ⊢ (¬¬negative_translation phi) -> A ⊢ negative_translation phi.
  Proof.
    intros H. eapply IE. 1: apply nt_dn_float'. easy.
  Qed.

  Lemma nt_peirce {p:peirce} {ff:falsity_flag} A phi psi:
    A ⊢ negative_translation (((phi → psi) → phi) → phi).
  Proof.
    cbn. apply II.
    apply nt_dn_float.
    apply II. eapply IE. 1: apply Ctx; now left.
    eapply IE. 1: apply Ctx; right; now left.
    apply II. apply Exp. eapply IE. 1: apply Ctx; right; now left.
    apply Ctx. now left.
  Qed.

  Lemma nt_Cprv_to_Iprv {p1 : peirce} {ff:falsity_flag} A phi :
    A ⊢C phi -> (map negative_translation A) ⊢ (negative_translation phi).
  Proof.
    remember class as p2. induction 1; cbn in *.
    all: try specialize (IHprv Heqp2).
    all: try specialize (IHprv1 Heqp2).
    all: try specialize (IHprv2 Heqp2).
    - eapply II. now apply IHprv.
    - eapply IE. 1: apply IHprv1. apply IHprv2.
    - eapply AllI. rewrite map_map in *. erewrite map_ext. 1: apply IHprv.
      intros a; cbn. now rewrite nt_subst.
    - rewrite nt_subst. eapply AllE. apply IHprv.
    - eapply Exp. apply IHprv.
    - eapply Ctx. now apply in_map.
    - apply nt_peirce.
  Qed.

  Lemma nt_Cprv_equiv A phi :
    A ⊢C phi <-> A ⊢C (negative_translation phi).
  Proof.
    revert A. induction phi as [| |[]|[]] using form_ind_falsity; intros A; cbn; split; intros Hprv.
    - easy.
    - easy.
    - eapply DN_into. easy.
    - eapply DN. easy.
    - apply II. apply IHphi2. eapply IE. 1: eapply Weak; [apply Hprv|firstorder].
      apply IHphi1. apply Ctx; now left.
    - apply II. apply IHphi2. eapply IE. 1: eapply Weak; [apply Hprv|firstorder].
      apply IHphi1. apply Ctx; now left.
    - apply (subst_Weak ↑) in Hprv. asimpl in Hprv.
      eapply (AllE $0) in Hprv. asimpl in Hprv.
      apply AllI. apply IHphi. apply Hprv.
    - apply (subst_Weak ↑) in Hprv. asimpl in Hprv.
      eapply (AllE $0) in Hprv. asimpl in Hprv.
      apply AllI. apply IHphi. apply Hprv.
  Qed.

  Lemma nt_bounded {ff:falsity_flag} n phi : bounded n phi -> bounded n (negative_translation phi).
  Proof.
    induction 1; cbn.
    - solve_bounds. now econstructor.
    - destruct binop. now solve_bounds.
    - destruct quantop. now solve_bounds.
    - solve_bounds.
  Qed.

  #[local] Existing Instance falsity_on.
  Lemma nt_correct A phi:
    (map negative_translation A) ⊢I negative_translation phi -> A ⊢C phi.
  Proof.
    intros H.
    apply big_imps_nil. apply nt_Cprv_equiv.
    eapply prv_transport_to_class.
    rewrite nt_impl. apply big_imps_nil in H. apply H.
  Qed.

  Lemma nt_correct_theory T phi:
    (tmap negative_translation T) ⊢TI negative_translation phi -> T ⊢TC phi.
  Proof.
    intros (? & (A & -> & HA1) % tmap_contains_L & HA2 % nt_correct).
    now exists A.
  Qed.

End NegativeTranslation.


From Undecidability.L Require Export Util.L_facts Tactics.Extract.
Require Import Undecidability.Shared.Libs.PSL.Bijection String.

(* * Correctness and time bounds *)

(* Typeclass for registering types *)

(* Encodable is in GenEncode *)

Class encInj (X : Type) `(R : encodable X) :=
  inj_enc : injective (X:=X) enc (* encoding is injective *).

Hint Mode encInj - + : typeclass_instances. (* treat argument as input and force evar-freeness*)

(* ** Correctness *)

(* Definition of the valid types for extraction *)

Inductive TT : Type -> Type :=
  TyB t (R : encodable t) : TT t
| TyArr t1 t2 (tt1 : TT t1) (tt2 : TT t2)
  : TT (t1 -> t2).

Existing Class TT.
Existing Instance TyB.
Existing Instance TyArr.

Arguments TyB _ {_}.
Arguments TyArr {_} {_} _ _.

Hint Mode TT + : typeclass_instances. (* treat argument as input and force evar-freeness*)

Notation "! X" := (TyB X) (at level 69).
Notation "X ~> Y" := (TyArr X Y) (right associativity, at level 70).

Fixpoint computes {A} (tau : TT A) {struct tau}: A -> L.term -> Type :=
  match tau with
    !_ => fun x xInt => (xInt = enc x)
  | @TyArr A B tau1 tau2 =>
    fun f t_f  =>
      proc t_f * forall (a : A) t_a,
        computes tau1 a t_a
        ->  {v : term & (app t_f t_a >* v) * computes tau2 (f a) v}
  end%type.

Lemma computesProc t (ty : TT t) (f : t) fInt:
  computes ty f fInt -> proc fInt.
Proof.
  destruct ty.
  -intros ->. unfold enc. now destruct R.
  -now intros [? _].
Qed.

(* This is for a user to give an definition *)
Class computable X {ty : TT X} (x : X) : Type :=
  {
    ext : extracted x;
    extCorrect : computes ty x ext;
  }.

Global Arguments computable {X} {ty} x.
Global Arguments extCorrect {X} ty x {computable} : simpl never.
Global Arguments ext {X} {ty} x {computable} : simpl never.

Hint Mode computable + - +: typeclass_instances. (* treat argument as input and force evar-freeness*)
Hint Extern 4 (@extracted ?t ?f) => let ty := constr:(_ : TT t) in notypeclasses refine (ext (ty:=ty) f) : typeclass_instances.

Typeclasses Opaque ext.

Lemma proc_ext X (ty : TT X) (x : X) ( H : computable x) : proc (ext x).
Proof.
  unfold ext. destruct H. apply (computesProc extCorrect0).
Qed.

Instance reg_is_ext ty (R : encodable ty) (x : ty) : computable x.
Proof.
  exists (enc x). reflexivity.
Defined. (* because ? *)

Lemma computesTyB (t:Type) (x:t) `{encodable t}: computes (TyB t) x (ext x).
Proof.
  unfold ext. now destruct R.
Qed.

Instance extApp' t1 t2 {tt1:TT t1} {tt2 : TT t2} (f: t1 -> t2) (x:t1) (Hf : computable f) (Hx : computable x) : computable (f x).
Proof.
  destruct Hf, Hx.
  edestruct extCorrect0 as [? H].
  edestruct H as (?&?&?).
  eassumption.
  now eapply (@Build_computable _ _ _ x0).
Defined. (* because ? *)

Lemma extApp t1 t2 {tt1:TT t1} {tt2 : TT t2} (f: t1 -> t2) (x:t1) (Hf : computable f) (Hx : computable x) :
  app (ext f) (ext x) >* ext (f x).
Proof.
  unfold ext, extApp'.
  destruct Hf, Hx.
  destruct extCorrect0 as (? & correct0).
  destruct correct0 as (?&?&?). tauto.
Qed.

Lemma ext_is_enc t1 (R:encodable t1) (x: t1) (Hf : computable x) :
  @ext _ _ x Hf = enc x.
Proof.
  now destruct Hf.
Defined. (* because ? *)

Definition computesExp {t} (ty : TT t) (f:t) (s fExt : term) : Type :=
  eval s fExt * computes ty f fExt.

Lemma computesExpStart t1 (tt1 : TT t1) (f : t1) (fExt : term):
  proc fExt ->
  {v :term & computesExp tt1 f fExt v} ->  computes tt1 f fExt.
Proof.
  intros ? (?&?&?). replace fExt with x. tauto. apply unique_normal_forms. eapply e. eapply H. destruct e as [e ?]. now rewrite e.
Qed.

Lemma computesExpStep t1 t2 (tt1 : TT t1) (tt2 : TT t2) (f : t1 -> t2) (s:term) (fExt : term):
  eval s fExt -> closed s ->
  (forall (y : t1) (yExt : term), computes tt1 y yExt -> {v : term & computesExp tt2 (f y) (app s yExt) v}%type) ->
  computesExp (tt1 ~> tt2) f s fExt.
Proof.
  intros ? ? H. split. assumption. split. split. now rewrite <-H0. now destruct H0.
  intros ? ? exted.
  edestruct H as (v&?&?). eassumption.
  eexists v. split. rewrite H0 in e. now rewrite e. eauto.
Qed.

Lemma computesTyArr t1 t2 (tt1 : TT t1) (tt2 : TT t2) f fExt :
  proc fExt
  -> (forall (y : t1) (yExt : term),
        computes tt1 y yExt
        -> {v : term & eval (app fExt yExt) v * (proc v -> computes tt2 (f y) v)}%type)
  -> computes (tt1 ~> tt2) f fExt.
Proof.
  intros ? H'.
  split;[assumption|].
  intros y yExt yCorrect.
  edestruct H' as (?&(R&?) & H''). eassumption.
  eexists. split.
  eassumption.
  eapply H''.
  split. 2:assumption.
  rewrite <- R. apply app_closed. now destruct H. specialize (computesProc yCorrect) as []. easy.
Qed.

(* Extensional equality to extract similar functions without unsopported features (e.g. informative deciders) instead *)

Fixpoint extEq t {tt:TT t} : t -> t -> Prop:=
  match tt with
    TyB _ _ => eq
  | @TyArr t1 t2 tt1 tt2 => fun f f' => forall (x : t1), extEq (f x) (f' x)
  end.

Instance extEq_refl t (tt:TT t): Reflexive (extEq (tt:=tt)).
Proof.
  unfold Reflexive.
  induction tt;cbn.
  -reflexivity.
  -intros f x. eauto.
Qed.

Lemma computesExt X (tt : TT X) (x x' : X) s:
  extEq x x' -> computes tt x s -> computes tt x' s.
Proof.
  induction tt in x,x',s |-*;intros eq.
  -inv eq. tauto.
  -cbn in eq|-*. intros [H1 H2]. split. 1:tauto.
   intros y t exts.
   specialize (H2 y t exts) as (v&R&H2).
   exists v. split. 1:assumption.
   eapply IHtt2. 2:now eassumption.
   apply eq.
Qed.

Lemma computableExt X (tt : TT X) (x x' : X):
  extEq x x' -> computable x -> computable x'.
Proof.
  intros ? (s&?). exists s. eauto using computesExt.
Defined. (* because ? *)

(* register a datatype via an function to another, e.g. vectors as lists *)

Lemma registerAs X Y `{encodable X} (f:Y -> X) : encodable Y.
Proof.
  eexists (fun x => enc (f x)). now destruct H.
Defined.
Arguments registerAs {_ _ _} _.

Lemma registerInjAs X Y R `{@encInj X R} (f:Y -> X) : injective f -> encInj (registerAs f).
Proof.
  unfold encInj.
  intros ? ? ? H'. eapply H0, @inj_enc. all:easy.
Defined. (* because ? *)

(* Support for extracting registerAs-ed functions *)

Fixpoint changeResType t1 t2 (tt1:TT t1) (tt2 : TT t2) : {t & TT t}:=
  match tt1 with
    TyB _ _ => existT _ t2 tt2
  | TyArr _ _ tt11 tt12 =>
    existT _ _ (TyArr tt11 (projT2 (changeResType tt12 tt2)))
  end.

Fixpoint resType t1 (tt1 : TT t1) : {t & encodable t} :=
  match tt1 with
    @TyB _ R => existT _ _ R
  | TyArr _ _ _ t2 => resType t2
  end.

Fixpoint insertCast t1 (tt1 : TT t1) Y (R: encodable Y) {struct tt1}:
  forall (cast : projT1 (resType tt1) -> Y) (f : t1), projT1 (changeResType tt1 (TyB Y)) :=
  match tt1 with
    TyB _ _ => fun cast x => cast x
  | TyArr _ _ tt11 tt12 => fun cast f x=> (insertCast (tt1:=tt12) R cast (f x))
  end.

Lemma cast_registeredAs t1 (tt1 : TT t1) Y (R: encodable Y) (cast : projT1 (resType tt1) -> Y) (f:t1) :
  projT2 (resType tt1) = registerAs cast ->
  computable (ty:=projT2 (changeResType tt1 (TyB Y))) (insertCast R cast f) ->
  computable f.
Proof.
  intros H (s&exts).
  exists s.
  induction tt1 in cast,f,H,s,exts |- *.
  -cbn in H,exts|-*;unfold enc in *. rewrite H. exact exts.
  -destruct exts as (?&exts). split. assumption.
   intros x s__x ext__x.
   specialize (exts x s__x ext__x) as (v &?&exts).
   exists v. split. tauto.
   eapply IHtt1_2. all:eassumption.
Qed.

Opaque computes.


Set Implicit Arguments.
Require Import List Omega std calculus higher_order_unification.
Import ListNotations.

(** * System Unification *)
Section SystemUnification.

  Variable (X: Const).

  Definition eq: Type := exp X * exp X.
  Definition eqs := list eq.

  Implicit Types (sigma: fin -> exp X) (e: eq) (E : eqs).

  Definition eq_typing  Gamma e A := Gamma ⊢ fst e : A /\ Gamma ⊢ snd e : A.

  Notation "Gamma ⊢₂ e : A" := (eq_typing Gamma e A) (at level 80, e at level 99).

  Reserved Notation  "Gamma ⊢₊₊ E : L" (at level 80, E at level 99).

  Inductive eqs_typing Gamma : eqs -> list type -> Prop :=
  | eqs_typing_nil: Gamma ⊢₊₊ nil : nil
  | eqs_typing_cons s t A E L: Gamma ⊢ s : A -> Gamma ⊢ t : A -> Gamma ⊢₊₊ E : L -> Gamma ⊢₊₊ ((s,t) :: E) : A :: L
  where  "Gamma ⊢₊₊ E : L" := (eqs_typing Gamma E L).

  Hint Constructors eqs_typing.

  Definition left_side E := map fst E.
  Definition right_side E := map snd E.

  Lemma left_typing Gamma E L: Gamma ⊢₊₊ E : L -> Gamma ⊢₊ left_side E : L.
  Proof. induction 1; cbn; eauto. Qed.
  Lemma right_typing Gamma E L: Gamma ⊢₊₊ E : L -> Gamma ⊢₊ right_side E : L.
  Proof. induction 1; cbn; eauto. Qed.

  Lemma typing_combine Gamma E L:
    Gamma ⊢₊ left_side E : L -> Gamma ⊢₊ right_side E : L -> Gamma ⊢₊₊ E : L.
  Proof.
    intros H1 H2; induction E in L, H1, H2 |-*; inv H1; inv H2; eauto.
    destruct a; eauto.
  Qed.

  Hint Resolve left_typing right_typing.

  Definition vars' (e: eq) := vars (fst e) ++ vars (snd e).
  Definition Vars' (E: list eq) := flat_map vars' E.

  Lemma Vars'_cons e E: Vars' (e :: E) = vars' e ++ Vars' E.
  Proof. reflexivity. Qed.

  Lemma Vars'_app E1 E2:
    Vars' (E1 ++ E2) = Vars' E1 ++ Vars' E2.
  Proof.
    unfold Vars'; now rewrite !flat_map_app.
  Qed.

  Hint Rewrite Vars'_cons Vars'_app : simplify.

  Definition subst_eq sigma e := let (s, t) := e in (sigma • s, sigma • t).

  Notation "sigma •₊₊ E" := (map (subst_eq sigma) E) (at level 69, right associativity).

  Lemma left_subst_eqs E sigma:
    left_side (sigma •₊₊ E) = sigma •₊ left_side E.
  Proof.
    unfold left_side; induction E as [| []]; cbn; congruence.
  Qed.

  Lemma right_subst_eqs E sigma:
    right_side (sigma •₊₊ E) = sigma •₊ right_side E.
  Proof.
    unfold right_side; induction E as [| []]; cbn; congruence.
  Qed.

  Hint Rewrite left_subst_eqs right_subst_eqs : simplify.

  Lemma equiv_eqs_pointwise sigma E:
    (sigma •₊ left_side E) ≡₊ (sigma •₊ right_side E) -> (forall s t, (s, t) ∈ E -> sigma • s ≡ sigma • t).
  Proof.
    induction E; cbn; intuition; subst.
    all: eapply equiv_lstep_cons_inv in H; intuition.
  Qed.

  Lemma equiv_pointwise_eqs sigma E:
    (forall s t, (s, t) ∈ E -> sigma • s ≡ sigma • t) ->
    (sigma •₊ left_side E) ≡₊ (sigma •₊ right_side E).
  Proof.
    induction E as [| [s t]]; cbn; intros; eauto; intuition.
    rewrite H; intuition.
    rewrite IHE; intuition.
  Qed.

  Lemma eqs_typing_preservation_subst Gamma E L Delta sigma:
      Gamma ⊢₊₊ E : L -> Delta ⊩ sigma : Gamma -> Delta ⊢₊₊ sigma •₊₊ E : L.
  Proof. induction 1; cbn; eauto. Qed.

  Definition all_terms (P: exp X -> Prop) (E: eqs) := forall s t, (s, t) ∈ E -> P s /\ P t.
  Definition all_eqs (P: exp X -> exp X -> Prop) (E: eqs) := forall s t, (s, t) ∈ E -> P s t.

  Lemma all_terms_cons P e E:
    all_terms P (e :: E) -> P (fst e) /\ P (snd e) /\ all_terms P E.
  Proof.
    destruct e as [s t]; intros H; cbn.
    specialize (H s t) as H'; cbn in H'; intuition.
    intros ???; eapply H; cbn; intuition.
  Qed.

  Lemma all_terms_cons_iff P e E:
    all_terms P (e :: E) <-> P (fst e) /\ P (snd e) /\ all_terms P E.
  Proof.
    unfold all_eqs; cbn; split.
    - eauto using all_terms_cons.
    - intros (? & ? & ?) ? ? [->|H']; firstorder.
  Qed.

  Hint Rewrite all_terms_cons_iff : simplify.

  Lemma all_terms_nil P: all_terms P nil.
  Proof. intros ??[]. Qed.

  Lemma all_terms_app P (E1 E2: eqs):
    all_terms P (E1 ++ E2) <-> all_terms P E1 /\ all_terms P E2.
  Proof.
    unfold all_eqs; split.
    - intros H; split; intros s t H'; eapply H; simplify; intuition.
    - intros [H1 H2] s t; simplify; intros [? % H1|? % H2]; intuition.
  Qed.

  Hint Rewrite all_terms_app : simplify.

  Class sysuni :=
  {
    Gammaᵤ'  : ctx;
    Eᵤ'  : eqs;
    Lᵤ'  : list type;
    Hᵤ' : Gammaᵤ' ⊢₊₊ Eᵤ' : Lᵤ';
  }.

  Definition SU (I: sysuni) :=
    exists (Delta: ctx) (sigma: fin -> exp X), Delta ⊩ sigma : Gammaᵤ' /\ (sigma •₊ left_side Eᵤ') ≡₊ (sigma •₊ right_side Eᵤ').

  Arguments SU: clear implicits.
  Hint Resolve @Hᵤ'.

  Definition linearize_terms (S: list (exp X)) :=
    lambda AppR (var 0) (renL shift S).

  Lemma linearize_terms_subst sigma S: sigma • linearize_terms S = linearize_terms (sigma •₊ S).
  Proof. unfold linearize_terms; asimpl.
         rewrite !map_map; asimpl.
         f_equal. f_equal. eapply map_ext.
         intros ?; now asimpl.
  Qed.

  Lemma linearize_terms_equiv S T:
    linearize_terms S ≡ linearize_terms T <-> S ≡₊ T.
  Proof.
    split.
    - intros [? % list_equiv_anti_ren _] % equiv_lam_elim % equiv_AppR_elim; eauto.
      unfold shift; intros ??; congruence.
    - unfold linearize_terms. now intros ->.
  Qed.

  Lemma linearize_terms_typing Gamma S L A:
    Gamma ⊢₊ S : L -> Gamma ⊢ linearize_terms S : (Arr (rev L) A) → A.
  Proof.
    intros H; econstructor; eapply AppR_typing with (L0 := L).
    eapply listtyping_preservation_under_renaming; eauto.
    intros x ?; cbn; eauto.
    econstructor; eauto; simplify; cbn; intuition.
  Qed.

  Lemma linearize_vars S:
    vars (linearize_terms S) === Vars S.
  Proof.
    split.
    - intros ? H % vars_varof. inv H. eapply varof_vars in H1.
      rewrite AppR_vars in H1. simplify in H1. cbn in H1; intuition.
      discriminate. eapply in_flat_map in H as [? []].
      mapinj. eapply vars_ren in H0 as []. intuition.
      injection H1 as ->. eapply in_flat_map. eexists; eauto.
    - intros x H. eapply varof_vars; econstructor; eapply vars_varof.
      rewrite AppR_vars; simplify; right.
      eapply in_flat_map in H as [y]; eapply in_flat_map; exists (ren shift y).
      intuition. now eapply ren_vars.
  Qed.

  Hint Resolve linearize_terms_typing.

  Global Program Instance uni_sysuni (I: uni X): sysuni :=
     { Gammaᵤ' := Gammaᵤ; Eᵤ' := [(sᵤ, tᵤ)]; Lᵤ' := [Aᵤ]; Hᵤ' := _; }.

   Global Program Instance sysuni_uni (I: sysuni): uni X :=
       {
         Gammaᵤ := Gammaᵤ';
         sᵤ := linearize_terms (left_side Eᵤ');
         tᵤ := linearize_terms (right_side Eᵤ');
         Aᵤ := (Arr (rev Lᵤ') alpha) → alpha;
         H1ᵤ := _;
         H2ᵤ := _;
       }.

   Lemma U_SU: U X ⪯ SU.
   Proof.
     exists (uni_sysuni); intros I.
     split; intros (Delta & sigma & H1 & H2); exists Delta; exists sigma; intuition.
     eapply equiv_pointwise_eqs; cbn; firstorder; injection H; intros; subst; eauto.
     eapply equiv_eqs_pointwise; cbn; eauto; cbn; intuition.
   Qed.

   Lemma SU_U: SU ⪯ U X.
   Proof.
     exists (sysuni_uni).
     intros I; split; intros (Delta & sigma & H1 & H2); exists Delta; exists sigma; destruct I; intuition;
       cbn [sᵤ tᵤ sysuni_uni] in *.
     now rewrite !linearize_terms_subst, linearize_terms_equiv.
     now rewrite <-linearize_terms_equiv, <-!linearize_terms_subst.
   Qed.

End SystemUnification.

Arguments SU : clear implicits.
Arguments sysuni : clear implicits.
Arguments Gammaᵤ' {_} {_}.
Arguments Eᵤ' {_} {_}.
Arguments Lᵤ' {_} {_}.

Notation "sigma •₊₊ E" := (map (subst_eq sigma) E) (at level 69, right associativity).
Notation  "Gamma ⊢₊₊ E : L" := (eqs_typing Gamma E L) (at level 80, E at level 99).
Notation "Gamma ⊢₂ e : A" := (eq_typing Gamma e A) (at level 80, e at level 99).

Hint Rewrite all_terms_cons_iff all_terms_app Vars'_app Vars'_cons: simplify.
Hint Resolve all_terms_nil.

(** ** Normalisation *)
Definition SNU {X: Const} (I: sysuni X) :=
  exists Delta sigma, Delta ⊩ sigma : Gammaᵤ' /\ (sigma •₊ left_side Eᵤ') ≡₊ (sigma •₊ right_side Eᵤ') /\
                 forall x, normal (sigma x).

Lemma SU_SNU X I: SU X I <-> SNU I.
Proof.
  split; intros (Delta & sigma & H1 & H2); [| exists Delta; exists sigma; intuition].
  eapply normalise_subst in H1 as (tau & H5 & H6 & H7).
  pose (theta x := if nth (@Gammaᵤ' _ I) x then tau x else var x).
  exists Delta. exists theta. intuition.
  + intros ???; unfold theta; rewrite H; eapply H7; eauto.
  + eapply equiv_pointwise_eqs; intros.
    eapply equiv_eqs_pointwise in H2; intros; eauto.
    rewrite subst_pointwise_equiv with (sigma0 := theta) (tau0 := sigma).
    rewrite subst_pointwise_equiv with (sigma0 := theta) (tau0 := sigma); eauto.
    all: intros ? ?; enough (x ∈ dom Gammaᵤ') as D;
      [domin D; unfold theta; rewrite D|]; eauto.
    all: eapply Vars_listtyping.
    2, 4: eapply in_flat_map; eexists; (intuition eauto).
    2: change t with (snd (s, t)); eapply in_map; eauto.
    2: change s with (fst (s, t)); eapply in_map; eauto.
    all: eauto using left_typing, right_typing, @Hᵤ'.
  + unfold theta; destruct nth eqn: ?; [|eauto].
    domin Heqo; eauto.
Qed.