Require Export GeoCoq.Elements.OriginalProofs.lemma_linereflectionisometry.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_10_12 :
   forall A B C H,
   Per A B C -> Per A B H -> Cong B C B H ->
   Cong A C A H.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists D, (BetS A B D /\ Cong A B D B /\ Cong A C D C /\ neq B C)) by (conclude_def Per );destruct Tf as [D];spliter.
assert (neq B H) by (conclude_def Per ).
let Tf:=fresh in
assert (Tf:exists F, (BetS A B F /\ Cong A B F B /\ Cong A H F H /\ neq B H)) by (conclude_def Per );destruct Tf as [F];spliter.
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (Cong D B A B) by (conclude lemma_congruencesymmetric).
assert (Cong D B F B) by (conclude lemma_congruencetransitive).
assert (Cong B F B D) by (forward_using lemma_doublereverse).
assert (eq F D) by (conclude lemma_extensionunique).
assert (Cong A H D H) by (conclude cn_equalitysub).
assert (Cong A C A H).
by cases on (eq C H \/ neq C H).
{
 assert (Cong A C A C) by (conclude cn_congruencereflexive).
 assert (Cong A C A H) by (conclude cn_equalitysub).
 close.
 }
{
 let Tf:=fresh in
 assert (Tf:exists M, (BetS C M H /\ Cong M C M H)) by (conclude proposition_10);destruct Tf as [M];spliter.
 assert (Cong C B H B) by (forward_using lemma_doublereverse).
 assert (Cong A C A H).
 by cases on (eq B M \/ neq B M).
 {
  assert (Per C B A) by (conclude lemma_8_2).
  assert (BetS C B H) by (conclude cn_equalitysub).
  assert (Cong B C B H) by (conclude cn_equalitysub).
  assert (Cong C B B H) by (forward_using lemma_congruenceflip).
  assert (Cong C A H A) by (conclude lemma_rightreverse).
  assert (Cong A C A H) by (forward_using lemma_congruenceflip).
  close.
  }
 {
  assert (neq M B) by (conclude lemma_inequalitysymmetric).
  assert (Cong C M H M) by (forward_using lemma_congruenceflip).
  assert (Per C M B) by (conclude_def Per ).
  assert (Per B M C) by (conclude lemma_8_2).
  assert (Cong C A C D) by (forward_using lemma_congruenceflip).
  assert (Cong H A H D) by (forward_using lemma_congruenceflip).
  assert (Cong C M C M) by (conclude cn_congruencereflexive).
  assert (Cong M H M H) by (conclude cn_congruencereflexive).
  assert (Cong M A M D) by (conclude lemma_interior5).
  assert (Cong A M D M) by (forward_using lemma_congruenceflip).
  assert (neq B M) by (conclude lemma_inequalitysymmetric).
  assert (Per A B M) by (conclude_def Per ).
  assert (Cong B A B D) by (forward_using lemma_congruenceflip).
  assert (Per M B A) by (conclude lemma_8_2).
  assert (Cong C A H D) by (conclude lemma_linereflectionisometry).
  assert (Cong A C D H) by (forward_using lemma_congruenceflip).
  assert (BetS D B A) by (conclude axiom_betweennesssymmetry).
  assert (Cong B D B A) by (forward_using lemma_congruenceflip).
  assert (Cong A B B D) by (forward_using lemma_congruenceflip).
  assert (Cong A H D H) by (conclude lemma_rightreverse).
  assert (Cong D H A H) by (conclude lemma_congruencesymmetric).
  assert (Cong C A H D) by (forward_using lemma_congruenceflip).
  assert (Cong H D H A) by (forward_using lemma_congruenceflip).
  assert (Cong C A H A) by (conclude lemma_congruencetransitive).
  assert (Cong A C A H) by (forward_using lemma_congruenceflip).
  close.
  }
(** cases *)
 close.
 }
(** cases *)
close.
Qed.

End Euclid.


Require Import Coq.Lists.List.
Require Import Monads.Monad.
Require Import Tactics.CpdtTactics.

Set Implicit Arguments.

(** List monad. *)

Definition ret : forall (A : Type), A -> list A.
Proof.
  intros A x. exact (cons x nil).
Defined.

Definition bind : forall (A B : Type), list A -> (A -> list B) -> list B.
Proof.
  intros A B n f. exact (concat (map f n)).
Defined.

Definition list_eq : forall T : Type, list T -> list T -> Prop :=
  fun T x y => x = y.

Instance list_monad : Monad list list_eq ret bind.
Proof.
  split; unfold ret, bind, list_eq.
  - (* left_id *)
    intros. crush.
  - (* right_id *)
    intros.
    induction x; crush.
  - (* bind_assoc *)
    intros.
    induction n; crush.
    rewrite <- IHn.
    rewrite map_app, concat_app.
    auto.
  - (* equivalence *)
    intros. constructor; crush.
  - (* f_equivalence *)
    intros. induction n; crush.
Qed.

Notation fmap := (@fmap list ret bind).
Notation join := (@join list bind).

Theorem map_eq_fmap :
  forall (A B : Type) (xs : list A) (f : A -> B),
    map f xs = fmap f xs.
Proof.
  induction xs; crush.
Qed.

Theorem concat_eq_join :
  forall (A : Type) (xs : list (list A)),
    concat xs = join xs.
Proof.
  induction xs; crush.
Qed.


Require Import util.
Require Import Coq.Lists.List.
Require Import Coq.Arith.Arith.
Require Import Coq.omega.Omega.
Import ListNotations.

(*******语法部分********)

(*算术表达式*)
Inductive aexp: Type :=
| ANum : nat -> aexp
| AId : id -> aexp    (* Var *)
| APlus : aexp -> aexp -> aexp
| AMult : aexp -> aexp -> aexp
| AMinus : aexp -> aexp -> aexp.

(*块表达式*)
Inductive bkexp : Type :=
| BKNum : nat -> bkexp
| BKId  : id -> bkexp     (* BKVar *)
| BKAddr: id -> aexp -> bkexp.

Inductive fexp : Type :=
(* | FNil : nil -> fexp *)
| FId : id -> fexp
| Fattach : fexp -> bkexp -> fexp.

(*布尔表达式*)
Inductive bexp: Type :=
| BTrue : bexp
| BFalse: bexp
| BEq : aexp -> aexp -> bexp
| BLe : aexp -> aexp -> bexp
| BNot : bexp -> bexp
| BAnd : bexp -> bexp -> bexp
| BOr  : bexp -> bexp -> bexp.

Inductive command: Type :=
| CSkip    : command
| CAss     : id -> aexp -> command
| CSeq     : command -> command -> command
| CIf      : bexp  -> command -> command -> command
| CWhile   : bexp -> command -> command
| CCons    : id -> aexp -> command  (*只创建一个存储空间*)
| CLookup  : id -> aexp -> command
| CMutate  : aexp -> aexp -> command
| CDispose : aexp -> command
(*file*)
| CFcreate : id -> bkexp -> command
| CFattach : id -> bkexp -> command
| CFdelete : id -> command
| CFlength : id -> id -> command
(*block*)
| CBalloc  : id -> aexp -> command
| CBnew    : id -> command
| CBappend : bkexp -> aexp -> command
| CBlookup : id -> bkexp -> aexp -> command
| CBlength : id -> bkexp -> command
| CBreplace : fexp -> aexp -> bkexp -> command
| CBtruncate : bkexp -> command
| CBdelete : bkexp -> command.

Notation " 'SKIP' " := CSkip.
Notation "x '::=' a" := (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

Require Import ssreflect.
Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype.
Set Automatic Coercions Import.
Require Export monads.

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

Definition Rel X Y := X -> Y -> Prop.

Definition SubRel X Y (R Q : Rel X Y)
  := forall x y, R x y -> Q x y.

Definition IdR : forall X, Rel X X := fun X x x' => x = x'.

Definition ArrR X X' Y Y' (RX : Rel X X') (RY : Rel Y Y')
  : Rel (X -> Y) (X' -> Y')
  := fun f f' => forall x x', RX x x' -> RY (f x) (f' x').

Definition ProdR X X' Y Y' (RX : Rel X X') (RY : Rel Y Y')
  : Rel (X * Y) (X' * Y')
  := fun p p' =>
       let (x,y) := p in
       let (x',y') := p' in RX x x' /\ RY y y'.
Hint Unfold ProdR.

Section nProd.
Variable n : nat.

Inductive nProd (X : 'I_n -> Type) : Type :=
  | tuple : forall (f : forall i :'I_n, X i), nProd X.

Definition proj X i (t : nProd X) :=
  let '(tuple f) := t in f i.

Definition nProdR (X : 'I_n -> Type) (X' : 'I_n -> Type)
                  (R : forall i : 'I_n, Rel (X i) (X' i))
  : Rel (nProd X) (nProd X')
  := fun t t' =>
       let '(tuple f) := t in
       let '(tuple f') := t' in
         forall i, R i (f i) (f' i).
End nProd.

Section nSum.
Variable n : nat.

Definition nSum (X : 'I_n -> Type) : Type := sigT X.

Definition inj (X : 'I_n -> Type) i x : nSum X := existT _ i x.
End nSum.

Infix " =R=> " := ArrR (at level 55).
Infix " *R* " := ProdR (at level 55).

Lemma ProdR_elim X X' Y Y' (RX : Rel X X') (RY : Rel Y Y') x y :
  (RX *R* RY) x y -> RX (fst x) (fst y) /\ RY (snd x) (snd y).
Proof.
by case x; case y.
Qed.

Lemma nProdR_elim n X X' R t t' :
  @nProdR n X X' R t t' -> forall i, R i (proj i t) (proj i t').
Proof.
by case: t; case: t'.
Qed.

Definition Gr A B (f : A -> B) : Rel A B
  := fun x y => f x = y.

Module Acceptable.
Section axiom.
Variable T T' : monadType.

Definition TRtype
  := forall X X', Rel X X' -> Rel (T X) (T' X').

Definition acceptableTR (TR : TRtype) : Prop :=
  (forall X X' (R : Rel X X') (x : X) (x' : X'),
    R x x' -> TR X X' R (tval T x) (tval T' x')) /\
    (forall X X' Y Y'
    (Q : Rel X X') (R : Rel Y Y')
    (f : X -> T Y) (f' : X' -> T' Y')
    (tx : T X) (tx' : T' X'),
    (TR X X' Q tx tx') -> (ArrR Q (TR Y Y' R) f f') -> TR Y Y' R (tbind tx f) (tbind tx' f')).
End axiom.

Record TRacc (T T' : monadType) := mkTRacc {
  TR :> TRtype T T';
  (*TR :> forall X X', Rel X X' -> Rel (T X) (T' X');*)
  axiomAcc :> acceptableTR TR
}.

End Acceptable.

Notation TRtype := Acceptable.TRtype.
Notation TRaccType := Acceptable.TRacc.
Notation TR := Acceptable.TR.
Notation Acc :=  Acceptable.axiomAcc.

Module StateAcceptable.
Section axiom.
Variables S S' : Type.
Definition TRtype
  := forall X X', Rel X X' -> Rel (State S X) (State S' X').

Definition acceptableTR (TR : TRtype) : Prop :=
  (forall X X' (R : Rel X X') (x : X) (x' : X'),
    R x x' -> TR X X' R (valState x) (valState x')) /\
    (forall X X' Y Y'
    (Q : Rel X X') (R : Rel Y Y')
    (f : X -> State S Y) (f' : X' -> State S' Y')
    (tx : State S X) (tx' : State S' X'),
    (TR X X' Q tx tx') -> (ArrR Q (TR Y Y' R) f f') -> TR Y Y' R (bindState tx f) (bindState tx' f')).
End axiom.

Record TRacc (S S' : Type) := mkTRacc {
  TR :> TRtype S S';
  axiomAcc :> acceptableTR TR
}.

End StateAcceptable.

Notation StateTRtype := StateAcceptable.TRtype.
Notation StateTRaccType := StateAcceptable.TRacc.
Notation StateTR := StateAcceptable.TR.
Notation StateAcc :=  StateAcceptable.axiomAcc.

Definition TRparam (S S' : Type) (R : Rel S S') : StateTRtype S S'
  := fun X X' Q =>  R =R=> (Q *R* R).

Definition TRparamAcc (S S' : Type) (P : Rel S S') : StateTRaccType S S'.
exists (TRparam P).
split; first by intuition.
move => X X' Y Y' Q R f f' tx tx' H Harr.
move => s s' Hss'.
rewrite /TRparam in H, Harr.
case e1 : (tx s) => [x1 s1].
case e1' : (tx' s') => [x1' s1'].
have H1 := H _ _ Hss' => {Hss' H}.
rewrite e1 e1' in H1.
elim: H1 => [HQ HR].
rewrite /bindState /tbind /= e1 e1'.
by apply: Harr.
Defined.


Require Import List.
Require Import Omega.

Require Import Assembler.
Require Import MachineModel.
Require Import OperationalSemantics.
Require Import LabelledOperationalSemantics.
Require Import Labels.
Require Import MyTactics.

(*==============================================
   Theorems  on the labelled operational semantics
==============================================*)

Lemma labelled_semantics_implies_original :
  forall (s1 s2 : State) (l : Label),
    s1 ~~ l ~~> s2 ->
    s1 ---> s2.
Proof.
intros s1 s2 l H.
(* 5 cases for labels *)
inversion H.
apply eval_call with (r' := r') (r'' := r'') (m' := m') (m'' := m'') (rd := rd); auto.
apply eval_ret with (r' := r') (r'' := r'') (m' := m') (p' := p') ; auto.
apply eval_callback with (r' := r') (r'' := r'') (m' := m') (m'' := m'') (rd := rd); auto.
apply eval_retback with (r' := r') (r'' := r'') (m' := m') (p' := p'); auto.
apply eval_writeout with (rs := rs) (rd := rd); auto.
(* case of Tau of internal jumps*)
inversion H0;
  try (apply eval_int with (p' := S p) (r' := r') (f' := f'); subst; apply H0; fail);
  try(apply eval_int with (p' := p') (r' := r') (f' := f'); subst; apply H0; fail).
  subst. unfold not in H1. destruct H1; auto.
 (* Case of Tau of external jumps*)
inversion H0;
  try (apply eval_ext with (p' := S p) (r' := r') (f' := f'); subst; apply H0; fail);
  try(apply eval_ext with (p' := p') (r' := r') (f' := f'); subst; apply H0; fail).
  subst. unfold not in H1. destruct H1; auto.
(* case of Tick of internal jumps*)
inversion H0; try (contradiction_diff_inst_halt; fail).
  (*halt*)
  apply eval_int with (p' := 0) (r' := r') (f' := f'). subst; auto.
(* case of Tick of external jumps*)
inversion H0; try (contradiction_diff_inst_halt; fail).
  (*halt*)
  apply eval_ext with (p' := 0) (r' := r') (f' := f'); subst; auto.
Qed.

Lemma original_semantics_implies_labelled :
  forall s1 s2 : State,
    s1 ---> s2 ->
    exists l : Label, s1 ~~ l ~~> s2.
Proof.
intros.
inversion H. (* 5 labels *)
exists (x := Call r'' f p'). apply los_eval_call with (r' := r') (r'' := r'') (m' := m') (m'' := m'') (rd := rd); auto.
exists (x := Return r f p'). apply los_eval_ret with (r' := r'); auto.
exists (x := Callback r f p'). apply los_eval_callback with (r' := r') (r'' := r'') (m' := m')  (rd := rd); auto.
exists (x := Returnback r'' f p'). apply los_eval_retback with (r' := r'); auto.
exists (x := Write_out (r rd) (r rs)). apply los_eval_writeout; auto.
 (* cases of internal jumps *)
inversion H0; try(same_domain_step_correspond_semantic).
  (*halt*)
  exists (x := Tick). apply los_eval_int_halt with (p' := 0) (r' := r') (f' := f'). subst; apply H0. auto.
 (* cases of external jumps *)
inversion H0; try(same_domain_step_correspond_semantic).
   (*halt*)
   exists (x := Tick). apply los_eval_ext_halt with (p' := 0) (r' := r') (f' := f'). subst. apply H0. auto.
Qed.


(***************************************************************************
* Church-Rosser Property in Pure Lambda-Calculus - Infrastructure          *
* Arthur Charguéraud, March 2007, Coq v8.1                                 *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory Lambda_Definitions.

(* ********************************************************************** *)
(** ** Additional Definitions Used in the Proofs *)

(* ********************************************************************** *)
(** Computing free variables of a term *)

Fixpoint fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i    => {}
  | trm_fvar x    => {{x}}
  | trm_app t1 t2 => (fv t1) \u (fv t2)
  | trm_abs t1    => (fv t1)
  end.

(* ********************************************************************** *)
(** Abstracting a name out of a term *)

Fixpoint close_var_rec (k : nat) (z : var) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => if x == z then (trm_bvar k) else (trm_fvar x)
  | trm_app t1 t2 => trm_app (close_var_rec k z t1) (close_var_rec k z t2)
  | trm_abs t1    => trm_abs (close_var_rec (S k) z t1)
  end.

Definition close_var z t := close_var_rec 0 z t.

(* ********************************************************************** *)
(** Substitution for a name *)

Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => if x == z then u else (trm_fvar x)
  | trm_app t1 t2 => trm_app (subst z u t1) (subst z u t2)
  | trm_abs t1    => trm_abs (subst z u t1)
  end.

Notation "[ z ~> u ] t" := (subst z u t) (at level 68).

(* ********************************************************************** *)
(** Definition of parallel relation *)

Inductive para : relation :=
  | para_red : forall L t1 t1' t2 t2',
      (forall x, x \notin L -> para (t1 ^ x) (t1' ^ x) ) ->
      para t2 t2' ->
      para (trm_app (trm_abs t1) t2) (t1' ^^ t2')
  | para_var : forall x,
      para (trm_fvar x) (trm_fvar x)
  | para_app : forall t1 t1' t2 t2',
      para t1 t1' -> para t2 t2' ->
      para (trm_app t1 t2) (trm_app t1' t2')
  | para_abs : forall L t1 t1',
     (forall x, x \notin L -> para (t1 ^ x) (t1' ^ x) ) ->
     para (trm_abs t1) (trm_abs t1').

(* ********************************************************************** *)
(** Definition of the transitive closure of a relation *)

Inductive iter_ (R : relation) : relation :=
  | iter_trans : forall t2 t1 t3,
      iter_ R t1 t2 -> iter_ R t2 t3 -> iter_ R t1 t3
  | iter_step : forall t t',
      R t t' -> iter_ R t t'.

Notation "R 'iter'" := (iter_ R) (at level 69).

(* ********************************************************************** *)
(** Inclusion between relations (simulation or a relation by another) *)

Definition simulated (R1 R2 : relation) :=
  forall (t t' : trm), R1 t t' -> R2 t t'.

Infix "simulated_by" := simulated (at level 69).

(* ********************************************************************** *)
(** Properties of relations *)

Definition red_regular (R : relation) :=
  forall t t', R t t' -> term t /\ term t'.

Definition red_refl (R : relation) :=
  forall t, term t -> R t t.

Definition red_in (R : relation) :=
  forall t x u u', term t -> R u u' ->
  R ([x ~> u]t) ([x ~> u']t).

Definition red_all (R : relation) :=
  forall x t t', R t t' ->
  forall u u', R u u' ->
  R ([x~>u]t) ([x~>u']t').

Definition red_out (R : relation) :=
  forall x u t t', term u -> R t t' ->
  R ([x~>u]t) ([x~>u]t').

Definition red_rename (R : relation) :=
  forall x t t' y,
  x \notin (fv t) -> x \notin (fv t') ->
  R (t ^ x) (t' ^ x) ->
  R (t ^ y) (t' ^ y).

Definition red_through (R : relation) :=
  forall x t1 t2 u1 u2,
  x \notin (fv t1) -> x \notin (fv u1) ->
  R (t1 ^ x) (u1 ^ x) -> R t2 u2 ->
  R (t1 ^^ t2) (u1 ^^ u2).

(* ********************************************************************** *)
(** ** Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => {{ x }}) in
  let C := gather_vars_with (fun x : trm => fv x) in
  constr:(A \u B \u C).

Ltac pick_fresh X :=
  let L := gather_vars in (pick_fresh_gen L X).

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto*.

Hint Constructors term.

(* ********************************************************************** *)
(** ** Lemmas *)

(* ********************************************************************** *)
(** Properties of substitutions *)

(* begin hide *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term_core :forall e j v i u, i <> j ->
  {j ~> v}e = {i ~> u}({j ~> v}e) -> e = {i ~> u}e.
Proof.
  induction e; introv Neq Equ;
  simpl in *; inversion* Equ; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; f_equal*. unfolds open.
  pick_fresh x. apply* (@open_rec_term_core t1 0 (trm_fvar x)).
Qed.

(* end hide *)

(** Substitution for a fresh name is identity. *)

Lemma subst_fresh : forall x t u,
  x \notin fv t ->  [x ~> u] t = t.
Proof.
  intros. induction t; simpls; f_equal*.
  case_var*. notin_contradiction.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ ([x ~> u]t2).
Proof.
  intros. unfold open. generalize 0.
  induction t1; intros; simpl; f_equal*.
  case_nat*. case_var*. apply* open_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_open_var : forall x y u e, y <> x -> term u ->
  ([x ~> u]e) ^ y = [x ~> u] (e ^ y).
Proof.
  introv Neq Wu. rewrite* subst_open.
  simpl. case_var*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_intro : forall x t u,
  x \notin (fv t) -> term u ->
  t ^^ u = [x ~> u](t ^ x).
Proof.
  introv Fr Wu. rewrite* subst_open.
  rewrite* subst_fresh. simpl. case_var*.
Qed.

(** Tactic to permute subst and open var *)

Ltac cross :=
  rewrite subst_open_var; try cross.

Tactic Notation "cross" "*" :=
  cross; auto*.

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

(** Terms are stable by substitution *)

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simpl*.
  case_var*.
  apply_fresh term_abs as y. rewrite* subst_open_var.
Qed.

Lemma subst_body : forall z u t,
  body t -> term u -> body ([z ~> u]t).
  unfold body. introv [L H]. exists (L \u {{z}}).
  intros. rewrite~ subst_open_var. use subst_term.
Qed.

Hint Resolve subst_term subst_body.

(* ********************************************************************** *)
(** ** Terms are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> body t1.
Proof.
  intros. unfold body. inversion* H.
Qed.

Lemma body_to_term_abs : forall t1,
  body t1 -> term (trm_abs t1).
Proof.
  intros. inversion* H.
Qed.

Hint Resolve term_abs_to_body body_to_term_abs.

(** ** Opening a body with a term gives a term *)

Lemma open_term : forall t u,
  body t -> term u -> term (t ^^ u).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro y).
Qed.

Hint Resolve open_term.

(* ********************************************************************** *)
(** ** Additional results on primitive operations *)

(** Open_var with fresh names is an injective operation *)

Lemma open_var_inj : forall x t1 t2,
  x \notin (fv t1) -> x \notin (fv t2) ->
  (t1 ^ x = t2 ^ x) -> (t1 = t2).
Proof.
  intros x t1. unfold open. generalize 0.
  induction t1; intro k; destruct t2; simpl; intros; inversion H1;
  try solve [ f_equal*
  | do 2 try case_nat; inversions* H1; try notin_contradiction ].
Qed.

(* begin hide *)

(** Close var commutes with open with some freshness conditions,
  this is used in the proofs of [close_var_body] and [close_var_open] *)

Lemma close_var_rec_open : forall x y z t1 i j,
  i <> j -> y <> x -> y \notin (fv t1) ->
    {i ~> trm_fvar y} ({j ~> trm_fvar z} (close_var_rec j x t1) )
  = {j ~> trm_fvar z} (close_var_rec j x ({i ~> trm_fvar y}t1) ).
Proof.
  induction t1; simpl; intros; try solve [ f_equal* ].
  do 2 (case_nat; simpl); try solve [ case_var* | case_nat* ].
  case_var*. simpl. case_nat*.
Qed.

(* end hide *)

(** Close var is an operation returning a body of an abstraction *)

Lemma close_var_fresh : forall x t,
  x \notin fv (close_var x t).
Proof.
  introv. unfold close_var. generalize 0.
  induction t; intros k; simpls; notin_simpl; auto.
  case_var; simpl*.
Qed.

(** Close var is an operation returning a body of an abstraction *)

Lemma close_var_body : forall x t,
  term t -> body (close_var x t).
Proof.
  introv W. exists {{x}}. intros y Fr.
  unfold open, close_var. generalize 0. gen y.
  induction W; intros y Fr k; simpls.
  case_var; simpl*. case_nat*.
  auto*.
  apply_fresh* term_abs as z.
   unfolds open. rewrite* close_var_rec_open.
Qed.

(** Close var is the right inverse of open_var *)

Lemma close_var_open : forall x t,
  term t -> t = (close_var x t) ^ x.
Proof.
  introv W. unfold close_var, open. generalize 0.
  induction W; intros k; simpls; f_equal*.
  case_var*. simpl. case_nat*.
  let L := gather_vars in match goal with |- _ = ?t =>
    destruct (var_fresh (L \u fv t)) as [y Fr] end.
  apply* (@open_var_inj y).
  unfolds open. rewrite* close_var_rec_open.
Qed.

(** An abstract specification of close_var, which packages the
  result of the operation and all the properties about it. *)

Lemma close_var_spec : forall t x, term t ->
  exists u, t = u ^ x /\ body u /\ x \notin (fv u).
Proof.
  intros. exists (close_var x t). split3.
  apply* close_var_open.
  apply* close_var_body.
  apply* close_var_fresh.
Qed.

(* ********************************************************************** *)
(** Regularity: relations only hold on well-formed terms *)

Section TermRelations.

Hint Extern 1 (term (trm_abs ?t)) =>
  match goal with H: context [term (t ^ _) ] |- _ =>
   let y := fresh in let K := fresh in
   apply_fresh term_abs as y;
   inst_notin H y as K; destruct K; auto end.

Lemma red_regular_beta : red_regular beta.
Proof.
  introz. induction* H.
Qed.

Lemma red_regular_beta_star : red_regular (beta star).
Proof.
  introz. induction* H. apply* red_regular_beta.
Qed.

Lemma red_regular_para : red_regular para.
Proof.
  introz. induction* H.
Qed.

Lemma red_regular_para_iter : red_regular (para iter).
Proof.
  introz. induction* H. apply* red_regular_para.
Qed.

End TermRelations.

Hint Resolve red_regular_beta red_regular_beta_star red_regular_para red_regular_para_iter.

Hint Extern 1 (term ?t) => match goal with
  | H: beta t _ |- _ => apply (proj1 (red_regular_beta H))
  | H: beta _ t |- _ => apply (proj2 (red_regular_beta H))
  | H: para t _ |- _ => apply (proj1 (red_regular_para H))
  | H: para _ t |- _ => apply (proj2 (red_regular_para H))
  | H: (beta star) t _ |- _ => apply (proj1 (red_regular_beta_star H))
  | H: (beta star) _ t |- _ => apply (proj2 (red_regular_beta_star H))
  | H: (para iter) t _ |- _ => apply (proj1 (red_regular_para_iter))
  | H: (para iter) _ t |- _ => apply (proj2 (red_regular_para_iter))
  end.

(* A last helper to solve the case where we have to prove
   [body t] and that we only know that [t ^ x] is a term
   because it appears as an argument to some reduction R. *)

Hint Extern 1 (body ?t) =>
   match goal with H: context [?R (t ^ _) _ ] |- _ =>
     let y := fresh in apply term_abs_to_body;
     apply_fresh term_abs as y;
     inst_notin H y as K; clear H end.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.functors MathClasses.theory.categories.

Section natural_transformations_id_comp.
  Context
    `{Category A} `{Category B} `{!Functor (f: A → B) f'}
    `{!Functor (f: A → B) f'} `{!Functor (g: A → B) g'} `{!Functor (h: A → B) h'}
    `{!NaturalTransformation (m:f⇛g)} `{!NaturalTransformation (n:g⇛h)}.

  Global Instance id_transformation: NaturalTransformation (λ a, cat_id: f a ⟶ f a).
  Proof. intros ???. rewrite left_identity, right_identity; reflexivity. Qed.

  Global Instance compose_transformation: NaturalTransformation (λ a, n a ◎ m a).
  Proof.
    intros ???.
    rewrite <- associativity, natural, associativity, natural, associativity; reflexivity.
  Qed.
End natural_transformations_id_comp.

Record Object A `{Arrows A} `{∀ x y : A, Equiv (x ⟶ y)} `{!CatId A} `{!CatComp A}
     B `{Arrows B} `{∀ x y : B, Equiv (x ⟶ y)} `{!CatId B} `{!CatComp B} : Type := object
  { map_obj:> A → B
  ; Fmap_inst:> Fmap map_obj
  ; Functor_inst: Functor map_obj _ }.
Existing Instance Fmap_inst.
Existing Instance Functor_inst.

Arguments Object _ {Aarrows Aeq Aid Acomp} _ {Barrows Beq Bid Bcomp} : rename.
Arguments object {A Aarrows Aeq Aid Acomp B Barrows Beq Bid Bcomp} {Fmap Functor} _ : rename.
Arguments map_obj {A Aarrows Aeq Aid Acomp B Barrows Beq Bid Bcomp} _ _ : rename.

Record Arrow `{Arrows A} `{∀ x y : A, Equiv (x ⟶ y)} `{!CatId A} `{!CatComp A}
     `{Arrows B} `{∀ x y : B, Equiv (x ⟶ y)} `{!CatId B} `{!CatComp B} (F G : Object A B) : Type := arrow
  { eta:> map_obj F ⇛ map_obj G
  ; NaturalTransformation_inst: NaturalTransformation eta }.
Existing Instance NaturalTransformation_inst.

Arguments arrow {A Aarrows Aeq Aid Acomp B Barrows Beq Bid Bcomp F G} _ _ : rename.
Arguments eta {A Aarrows Aeq Aid Acomp B Barrows Beq Bid Bcomp F G} _ _ : rename.

Section contents.
  Context `{Category A} `{Category B}.

  Global Instance: Arrows (Object A B) := Arrow.

  Section arrow_setoid.
    Context (F G : Object A B).

    Global Program Instance e: Equiv (F ⟶ G) :=
      λ m n, ∀ x: A, m x = n x.

    Instance e_refl: Reflexive e.
    Proof. intro a; red; reflexivity. Qed.

    Instance e_sym: Symmetric e.
    Proof. intros m n Hmn a. red in Hmn. rewrite Hmn. reflexivity. Qed.

    Instance e_trans: Transitive e.
    Proof. intros m n o Hmn Hno a. red in Hmn, Hno. rewrite Hmn, Hno. reflexivity. Qed.

    Instance: Equivalence e := {}.
    Global Instance: Setoid (F ⟶ G) := {}.
  End arrow_setoid.

  Global Instance: CatId (Object A B) := λ _, arrow (λ _, cat_id) _.
  Global Instance: CatComp (Object A B) := λ _ _ _ m n, arrow (λ a, m a ◎ n a) _.

  Global Instance: ∀ x y z: Object A B,
    Proper ((=) ==> (=) ==> (=)) ((◎): (y ⟶ z) → (x ⟶ y) → (x ⟶ z)).
  Proof.
    intros ????? Hx ?? Hy a.
    simpl. rewrite (Hx a), (Hy a). reflexivity.
  Qed.

  Instance: ∀ x y: Object A B, LeftIdentity (comp x y y) cat_id.
  Proof. repeat intro. simpl. apply left_identity. Qed.

  Instance: ∀ x y: Object A B, RightIdentity (comp x x y) cat_id.
  Proof. repeat intro. simpl. apply right_identity. Qed.

  Instance: ArrowsAssociative (Object A B).
  Proof. repeat intro. simpl. apply associativity. Qed.

  Global Instance: Category (Object A B) := {}.
End contents.


Require Import Basics.
Require Import WildCat.Core.

(** ** Natural transformations *)

Definition Transformation {A B : Type} `{IsGraph B} (F : A -> B) (G : A -> B)
  := forall (a : A), F a $-> G a.

Notation "F $=> G" := (Transformation F G).

(** A 1-natural transformation is natural up to a 2-cell, so its domain must be a 1-category. *)
Class Is1Natural {A B : Type} `{IsGraph A} `{Is1Cat B}
      (F : A -> B) `{!Is0Functor F} (G : A -> B) `{!Is0Functor G}
      (alpha : F $=> G) :=
{
  isnat : forall a a' (f : a $-> a'),
     (alpha a') $o (fmap F f) $== (fmap G f) $o (alpha a);
}.

Arguments isnat {_ _ _ _ _ _ _ _ _} alpha {alnat _ _} f : rename.

(** The transposed natural square *)
Definition isnat_tr {A B : Type} `{IsGraph A} `{Is1Cat B}
      {F : A -> B} `{!Is0Functor F} {G : A -> B} `{!Is0Functor G}
      (alpha : F $=> G) `{!Is1Natural F G alpha}
      {a a' : A} (f : a $-> a')
  : (fmap G f) $o (alpha a) $== (alpha a') $o (fmap F f)
  := (isnat alpha f)^$.

Definition id_transformation {A B : Type} `{Is01Cat B} (F : A -> B)
  : F $=> F
  := fun a => Id (F a).

Global Instance is1natural_id {A B : Type} `{IsGraph A} `{Is1Cat B}
       (F : A -> B) `{!Is0Functor F}
  : Is1Natural F F (id_transformation F).
Proof.
  apply Build_Is1Natural; intros a b f; cbn.
  refine (cat_idl _ $@ (cat_idr _)^$).
Defined.

Definition comp_transformation {A B : Type} `{Is01Cat B}
           {F G K : A -> B} (gamma : G $=> K) (alpha : F $=> G)
  : F $=> K
  := fun a => gamma a $o alpha a.

Global Instance is1natural_comp {A B : Type} `{IsGraph A} `{Is1Cat B}
       {F G K : A -> B} `{!Is0Functor F} `{!Is0Functor G} `{!Is0Functor K}
       (gamma : G $=> K) `{!Is1Natural G K gamma}
       (alpha : F $=> G) `{!Is1Natural F G alpha}
  : Is1Natural F K (comp_transformation gamma alpha).
Proof.
  apply Build_Is1Natural; intros a b f; unfold comp_transformation; cbn.
  refine (cat_assoc _ _ _ $@ (_ $@L isnat alpha f) $@ _).
  refine (cat_assoc_opp _ _ _ $@ (isnat gamma f $@R _) $@ _).
  apply cat_assoc.
Defined.

(** Modifying a transformation to something pointwise equal preserves naturality. *)
Definition is1natural_homotopic {A B : Type} `{Is01Cat A} `{Is1Cat B}
      {F : A -> B} `{!Is0Functor F} {G : A -> B} `{!Is0Functor G}
      {alpha : F $=> G} (gamma : F $=> G) `{!Is1Natural F G gamma}
      (p : forall a, alpha a $== gamma a)
  : Is1Natural F G alpha.
Proof.
  constructor; intros a b f.
  exact ((p b $@R _) $@ isnat gamma f $@ (_ $@L (p a)^$)).
Defined.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import NAxioms NSub GenericMinMax.

(** * Properties of minimum and maximum specific to natural numbers *)

Module Type NMaxMinProp (Import N : NAxiomsMiniSig').
Include NSubProp N.

(** Zero *)

Lemma max_0_l : forall n, max 0 n == n.
Proof.
 intros. apply max_r. apply le_0_l.
Qed.

Lemma max_0_r : forall n, max n 0 == n.
Proof.
 intros. apply max_l. apply le_0_l.
Qed.

Lemma min_0_l : forall n, min 0 n == 0.
Proof.
 intros. apply min_l. apply le_0_l.
Qed.

Lemma min_0_r : forall n, min n 0 == 0.
Proof.
 intros. apply min_r. apply le_0_l.
Qed.

(** The following results are concrete instances of [max_monotone]
    and similar lemmas. *)

(** Succ *)

Lemma succ_max_distr : forall n m, S (max n m) == max (S n) (S m).
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono.
Qed.

Lemma succ_min_distr : forall n m, S (min n m) == min (S n) (S m).
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono.
Qed.

(** Add *)

Lemma add_max_distr_l : forall n m p, max (p + n) (p + m) == p + max n m.
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l.
Qed.

Lemma add_max_distr_r : forall n m p, max (n + p) (m + p) == max n m + p.
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r.
Qed.

Lemma add_min_distr_l : forall n m p, min (p + n) (p + m) == p + min n m.
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l.
Qed.

Lemma add_min_distr_r : forall n m p, min (n + p) (m + p) == min n m + p.
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r.
Qed.

(** Mul *)

Lemma mul_max_distr_l : forall n m p, max (p * n) (p * m) == p * max n m.
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_l.
Qed.

Lemma mul_max_distr_r : forall n m p, max (n * p) (m * p) == max n m * p.
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_r.
Qed.

Lemma mul_min_distr_l : forall n m p, min (p * n) (p * m) == p * min n m.
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_l.
Qed.

Lemma mul_min_distr_r : forall n m p, min (n * p) (m * p) == min n m * p.
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_r.
Qed.

(** Sub *)

Lemma sub_max_distr_l : forall n m p, max (p - n) (p - m) == p - min n m.
Proof.
 intros. destruct (le_ge_cases n m).
 rewrite min_l by trivial. apply max_l. now apply sub_le_mono_l.
 rewrite min_r by trivial. apply max_r. now apply sub_le_mono_l.
Qed.

Lemma sub_max_distr_r : forall n m p, max (n - p) (m - p) == max n m - p.
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r.
Qed.

Lemma sub_min_distr_l : forall n m p, min (p - n) (p - m) == p - max n m.
Proof.
 intros. destruct (le_ge_cases n m).
 rewrite max_r by trivial. apply min_r. now apply sub_le_mono_l.
 rewrite max_l by trivial. apply min_l. now apply sub_le_mono_l.
Qed.

Lemma sub_min_distr_r : forall n m p, min (n - p) (m - p) == min n m - p.
Proof.
 intros. destruct (le_ge_cases n m);
  [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r.
Qed.

End NMaxMinProp.


Require Export Structure.

Module Eq.

Structure obj {S T: Category} (F G: Functor S T) := Obj {
  sort: S;
  comm: F sort = G sort;
}.

Arguments sort {S T F G} _.
Arguments comm {S T F G} _.
Coercion sort: obj >-> Category.obj.

Lemma obj_eq {S T: Category} {F G: Functor S T} (x y: obj F G): x = y <-> sort x = y.
Proof.
  split.
  intros H.
  now subst y.
  destruct x as [x Hx], y as [y Hy]; simpl.
  intros H.
  subst y.
  f_equal; apply proof_irrelevance.
Qed.

Structure hom {S T: Category} {F G: Functor S T} (x y: obj F G) := {
  map: x ~> y;
  map_comm: eq_iso (comm y) ∘ fmap F map = fmap G map ∘ eq_iso (comm x);
}.

Arguments map {S T F G x y} _.
Arguments map_comm {S T F G x y} _.
Coercion map: hom >-> Categories.hom.

Lemma hom_eq {S T: Category} {F G: Functor S T} {x y: obj F G} (f g: hom x y): f = g <-> map f = g.
Proof.
  split.
  intros H.
  now subst g.
  destruct f as [f Hf], g as [g Hg]; simpl.
  intros H.
  subst g.
  f_equal; apply proof_irrelevance.
Qed.

Section category.
Context {S T: Category} (F G: Functor S T).

Program Definition cat_mixin: Category.mixin_of (obj F G) :=
  Category.Mixin (obj F G) hom
  (fun a => {| map := id a |})
  (fun a b c f g => {| map := f ∘ g |})
  _ _ _.
Next Obligation.
  rewrite !fmap_id, comp_id_l.
  apply comp_id_r.
Qed.
Next Obligation.
  rewrite !fmap_comp, <- comp_assoc, comp_assoc.
  rewrite map_comm, <- comp_assoc.
  f_equal.
  apply map_comm.
Qed.
Next Obligation.
  apply hom_eq; simpl.
  apply comp_assoc.
Qed.
Next Obligation.
  apply hom_eq; simpl.
  apply comp_id_l.
Qed.
Next Obligation.
  apply hom_eq; simpl.
  apply comp_id_r.
Qed.

Canonical cat: Category :=
  Category.Pack (obj F G) cat_mixin.

End category.

Lemma is_eq_map {S T: Category} {F G: Functor S T} {x y: obj F G} (f: hom x y): @is_eq (cat F G) x y f -> is_eq (map f).
Proof.
  intros [e H].
  subst f y.
  rewrite eq_iso_refl; simpl.
  apply is_eq_id.
Qed.

End Eq.

Canonical Eq.cat.
Notation Eq := Eq.cat.

Section CatEq.

Program Definition Ceqz {S T: Category} (F G: Functor S T): Functor (Eq F G) S := {|
  fobj := Eq.sort;
  fmap := @Eq.map S T F G;
|}.

Lemma Ceqz_comm {S T: Category} (F G: Functor S T): F ∘ Ceqz F G = G ∘ Ceqz F G.
Proof.
  fun_eq x y f.
  apply Eq.comm.
  assert (H = Eq.comm x) by apply proof_irrelevance.
  assert (H0 = Eq.comm y) by apply proof_irrelevance.
  subst H H0.
  apply Eq.map_comm.
Qed.

Program Definition EqzMed {E S T: Category} (F G: Functor S T) (e: Functor E S) (He: F ∘ e = G ∘ e): Functor E (Eq F G) := {|
  fobj x := {| Eq.sort := e x; Eq.comm := f_equal (fun F => fobj F x) He |};
  fmap x y f := {| Eq.map := fmap e f; |};
|}.
Next Obligation.
  transitivity (fmap (G ∘ e) f ∘ to (eq_iso He) x).
  transitivity (to (eq_iso He) y ∘ fmap (F ∘ e) f).
  2: apply (naturality (to (eq_iso He))).
  symmetry.
  all: f_equal.
  all: apply is_eq_unique.
  1, 3: apply transform_is_eq.
  all: apply eq_iso_is_eq.
Qed.
Next Obligation.
  apply Eq.hom_eq, fmap_id.
Qed.
Next Obligation.
  apply Eq.hom_eq, fmap_comp.
Qed.

Lemma EqzMed_comm {E S T: Category} (F G: Functor S T) (e: Functor E S) (He: F ∘ e = G ∘ e): Ceqz F G ∘ EqzMed F G e He = e.
Proof.
  now fun_eq x y f.
Qed.

Lemma EqzMed_unique {E S T: Category} (F G: Functor S T) (e: Functor E S) (u: Functor E (Eq F G)) (He: F ∘ e = G ∘ e): Ceqz F G ∘ u = e -> EqzMed F G e He = u.
Proof.
  intros H.
  subst e.
  fun_eq x y f.
  now apply Eq.obj_eq.
  apply Eq.hom_eq; simpl.
  transitivity (Eq.map (fmap u f)).
  2: symmetry.
  1: rewrite <- comp_id_l.
  2: rewrite <- comp_id_r.
  all: f_equal.
  all: apply is_eq_refl.
  apply (Eq.is_eq_map (to (eq_iso H0))), eq_iso_is_eq.
  apply (Eq.is_eq_map (to (eq_iso H))), eq_iso_is_eq.
Qed.

Definition CatEq_mixin: EqCategory.mixin_of Cat :=
  EqCategory.Mixin Cat (@Eq) (@Ceqz) (@Ceqz_comm) (@EqzMed) (@EqzMed_comm) (@EqzMed_unique).

Canonical CatEq: EqCategory :=
  EqCategory.Pack Cat CatEq_mixin.
End CatEq.


Require Import IA.
Require Import parser.

(*case 1:basic_fire.si*)
Definition CtrlU:IA := parse
"IA [s0,s1,s2] (s0) [fire] [FD] [] [s0->(fire)s1, s1->(FD)s2]".

Definition FireD1:IA := parse
"IA [s0,s1,s2] (s0) [smoke1] [fire] [] [s0->(smoke1)s1, s1->(fire)s2]".

Definition FireD2:IA :=parse
"IA [s0,s1,s2] (s0) [smoke2] [fire] [] [s0->(smoke2)s1, s1->(fire)s2]".

Eval compute in IAutomaton.b_compatible FireD1 CtrlU.
Eval compute in :> IAutomaton.IAProd FireD1 CtrlU.
Eval compute in :> IAutomaton.composition FireD1 CtrlU.

Eval compute in :> IAutomaton.IAProd (IAutomaton.IAProd FireD1 CtrlU) FireD2.

Definition c: IA := IAutomaton.composition CtrlU FireD1.

Eval compute in IAutomaton.b_compatible c FireD2.
Eval compute in :> IAutomaton.composition c FireD2.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_equ_sha_top_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_equ x1 L1 T1') ->
                  forall T2 x2 L2 ss2, T2 = (t_sha_top x2 L2 ss2) ->
                                  subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


(* Check if omission of "as" in return clause works w/ section variables too *)

Section sec.

Variable b: bool.

Definition d' :=
  (match b return b = true \/ b = false with
  | true => or_introl _ (refl_equal true)
  | false => or_intror _ (refl_equal false)
  end).


From mathcomp Require Import all_ssreflect.
From mathcomp Require Import perm ssralg poly ssrnum polydiv mxpoly ssrint rat.
From mathcomp Require Import polyorder finmap order.
From SsrMultinomials Require Import mpoly.
From Lindemann Require Import archi Rstruct Cstruct prelim.
From Lindemann Require Import Lind_part1 Lind_part2 Lind_part3.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Open Scope ring_scope.
Import GRing.Theory Num.Theory Archi.Theory Archi.Order.

Local Notation RtoC := Cstruct.RtoC.
Local Notation Cnat := Cstruct.Cnat.
Local Notation Cint := Cstruct.Cint.

Notation "x 'is_algebraic'" := (algebraicOver QtoC x)
  (at level 55).

Definition lin_indep_over (P : pred_class) {n : nat} (x : complexR ^ n) :=
  forall (lambda : complexR ^ n), lambda \in ffun_on P ->
    lambda != 0 -> \sum_(i < n) (lambda i * x i) != 0.

Definition alg_indep_over (P : pred_class) {n : nat} (x : complexR ^ n) :=
  forall (p : {mpoly complexR[n]}), p \is a mpolyOver _ P ->
    p != 0 -> p.@[x] != 0.

Local Notation setZroots := ((fset_roots Cint) :
    complexR -> qualifier 1 {fset complexR}).

(******************************************************************************)
(*                          Lindemann's theorems                              *)
(******************************************************************************)

Theorem LindemannBaker : forall (l : nat) (alpha : complexR ^ l) (a : complexR ^ l),
  (0%N < l)%N -> injective alpha -> (forall i : 'I_l, alpha i is_algebraic) ->
  (forall i : 'I_l, a i != 0) -> (forall i : 'I_l, a i is_algebraic) ->
  (Cexp_span a alpha != 0).
Proof.
apply: wlog1_Lindemann.
apply: wlog2_Lindemann.
by apply: Lindemann_last.
Qed.

Theorem LindemannWeierstrass n (alpha : complexR ^ n) :
  (n > 0)%N -> (forall i : 'I_n, alpha i is_algebraic) ->
  lin_indep_over Cint alpha -> alg_indep_over Cint (finfun (Cexp \o alpha)).
Proof.
move=> Hn alph_alg alph_lind P /mpolyOverP P_int P0.
pose t := finfun (tnth (in_tuple (msupp P))).
pose beeta :=  (finfun ((fun m : 'X_{1..n} => \sum_(i < n)
  (alpha i *+ m i)) \o t)).
pose a := (finfun ((fun m => P@_m) \o t)).
have -> : P.@[finfun (Cexp \o alpha)] = Cexp_span a beeta.
  rewrite /Cexp_span mevalE /beeta /a /t /= big_tnth.
  apply: eq_bigr => m _; rewrite !ffunE /=.
  congr (_ * _); first by rewrite ffunE.
  rewrite [RHS](big_morph Cexp Cexp_morph Cexp0).
  by apply: eq_bigr => i _; rewrite !ffunE /= CexpRX.
apply: LindemannBaker.
+ by rewrite lt0n size_eq0 msupp_eq0.
+ move=> i j; apply: contra_eq; rewrite /beeta !ffunE /= => i_neqj.
  rewrite -subr_eq0 -sumrB.
  pose lambda := finfun (fun i0 => (((t i) i0)%:R - ((t j) i0)%:R) : complexR).
  rewrite (eq_bigr (fun i0 => (lambda i0) * alpha i0)); last first.
    by move=> k _; rewrite /lambda !ffunE /= mulrBl !mulr_natl.
  apply: alph_lind.
  - by apply/ffun_onP => k; rewrite ffunE /= rpredB // Cint_Cnat // Cnat_nat.
  have := (nth_uniq 0%MM (ltn_ord i) (ltn_ord j) (msupp_uniq P)).
  rewrite [RHS](inj_eq (@ord_inj _)) => H_neq.
  move: i_neqj; rewrite -H_neq -[msupp P]/(tval (in_tuple _)) -!tnth_nth.
  have H_k k : tnth (in_tuple (msupp P)) k = t k by rewrite /t ffunE /=.
  apply: contra => /eqP Hlambda; rewrite !H_k => {H_k}.
  apply/eqP/mnmP => k.
  have /eqP : lambda k = 0 by rewrite Hlambda ffunE.
  by rewrite /lambda ffunE subr_eq0 eqr_nat => /eqP ->.
+ move=> i; rewrite /beeta !ffunE /=.
  apply: big_rec; first by apply: algebraic0.
  move=> j x _; apply: algebraic_add; rewrite -mulr_natr.
  apply: algebraic_mul; first by apply: alph_alg.
  by rewrite integral_algebraic; apply: integral_nat.
+ by move=> i; rewrite /a ffunE /= -mcoeff_msupp /t ffunE /= mem_tnth.
move=> i; rewrite /a ffunE /=.
have := (P_int (t i)); rewrite CintE => /orP [/CnatP[m ->] | /CnatP[m]].
  by rewrite integral_algebraic; apply: integral_nat.
rewrite -[X in algebraicOver _ X]opprK => Heq.
apply: algebraic_opp; rewrite Heq integral_algebraic.
by apply: integral_nat.
Qed.

(* Print Assumptions LindemannWeierstrass *)

Lemma ffun1_lin_indep_over (P : pred_class) (x : complexR) :
  x != 0 -> lin_indep_over P (finfun (fun (i : 'I_1) => x)).
Proof.
move=> x_neq0; rewrite /lin_indep_over => l /ffun_onP _ l_neq0.
rewrite big_ord_recl /= big_ord0 addr0 ffunE.
apply/mulf_neq0/x_neq0.
apply: (contra _ l_neq0) => /eqP n0_eq0.
apply/eqP/ffunP => i; rewrite zmodp.ord1 n0_eq0.
by rewrite [in RHS]/GRing.zero /= /ffun_zero ffunE.
Qed.

Lemma ffun1_alg_indep_over (x : complexR) :
   (x is_algebraic) -> ~ (alg_indep_over Cint (finfun (fun (i : 'I_1) => x))).
Proof.
rewrite /alg_indep_over => x_alg.
pose p := polyMin x_alg.
pose F := (fun (i : nat) => p`_i *: 'X_[U_(@ord0 0) *+ i]).
pose q := \sum_(i < size p) F i : {mpoly complexR[1]}.
have q_over : q \is a mpolyOver 1 Cint.
  apply/mpolyOverP => m; rewrite /q raddf_sum /= rpred_sum // => i _.
  rewrite mcoeffZ mcoeffX rpredM //; last by apply/Cint_Cnat/Cnat_nat.
  by have /polyOverP/(_ i) := (polyMin_over x_alg).
have q_neq0 : q != 0.
  suff H_in : (U_(@ord0 0) *+ (size p).-1)%MM \in (msupp q).
    by apply/negP => /eqP Hq; move: H_in; rewrite Hq msupp0 inE.
  rewrite /q -(big_mkord xpredT) (polySpred (polyMin_neq0 x_alg)).
  rewrite big_nat_recr //= (perm_eq_mem (msuppD _)) ?mem_cat.
    apply/orP; right; rewrite /F msuppMCX; first by rewrite inE.
    by rewrite -lead_coefE lead_coef_eq0 polyMin_neq0.
  move=> y /=; rewrite {2}/F msuppMCX; last first.
    by rewrite -lead_coefE lead_coef_eq0 polyMin_neq0.
  rewrite inE; case: eqP => [-> | ]; last by rewrite andbF.
  rewrite andbT; apply/negP; move/msupp_sum_le/flatten_mapP => [i].
  rewrite filter_predT mem_index_iota => /andP[i_gt0 i_lt].
  move/msuppZ_le; rewrite msuppX inE.
  move/eqP/mnmP/(_ (@ord0 0)); rewrite !mulmnE !mnmE /= !muln1 => H.
  by move: i_lt; rewrite H ltnn.
move/(_ q q_over q_neq0)/negP; apply; apply/eqP; rewrite /q raddf_sum /=.
have /rootP := (polyMin_root x_alg) => {2}<-; rewrite -/p horner_coef.
apply: eq_bigr => i _; rewrite /F mevalZ /meval mmapX /mmap1 /=.
by rewrite big_ord_recl /= big_ord0 mulr1 mulmnE mnmE /= muln1 ffunE /=.
Qed.

(******************************************************************************)
(*                          Hermite-Lindemann theorem                         *)
(******************************************************************************)

Theorem HermiteLindemann (x : complexR) :
  x != 0 -> x is_algebraic -> ~ ((Cexp x) is_algebraic).
Proof.
move=> x_neq0 x_alg; move/ffun1_alg_indep_over; apply.
have -> : (finfun (fun _ : 'I_1 => Cexp x)) =
          (finfun (Cexp \o (finfun (fun _ : 'I_1 => x)))).
  by apply/ffunP => i; rewrite !ffunE /= ffunE.
apply/LindemannWeierstrass.
+ by [].
+ by move=> i; rewrite ffunE.
by apply/ffun1_lin_indep_over/x_neq0.
Qed.

(* Print Assumptions HermiteLindemann *)

(******************************************************************************)
(*                          Transcendence of e                                *)
(******************************************************************************)

Theorem e_trans_by_LB :
  ~ (RtoC (Rtrigo_def.exp 1) is_algebraic).
Proof.
have -> : RtoC (Rtrigo_def.exp 1) = Cexp 1 by rewrite Cexp_exp ?real1.
move=> e_alg.
pose p := polyMin e_alg.
pose t := enum ((fun i => p`_i != 0) : pred 'I_(size p)).
pose alpha := (finfun (fun i => ((tnth (in_tuple t) i)%:R : complexR))).
pose a := (finfun (fun i => p`_(tnth (in_tuple t) i))).
have /eqP : Cexp_span a alpha = 0.
  move/rootP: (polyMin_root e_alg) => <-; rewrite -/p horner_coef.
  rewrite /Cexp_span /alpha /a -/p.
  pose f := (fun (i : 'I_(size p)) => p`_i * Cexp 1 ^+ i).
  rewrite [LHS](eq_bigr (fun i => (f \o (tnth (in_tuple t))) i)); first last.
    by move=> i _; rewrite /f !ffunE /= CexpRX.
  rewrite -(big_tnth _ _ _ xpredT) /f big_filter big_mkcond /=.
  by apply: eq_bigr => i _; case: ifP => [// | /negbFE/eqP ->]; rewrite mul0r.
have ord_p : ((size p).-1 < size p)%N.
  by rewrite -(polySpred (polyMin_neq0 e_alg)).
apply/negP/LindemannBaker.
+ have := (polyMin_neq0 e_alg); rewrite -/p -lead_coef_eq0 lead_coefE => H.
  rewrite size_filter -has_count.
  by apply/hasP; exists (Ordinal ord_p) => //=; rewrite mem_index_enum.
+ move=> i j /eqP; rewrite /alpha !ffunE eqr_nat.
  rewrite !(tnth_nth (Ordinal ord_p)) /= => /eqP /ord_inj /eqP.
  by rewrite nth_uniq // /t ?enum_uniq // => /eqP /ord_inj //.
+ move=> i; rewrite /alpha ffunE -ratr_nat.
  by apply: algebraic_id.
+ move=> i; rewrite /a ffunE.
  by have := (mem_tnth i (in_tuple t)); rewrite mem_filter => /andP[].
move=> i; rewrite /a ffunE.
have /polyOverP/(_ (tnth (in_tuple t) i)) := (polyMin_over e_alg); rewrite -/p.
move/CintP => [m ->]; rewrite -ratr_int.
by apply: algebraic_id.
Qed.

Theorem e_trans_by_LW :
  ~ (RtoC (Rtrigo_def.exp 1) is_algebraic).
Proof.
have -> : RtoC (Rtrigo_def.exp 1) = Cexp 1 by rewrite Cexp_exp ?real1.
move/ffun1_alg_indep_over; apply.
have -> : (finfun (fun _ : 'I_1 => Cexp 1)) =
          (finfun (Cexp \o (finfun (fun _ : 'I_1 => 1)))).
  by apply/ffunP => i; rewrite !ffunE /= ffunE.
apply/LindemannWeierstrass.
+ by [].
+ by move=> i; rewrite ffunE; apply/algebraic1.
by apply/ffun1_lin_indep_over/oner_neq0.
Qed.

Theorem e_trans_by_HL :
  ~ (RtoC (Rtrigo_def.exp 1) is_algebraic).
Proof.
have -> : RtoC (Rtrigo_def.exp 1) = Cexp 1 by rewrite Cexp_exp ?real1.
by apply/HermiteLindemann/algebraic1/oner_neq0.
Qed.

(******************************************************************************)
(*                          Transcendence of pi                               *)
(******************************************************************************)

Lemma eiPI_eqm1 : Cexp (RtoC Rtrigo1.PI * 'i) = -1.
Proof.
rewrite /Cexp; RtoC_simpl.
rewrite !mulr0 !mulr1 subr0 addr0 expR0 Rtrigo1.cos_PI Rtrigo1.sin_PI.
by rewrite /= mul1r mulr0 addr0 -!RtoCE.
Qed.

Theorem Pi_trans_by_LB : ~ (RtoC Rtrigo1.PI is_algebraic).
Proof.
suff : ~ (RtoC Rtrigo1.PI * 'i) is_algebraic.
  move=> iPi_nalg Pi_alg; apply: iPi_nalg.
  apply: algebraic_mul => //; exists ('X^2 + 1).
    by rewrite -size_poly_eq0 size_addl size_polyXn ?size_poly1.
  apply/rootP; rewrite rmorphD  hornerD rmorphX /= map_polyX map_polyC hornerC.
  by rewrite hornerXn /= rmorph1 sqrCi addNr.
move=> iPi_alg.
pose a := (finfun (fun (i : 'I_2) => (1 : complexR))).
pose alpha := (finfun (fun (i : 'I_2) => if (i == ord0) then
   RtoC Rtrigo1.PI * 'i else 0)).
have : Cexp_span a alpha == 0.
  rewrite /Cexp_span big_ord_recl /= big_ord_recl /= big_ord0 addr0 /=.
  by rewrite !ffunE /= !mul1r Cexp0 eiPI_eqm1 addNr.
have Hord2 (j : 'I_2) : (j == ord0) || (j == Ordinal (ltnSn 1)).
  case: j; case => [//= | ]; case => //=.
apply/negP/LindemannBaker => //.
+ move=> i j; apply: contra_eq; move/negbTE; rewrite /alpha !ffunE eq_sym.
  have PI_neq0 : RtoC Rtrigo1.PI * 'i != 0.
    apply/mulf_neq0/neq0Ci/negP; rewrite -RtoCE.
    by move/eqP; apply: Rtrigo1.PI_neq0.
  have /orP[/eqP -> -> //= | /eqP ] := (Hord2 i).
  have /orP[/eqP -> -> /= _ | /eqP -> -> //] := (Hord2 j).
  by rewrite eq_sym.
+ move=> i; have /orP[/eqP -> | /eqP ->] := (Hord2 i); rewrite ffunE /=.
    by apply: iPi_alg.
  by apply: algebraic0.
+ by move=> i; rewrite ffunE /= oner_neq0.
by move=> i; rewrite ffunE /=; apply: algebraic1.
Qed.

Theorem Pi_trans_by_LW : ~ (RtoC Rtrigo1.PI is_algebraic).
Proof.
suff : ~ (RtoC Rtrigo1.PI * 'i) is_algebraic.
  move=> iPi_nalg Pi_alg; apply: iPi_nalg.
  apply: algebraic_mul => //; exists ('X^2 + 1).
    by rewrite -size_poly_eq0 size_addl size_polyXn ?size_poly1.
  apply/rootP; rewrite rmorphD  hornerD rmorphX /= map_polyX map_polyC hornerC.
  by rewrite hornerXn /= rmorph1 sqrCi addNr.
move=> ipi_alg.
have /(@ffun1_lin_indep_over Cint) : RtoC Rtrigo1.PI * 'i != 0.
  apply/mulf_neq0/neq0Ci/negP; rewrite -RtoCE.
  by move/eqP; apply: Rtrigo1.PI_neq0.
move/(LindemannWeierstrass (ltnSn _) _).
set alpha := finfun _.
have Halg : (forall i : 'I_1, alpha i is_algebraic).
  by move=> i; rewrite /alpha ffunE; apply: ipi_alg.
move/(_ Halg).
have -> : (finfun (Cexp \o alpha)) =
          (finfun (fun _ : 'I_1 => Cexp (RtoC Rtrigo1.PI * 'i))).
  by apply/ffunP => i; rewrite /alpha !ffunE /= ffunE.
apply/ffun1_alg_indep_over; rewrite eiPI_eqm1.
by apply/algebraic_opp/algebraic1.
Qed.

Theorem Pi_trans_by_HL : ~ (RtoC Rtrigo1.PI is_algebraic).
Proof.
suff : ~ (RtoC Rtrigo1.PI * 'i) is_algebraic.
  move=> iPi_nalg Pi_alg; apply: iPi_nalg.
  apply: algebraic_mul => //; exists ('X^2 + 1).
    by rewrite -size_poly_eq0 size_addl size_polyXn ?size_poly1.
  apply/rootP; rewrite rmorphD  hornerD rmorphX /= map_polyX map_polyC hornerC.
  by rewrite hornerXn /= rmorph1 sqrCi addNr.
move/HermiteLindemann; apply.
+ apply/mulf_neq0/neq0Ci/negP; rewrite -RtoCE.
  by move/eqP; apply: Rtrigo1.PI_neq0.
by rewrite eiPI_eqm1; apply/algebraic_opp/algebraic1.
Qed.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Bishop.Exp.

Import BishopNotations.

Close Scope nat.

Definition sum_eqv (A B: Bishop) (x y: A + B) :=
  match (x, y) with
  | (inl x', inl y') => x' == y'
  | (inr x', inr y') => x' == y'
  | _ => False
  end.

Hint Unfold sum_eqv: bishop.

#[program]
Definition sum (A B: Bishop): Bishop := (A + B) /~ {| equiv := sum_eqv A B |}.

Next Obligation.
Proof.
  exists.
  all: admit.
Admitted.

#[program]
Definition fanin {C A B: Bishop} (f: exp A C) (g: exp B C): exp (sum A B) C := λ x,
                                                                          match x with
                                                                          | inl x' => f x'
                                                                          | inr x' => g x'
                                                                          end.

Next Obligation.
Proof.
  admit.
Admitted.

#[program]
Definition inl {A B: Bishop}: exp A (sum A B) := inl.

Next Obligation.
Proof.
  intros ? ? p.
  cbn.
  assumption.
Qed.

#[program]
Definition inr {A B: Bishop}: exp B (sum A B) := inr.

Next Obligation.
Proof.
  intros ? ? p.
  cbn.
  assumption.
Qed.

Module SumNotations.
  Infix "+" := sum : bishop_scope.
End SumNotations.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo40:
  prime  11190113358133->
  prime  2619426498556680433.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      2619426498556680433
      234084
      ((11190113358133,1)::nil)
      0
      192
      4
      16)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


(** Coq coding by choukh, Feb 2021 **)

Require Export ZFC.Axiom.ZFC0.

Declare Scope class_scope.
Open Scope class_scope.

(* 类 *)
Notation Class := (set → Prop).

(* 类成员 *)
Definition InClass := λ x (C : Class), C x.
Notation "x ⋵ C" := (InClass x C) (at level 70) : class_scope.
Global Hint Unfold InClass : core.

Notation "∀ x .. y ⋵ A , P" :=
  (∀ x, x ⋵ A → (.. (∀ y, y ⋵ A → P) ..))
  (at level 200, x binder, right associativity) : class_scope.

Notation "∃ x .. y ⋵ A , P" :=
  (∃ x, x ⋵ A ∧ (.. (∃ y, y ⋵ A ∧ P) ..))
  (at level 200, x binder, right associativity) : class_scope.

Notation "'∃' ! x .. y ⋵ A , P" :=
  (∃! x, x ⋵ A ∧ (.. (∃! y, y ⋵ A ∧ P) ..))
  (at level 200, x binder, right associativity,
   format "'[' '∃' ! '/ '  x .. y  ⋵  A ,  '/ ' P ']'") : class_scope.

(* 能成为集合的类 *)
Definition is_set := λ C, ∃ A, ∀ x, x ∈ A ↔ x ⋵ C.

(* 子类 *)
Notation "C ⫃ D" := (∀ x, x ⋵ C → x ⋵ D) (at level 70) : class_scope.

(* 类的子集 *)
Notation "A ⪽ C" := (∀ x, x ∈ A → x ⋵ C) (at level 70) : class_scope.

(* 类函数 *)
Notation "F :ᶜ D ⇒ R" := (∀x ⋵ D, F x ⋵ R) (at level 60) : class_scope.

(* 类单射 *)
Definition class_injective := λ (F : set → set) D,
  ∀ x y ⋵ D, F x = F y → x = y.
Definition class_injection := λ F D R,
  F :ᶜ D ⇒ R ∧ class_injective F D.
Notation "F :ᶜ D ⇔ R" := (class_injection F D R) (at level 60) : class_scope.

(* 类满射 *)
Definition class_surjective := λ F D R,
  ∀y ⋵ R, ∃x ⋵ D, F x = y.
Definition class_surjection := λ F D R,
  F :ᶜ D ⇒ R ∧ class_surjective F D R.
Notation "F :ᶜ D ⟹ R" := (class_surjection F D R) (at level 60) : class_scope.

(* 类双射 *)
Definition class_bijective := λ F D R,
  class_injective F D ∧ class_surjective F D R.
Definition class_bijection := λ F D R,
  F :ᶜ D ⇒ R ∧ class_bijective F D R.
Notation "F :ᶜ D ⟺ R" := (class_bijection F D R) (at level 60) : class_scope.


(* A theory of constructed functions and permutations, including random functions and random permutations. *)

Set Implicit Arguments.
Require Import Crypto.
Require Import Permutation.
Require Import CompFold.
Require Export Array.

Local Open Scope list_scope.
Local Open Scope array_scope.

Require Import State.

Definition oracleMap(D R S: Set)(eqds : EqDec S)(eqdr : EqDec R)(oracle : (S * D) -> Comp (S * R))(s : S)(ds : list D) :=
  compFold _ (fun acc d => [s, rs] <-2 acc; [s, r] <-$2 oracle (s, d); ret (s, rs ++ r :: nil)) (s, nil) ds.

Section RandomFunc.

  Variable D R : Set.
  Hypothesis D_EqDec : EqDec D.
  Hypothesis R_EqDec : EqDec R.

  Variable RndR : Comp R.
  Hypothesis RndR_wf : well_formed_comp RndR.

  (* A random function *)
  Definition randomFunc(p : (list (D * R)) * D) : Comp (list (D * R) * R) :=
    let (f, d) := p in
    match (arrayLookup _ f d) with
      | None => (r <-$ RndR; ret ((d, r) :: f, r))
      | Some r => ret (f, r)
    end.
  Lemma randomFunc_wf : forall p,
    well_formed_comp (randomFunc p).

    intuition.
    unfold randomFunc.
    case_eq (a#b); intuition; wftac.

  Qed.

  (* Eager random functions can be used to simplify many definitions. *)
  Fixpoint randomFunc_eager_arr(allD : list D) :=
    match allD with
        | nil => ret nil
        | d :: allD' =>
          arr' <-$ randomFunc_eager_arr allD';
            r <-$ RndR;
            ret ((d, r) :: arr')
    end.

  Hint Resolve randomFunc_wf : wftac.

  Theorem inSupportRandomFunc :
    forall a b r,
      a # b = None ->
      In r (getSupport RndR) ->
      In ((b, r) :: a, r) (getSupport (randomFunc (a, b))).

    intuition.
    unfold randomFunc.
    rewrite H.
    eapply getSupport_In_Seq.
    eauto.
    simpl.
    intuition.

  Qed.

  Section PRF.

    Variable eta : nat.
    Variable f : Bvector eta -> D -> R.
    Variable A : AdversaryWithOracle unit bool D R (list (D * R)).
    Variable q : nat.

    Definition f_oracle (k : Bvector eta)(p : (list (D * R)) * D) : Comp ((list (D * R)) * R) :=
      [s, d] <-2 p;
      ret (nil, f k d).

    Definition PRF_G0 :=
      k <-$ {0, 1} ^ eta;
      [b, _] <-$2 (A queries (f_oracle k)) q nil tt;
      ret b.

    Definition PRF_G1 :=
      [b, _] <-$2 (A queries randomFunc) q nil tt;
      ret b.

    Definition PRF_Advantage := | Pr[PRF_G0] - Pr[PRF_G1] |.

  End PRF.
  (* A PRF that is secure against a non-adaptive adversary. *)
  Section PRF_NA.

    Variable eta : nat.
    Variable f : Bvector eta -> D -> R.

    Section PRF_NA_Adversary.
      Variable A_state : Set.
      Variable A1 : Comp ((list D) * A_state ).
      Variable A2 : A_state -> list R -> Comp bool.
      Definition A := (A1, A2).

      Definition PRF_NA_G0 :=
        lsD <-& A;
        lsR <-$ (k <-$ {0, 1} ^ eta; ret (map (f k) lsD));
        A lsR.

      Definition PRF_NA_G1 :=
        lsD <-& A;
        [_, lsR] <-$2 oracleMap _ _ randomFunc nil lsD;
        A lsR.

      Definition PRF_NA_Advantage :=
      | Pr[PRF_NA_G0] - Pr[PRF_NA_G1] |.

    End PRF_NA_Adversary.

    Variable efficient : forall(x : Type), x -> Prop.

    Definition PRF_NA_Assumption epsilon :=
      forall A_state A1 A2,
        efficient A1 ->
        efficient A2 ->
        @PRF_NA_Advantage A_state A1 A2 <= epsilon.

  End PRF_NA.

  (* An iterated PRF security definition.  The adversary supplies several lists of PRF inputs.  The definition chooses a new random key for each list.  *)
  Section PRF_NAI.

    Variable eta : nat.
    Variable f : Bvector eta -> D -> R.
    Variable A_state : Set.
    Variable A1 : Comp ((list (list D)) * A_state ).
    Variable A2 : A_state -> list (list R) -> Comp bool.

    Definition PRF_NAI_G0 :=
      [lsDs, s_A] <-$2 A1;
      lsRs <-$ compMap _ (fun lsD => k <-$ {0, 1}^eta; ret (map (f k) lsD)) lsDs;
      A2 s_A lsRs.

    Definition PRF_NAI_G1 :=
      [lsDs, s_A] <-$2 A1;
      lsRs <-$ compMap _ (fun lsD => [_, lsR] <-$2 oracleMap _ _ randomFunc nil lsD; ret lsR) lsDs;
      A2 s_A lsRs.

    Definition PRF_NAI_Advantage :=
    | Pr[PRF_NAI_G0] - Pr[PRF_NAI_G1] |.

  End PRF_NAI.

End RandomFunc.

Section RandomPerm.

  Variable D R : Set.
  Hypothesis D_EqDec : EqDec D.
  Hypothesis R_EqDec : EqDec R.

  Variable RndR : Comp R.
  Hypothesis RndR_wf : well_formed_comp RndR.

  Fixpoint inRange(f : list (D * R))(r : R) :=
    match f with
      | nil => false
      | (d', r') :: f' =>
        if (eqb r r') then true
          else (inRange f' r)
    end.

  Definition getUnusedR(f : list (D * R)) :=
    Repeat (RndR) (fun r => negb (inRange f r)).

  Lemma getUnusedR_eq : forall ls1 ls2 x,
    (forall r, inRange ls1 r = inRange ls2 r) ->
    evalDist (getUnusedR ls1) x == evalDist (getUnusedR ls2) x.

    intuition.

    destruct (in_dec (EqDec_dec _) x (getSupport (getUnusedR ls1))).
    unfold getUnusedR in *.

    simpl in i.
    apply filter_In in i; intuition.
    eapply evalDist_Repeat_eq.
    intuition.
    rewrite H.
    trivial.
    eapply filter_In; intuition.
    eapply sumList_permutation.
    eapply NoDup_Permutation.
    eapply filter_NoDup.
    eapply getSupport_NoDup.
    eapply filter_NoDup.
    eapply getSupport_NoDup.
    intuition.
    apply filter_In in H2; intuition.
    eapply filter_In; intuition.
    rewrite <- H.
    trivial.
    apply filter_In in H2; intuition.
    eapply filter_In; intuition.
    rewrite H.
    trivial.

    unfold getUnusedR in *.
    simpl in n.
    apply filter_not_In in n.
    intuition.
    simpl.
    rewrite getSupport_not_In_evalDist_h; intuition.
    repeat rewrite ratMult_0_r.
    intuition.

    simpl.
    unfold indicator.
    rewrite <- H.
    rewrite H0.
    repeat rewrite ratMult_0_l.
    intuition.

  Qed.

  Lemma inRange_map : forall ls x,
    inRange ls x = true ->
    In x (map (@snd D R) ls).

    induction ls; intuition; simpl in *.
    discriminate.
    case_eq (eqb x b); intuition.
    rewrite eqb_leibniz in H0.
    subst.
    intuition.

    right.
    eapply IHls.
    rewrite H0 in H.
    trivial.
  Qed.

  Lemma getUnusedR_wf : forall ls r,
    inRange ls r = false ->
    In r (getSupport RndR) ->
    well_formed_comp (getUnusedR ls).

    intuition.
    unfold getUnusedR.
    eapply (well_formed_Repeat _ _ r).
    wftac.

    eapply filter_In.
    intuition.
    rewrite H.
    simpl.
    trivial.

    Grab Existential Variables.
    unfold eq_dec; intuition.
    eapply (EqDec_dec _).
  Qed.
  Hint Resolve getUnusedR_wf : wftac.

  (* A random permutation *)
  Definition randomPerm(p : (list (D * R) *  D)) : Comp (list (D * R) * R) :=
    let (f, d) := p in
    match (f#d) with
      | None => (r <-$ getUnusedR f ; ret ((d, r) :: f, r))
      | Some r => ret (f, r)
    end.

  Lemma randomPerm_wf : forall ls b0,
    (forall x, ls#x = None -> exists r, inRange ls r = false /\ In r (getSupport RndR)) ->
    well_formed_comp (randomPerm (ls, b0)).

    intuition.
    unfold randomPerm.
    case_eq (ls#b0); intuition; wftac.
    edestruct H; eauto.
    intuition.
    wftac.
  Qed.

  (* Many proofs involving random permutations will need to query the random permutation repeatedly.  In order to show that each call to the permutation is well-formed, we need to preserve the invariant that the state of the permutation is actually a permutation (as opposed to an arbitrary function).  The well_formed_perm is the predicate that we will use for this invariant. *)
  Definition well_formed_perm ls :=
    forall lsd,
      NoDup lsd ->
      (forall d, In d lsd -> ls#d = None) ->
      exists lsr,
        (forall r, In r lsr -> inRange ls r = false /\ In r (getSupport RndR)) /\
        NoDup lsr /\
        length lsd = length lsr.

  (*
  Lemma well_formed_perm_nil : well_formed_perm nil.

    intuition.
    unfold well_formed_perm.
    intuition.
    econstructor.
    intuition.
    eapply H1.
    eapply getSupport_NoDup.

    exists lsd.
    intuition.

  Qed.
*)

  Lemma well_formed_perm_1 : forall ls,
    well_formed_perm ls ->
    forall d,
    ls#d = None ->
    exists r, inRange ls r = false /\ In r (getSupport RndR).

    intuition.
    specialize (H (d :: nil)).
    edestruct H.
    econstructor.
    simpl. intuition.
    econstructor.
    intuition.
    simpl in *.
    intuition. subst.
    trivial.

    intuition.
    destruct x.
    simpl in *.
    omega.
    destruct x; simpl in *.
    econstructor.
    eapply H2.
    intuition.
    omega.
  Qed.
  Hint Resolve well_formed_perm_1 : wftac.

  Lemma removeFirst_length : forall (A : Set)(eqd : eq_dec A)(ls : list A) a,
    In a ls ->
    S (length (removeFirst eqd ls a)) = length ls.

    induction ls; intuition; simpl in *.
    intuition.
    subst.
    f_equal.
    destruct (eqd a0 a0).
    trivial.
    congruence.
    destruct (eqd a0 a); subst.
    trivial.
    simpl.
    f_equal.
    eauto.
  Qed.

  Lemma well_formed_perm_cons : forall ls d r,
    well_formed_perm ls ->
    ls#d = None ->
    inRange ls r = false ->
    well_formed_perm ((d, r) :: ls).

    unfold well_formed_perm in *.
    intuition.
    destruct (in_dec (EqDec_dec _) d lsd).
    specialize (H3 d).
    intuition.
    simpl in *.
    rewrite eqb_refl in H4.
    discriminate.

    edestruct (H (d :: lsd)).
    econstructor; trivial.
    intuition.
    simpl in *.
    intuition. subst.
    trivial.
    specialize (H3 d0).
    intuition.
    destruct (eqb d0 d).
    discriminate.
    trivial.

    intuition.
    (* now I have |lsd| + 1 unique elements that are not in the range *)
    (* but r may be in there *)
    destruct (in_dec (EqDec_dec _) r x).
    (* r is in the list, take it out and we get a list of the correct length *)
    exists (removeFirst (EqDec_dec _) x r).
    intuition.
    simpl.
    case_eq (eqb r0 r); intuition.
    rewrite eqb_leibniz in H8.
    subst.
    exfalso.
    eapply removeFirst_NoDup_not_in.
    eapply H4.
    eapply H6.
    eapply H5.
    eapply removeFirst_in_iff.
    eauto.
    eapply H5.
    eapply removeFirst_in_iff.
    eauto.

    eapply removeFirst_NoDup.
    trivial.

    simpl in H7.
    eapply eq_add_S.
    rewrite H7.
    symmetry.
    eapply removeFirst_length.
    trivial.

    (* r is not in the list, just use the tail of it *)
    destruct x.
    simpl in *. omega.
    exists x.
    intuition.
    simpl in *.
    intuition.
    case_eq (eqb r1 r); intuition.
    exfalso.
    rewrite eqb_leibniz in H10.
    subst.
    intuition.
    eapply H5.
    right.
    trivial.
    eapply H5.
    simpl.
    intuition.
    inversion H4; clear H4; subst.
    trivial.
  Qed.

  Lemma well_formed_perm_cons_2 : forall ls d r1 r2,
    well_formed_perm ls ->
    inRange ls r2 = true ->
    ls#d = None ->
    well_formed_perm ((d, r1) :: (d, r2) :: ls).

    intuition.
    unfold well_formed_perm.
    intuition.
    destruct (in_dec (EqDec_dec _) d lsd).
    specialize (H3 d).
    intuition.
    simpl in *.
    rewrite eqb_refl in H4.
    discriminate.
    edestruct (H (d :: lsd)).
    econstructor; trivial.
    intuition.
    simpl in H4.
    intuition. subst.
    trivial.

    specialize (H3 d0).
    intuition.
    simpl in *.
    destruct (eqb d0 d).
    discriminate.
    trivial.

    intuition.
    destruct (in_dec (EqDec_dec _) r1 x).
    exists (removeFirst (EqDec_dec _) x r1).
    intuition.
    simpl.
    case_eq (eqb r r1); intuition.
    rewrite eqb_leibniz in H8.
    subst.
    exfalso.
    eapply removeFirst_NoDup_not_in.
    eapply H4.
    eauto.
    case_eq (eqb r r2); intuition.
    rewrite eqb_leibniz in H9.
    subst.
    assert (inRange ls r2 = false).
    eapply H5.
    eapply removeFirst_in_iff.
    eauto.
    congruence.
    eapply H5.
    eapply removeFirst_in_iff.
    eauto.
    eapply H5.
    eapply removeFirst_in_iff.
    eauto.
    eauto using removeFirst_NoDup.
    eapply eq_add_S.
    simpl in H7.
    rewrite H7.
    symmetry.
    eapply removeFirst_length.
    trivial.

    destruct x.
    simpl in *.
    omega.
    exists x.
    intuition.
    simpl in *.
    case_eq (eqb r0 r1); intuition.
    rewrite eqb_leibniz in H8.
    subst.
    intuition.
    case_eq (eqb r0 r2); intuition.
    rewrite eqb_leibniz in H11.
    subst.
    assert (inRange ls r2 = false).
    eapply H5.
    intuition.
    congruence.
    eapply H5.
    intuition.
    eapply H5.
    simpl.
    intuition.
    inversion H4; clear H4; subst.
    trivial.
  Qed.

  Lemma getUnusedR_preserves_wf : forall ls d r,
    well_formed_perm ls ->
    ls#d = None ->
    In r (getSupport (getUnusedR ls)) ->
    well_formed_perm ((d, r) :: ls).

    intuition.
    unfold getUnusedR in *.
    simpl in H1.
    apply filter_In in H1.
    intuition.

    eapply well_formed_perm_cons; eauto.
    destruct (inRange ls r); simpl in *; congruence.

  Qed.

  Lemma getUnusedR_ret_preserves_wf : forall ls ls' d r,
    well_formed_perm ls ->
    ls#d = None ->
    In (ls', r) (getSupport (r <-$ getUnusedR ls; ret ((d, r) :: ls, r))) ->
    well_formed_perm ls'.

    intuition.
    apply getSupport_Bind_In in H1.
    destruct H1.
    intuition.
    simpl in H3.
    intuition.
    inversion H1; clear H1; subst.
    eapply getUnusedR_preserves_wf; eauto.

  Qed.

  Lemma randomPerm_preserves_wf : forall ls d ls' r,
    well_formed_perm ls ->
    In (ls', r) (getSupport (randomPerm (ls, d))) ->
    well_formed_perm ls'.

    intuition.
    unfold randomPerm in *.
    case_eq (ls#d); intuition.
    rewrite H1 in H0.
    simpl in *.
    intuition.
    inversion H2; clear H2; subst.
    trivial.

    rewrite H1 in H0.
    eapply getUnusedR_ret_preserves_wf; eauto.
  Qed.

  Lemma randomPerm_preserves_wf_pair : forall ls d p,
    well_formed_perm ls ->
    In p (getSupport (randomPerm (ls, d))) ->
    well_formed_perm (fst p).

    intuition.
    destruct p.
    eapply randomPerm_preserves_wf; eauto.

  Qed.

  Lemma getUnusedR_not_inRange : forall ls d r,
    ls#d = None ->
    In r (getSupport (getUnusedR ls)) ->
    inRange ls r = false.

    intuition.
    unfold getUnusedR in *.
    simpl in *.
    eapply filter_In in H0.
    intuition.
    destruct (inRange ls r); intuition.
  Qed.

  Lemma funcLookup_inRange_true : forall s d r,
    s#d = Some r ->
    inRange s r = true.

    induction s; intuition; simpl in *.
    discriminate.

    case_eq (eqb d a0); intuition;
    rewrite H0 in H.
    inversion H; clear H; subst.
    rewrite eqb_refl.
    trivial.

    case_eq (eqb r b); intuition.
    eauto.

  Qed.

  Lemma inRange_permutation : forall ls1 ls2 r,
    Permutation ls1 ls2 ->
    inRange ls1 r = inRange ls2 r.

    induction 1; intuition; simpl in *.
    rewrite IHPermutation.
    trivial.
    case_eq (eqb r b0); intuition.
    rewrite eqb_leibniz in H.
    subst.
    destruct (eqb b0 b); intuition.

    eauto.

  Qed.

  Lemma inRange_app_cons : forall ls d r x,
    inRange (ls ++ (d, r) :: nil) x = inRange ((d , r) :: ls) x.

    intuition.
    symmetry.
    eapply inRange_permutation.
    eapply Permutation_cons_append.
  Qed.

  Lemma inRange_app : forall ls ls' r,
    inRange ls r = true ->
    inRange (ls ++ ls') r = true.

    induction ls; intuition; simpl in *.
    case_eq (eqb r b); intuition.
    eapply IHls.
    rewrite H0 in H.
    trivial.
  Qed.

  Lemma notInArrayLookupNone :
    forall (A B : Set)(eqd : EqDec A)(arr : Array A B) a,
      (~ In a (fst (unzip arr))) ->
      (arr # a) = None.

    induction arr; intuition; simpl in *.

    case_eq (eqb a a0); intuition.
    rewrite eqb_leibniz in H0.
    subst.
    intuition.

  Qed.

  Ltac hypInv :=
      try (match goal with
          | [H: Some _ = Some _ |-_ ] => inversion H; clear H; subst
      end); try pairInv.

  Lemma arrayLookup_Some_In_unzip :
  forall (A B : Set)(eqd : EqDec A)(arr : Array A B) a b,
    (arr # a) = Some b ->
    In a (fst (unzip arr)).

  induction arr; intuition; simpl in *.
  discriminate.

  case_eq (eqb a a0); intuition;
  rewrite H0 in *.
  hypInv.
  rewrite eqb_leibniz in H0.
  subst.
  intuition.

  right.
  eapply IHarr.
  eauto.

Qed.

  (*
  Lemma funcLookup_app_some_eq : forall ls d (v : R),
    ls#d = None ->
    (ls ++ (d, v) :: nil)#d = Some v.

    intuition.
    eapply arrayLookup_app_some_eq.
    eauto.

  Qed.

  Lemma funcLookup_app_none : forall ls d d' (v' : R),
    ls#d = None ->
    (ls ++ (d, v') :: nil) # d' = (((d, v') :: ls)#d').

    intuition.
    eapply arrayLookup_app_none; eauto.

  Qed.

  Lemma funcLookup_app_ne : forall ls d (r : R) d',
    d <> d' ->
    (ls ++ (d, r) :: nil)#d' = (ls#d').

    intuition.
    eapply arrayLookup_app_ne; eauto.

  Qed.

  Lemma funcLookup_app_some : forall ls d d' (v v' : R),
    ls#d = Some v ->
    (ls ++ (d, v') :: nil)#d' = (ls#d').

    intuition.
    eapply arrayLookup_app_some.
    eauto.
  Qed.
*)

  Lemma inRange_in_dec : forall ls r,
    inRange ls r = if (in_dec (EqDec_dec _) r (map (@snd D R) ls)) then true else false.

    induction ls; intuition; simpl in *.
    destruct (EqDec_dec R_EqDec b r); subst.
    rewrite eqb_refl.
    trivial.
    case_eq (eqb r b); intuition.
    rewrite eqb_leibniz in H.
    subst.
    intuition.
    exfalso.
    intuition.
    specialize (IHls r).
    destruct (in_dec (EqDec_dec R_EqDec) r (map (snd (B:=R)) ls)).
    trivial.
    trivial.
  Qed.

  Theorem inSupportRandomPerm :
    forall a b r,
      In r (getSupport (getUnusedR a)) ->
      a # b = None ->
      In ((b, r) :: a, r) (getSupport (randomPerm (a, b))).

    intuition.
    unfold randomPerm.
    rewrite H0.
    eapply getSupport_In_Seq.
    eauto.
    simpl.
    intuition.

  Qed.

  (* Equivalence of functions and permutations. *)
  Definition funcs_eq s1 s2 :=
    (forall d, s1#d = (s2#d)) /\
    (forall r, inRange s1 r = inRange s2 r).

  Definition perms_eq s1 s2 :=
    well_formed_perm s1 /\
    well_formed_perm s2 /\
    funcs_eq s1 s2.

  (*
  Lemma perms_eq_nil : perms_eq nil nil.

    unfold perms_eq.
    intuition.
    eapply well_formed_perm_nil.
    eapply well_formed_perm_nil.
    unfold funcs_eq.
    intuition.
  Qed.
*)

  (* Eager random permutations can be used to simplify many definitions. *)
  Fixpoint randomPerm_eager_arr(allD : list D) :=
    match allD with
        | nil => ret nil
        | d :: allD' =>
          arr' <-$ randomPerm_eager_arr allD';
            r <-$ getUnusedR arr';
            ret ((d, r) :: arr')
    end.

End RandomPerm.


Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : list Y :=
  match l with
  | [] => []
  | h :: t => (f h) ++ (flat_map f t)
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof.
  simpl.
  reflexivity.
Qed.


Require Import StructTact.StructTactics.
Require Import FunctionalExtensionality.

Definition update {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) st h (v : B) :=
  fun nm => if A_eq_dec nm h then v else st nm.

Section update.
  Variables A B : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Lemma update_diff :
    forall (sigma : A -> B) x v y,
      x <> y ->
      update A_eq_dec sigma x v y = sigma y.
  Proof using.
    unfold update.
    intros.
    break_if; congruence.
  Qed.

  Lemma update_nop :
    forall (sigma : A -> B) x y,
      update A_eq_dec sigma x (sigma x) y = sigma y.
  Proof using.
    unfold update.
    intros. break_if; congruence.
  Qed.

  Lemma update_eq :
    forall (sigma : A -> B) x y v,
      x = y ->
      update A_eq_dec sigma x v y = v.
  Proof using.
    intros. subst.
    unfold update.
    break_if; congruence.
  Qed.

  Lemma update_same :
    forall (sigma : A -> B) x v,
      update A_eq_dec sigma x v x = v.
  Proof using.
    intros.
    rewrite update_eq; auto.
  Qed.

  Lemma update_nop_ext :
    forall (sigma : A -> B) h,
      update A_eq_dec sigma h (sigma h) = sigma.
  Proof using.
    intros.
    apply functional_extensionality.
    intros.
    apply update_nop.
  Qed.

  Lemma update_nop_ext' :
    forall (sigma : A -> B) y v,
      sigma y = v ->
      update A_eq_dec sigma y v = sigma.
  Proof using.
    intros.
    subst.
    apply update_nop_ext.
  Qed.

  Lemma update_overwrite :
    forall (sigma : A -> B) h st st',
      update A_eq_dec (update A_eq_dec sigma h st) h st' = update A_eq_dec sigma h st'.
  Proof using.
    intros.
    apply functional_extensionality.
    intros. destruct (A_eq_dec h x).
    - repeat rewrite update_eq; auto.
    - repeat rewrite update_diff; auto.
  Qed.
End update.

Lemma update_fun_comm :
  forall A B C A_eq_dec (f : B -> C) (st : A -> B) y v x,
    f (update A_eq_dec st y v x) = update A_eq_dec (fun x => f (st x)) y (f v) x.
Proof.
  intros.
  destruct (A_eq_dec x y); subst;
    repeat first [rewrite update_diff by congruence |
                  rewrite update_eq  by auto ]; auto.
Qed.

Ltac update_destruct_goal :=
  match goal with
    | [ |- context [ update ?eq_dec _ ?y _ ?x ] ] => destruct (eq_dec y x)
  end.

Ltac update_destruct_hyp :=
  match goal with
    | [ _ : context [ update ?eq_dec _ ?y _ ?x ] |- _ ] => destruct (eq_dec y x)
  end.

Ltac update_destruct := update_destruct_goal || update_destruct_hyp.

Ltac rewrite_update' H :=
  first [rewrite update_diff in H by congruence |
         rewrite update_eq in H by auto ].

Ltac rewrite_update :=
  repeat match goal with
           | [ H : context [ update _ _ _ _ _ ] |- _ ] =>
             rewrite_update' H; repeat rewrite_update' H
           | [ |- _ ] => repeat (try rewrite update_diff by congruence;
                                 try rewrite update_eq by auto)
         end.

Ltac destruct_update :=
  repeat (update_destruct; subst; rewrite_update).

Ltac destruct_update_hyp :=
  repeat ((update_destruct_hyp || update_destruct_goal); subst; rewrite_update).

Ltac update_destruct_simplify :=
  update_destruct; subst; rewrite_update; simpl in *.

Ltac update_destruct_simplify_hyp :=
  update_destruct_hyp || update_destruct_goal; subst; rewrite_update; simpl in *.

Ltac update_destruct_max_simplify :=
  update_destruct; subst_max; rewrite_update; simpl in *.


Require Import List.
Import ListNotations.

Require Import Relations Equality.
Require Import Relations.Relation_Operators.

Class WfTranslation (A : Type) : Type :=
{
  smaller : A -> A -> Prop;
  well_founded_smaller : well_founded smaller;
}.

Arguments smaller {A _} _ _.
Arguments well_founded_smaller {A _}.

#[export, refine] Instance WfTranslation_False : WfTranslation False :=
{
  smaller := fun _ _ => False;
}.
Proof.
  now intros [].
Defined.

#[export, refine] Instance WfTranslation_unit : WfTranslation unit :=
{
  smaller := fun _ _ => False;
}.
Proof.
  constructor.
  now intros _ [].
Defined.

Inductive smaller_prod
  {A B : Type} (RA : A -> A -> Prop) (RB : B -> B -> Prop) : A * B -> A * B -> Prop :=
| smaller_prod_l :
    forall (a1 a2 : A) (b : B), RA a1 a2 -> smaller_prod RA RB (a1, b) (a2, b)
| smaller_prod_r :
    forall (a : A) (b1 b2 : B), RB b1 b2 -> smaller_prod RA RB (a, b1) (a, b2).

#[export, refine] Instance WfTranslation_prod
  {A B : Type} {WA : WfTranslation A} {WB : WfTranslation B} : WfTranslation (A * B) :=
{
  smaller := smaller_prod smaller smaller;
}.
Proof.
  intros [a b].
  pose proof (Acc_a := well_founded_smaller a).
  revert b.
  induction Acc_a as [a Ha IHa].
  intros b.
  constructor.
  intros [a' b']; inversion 1; subst.
  - now apply IHa.
  - clear Ha H H1.
    pose proof (Acc_b := well_founded_smaller b').
    revert a IHa; induction Acc_b as [b' Hb IHb].
    constructor.
    intros [a'' b'']; inversion 1; subst.
    + now apply IHa.
    + now apply IHb.
Defined.

Inductive smaller_sum
  {A B : Type} (RA : A -> A -> Prop) (RB : B -> B -> Prop) : A + B -> A + B -> Prop :=
| smaller_sum_l :
    forall (a1 a2 : A), RA a1 a2 -> smaller_sum RA RB (inl a1) (inl a2)
| smaller_sum_r :
    forall (b1 b2 : B), RB b1 b2 -> smaller_sum RA RB (inr b1) (inr b2).

#[export, refine] Instance WfTranslation_sum
  {A B : Type} {WA : WfTranslation A} {WB : WfTranslation B} : WfTranslation (A + B) :=
{
  smaller := smaller_sum smaller smaller;
}.
Proof.
  intros [a | b].
  - pose proof (Acc_a := well_founded_smaller a).
    induction Acc_a as [a H IH].
    constructor.
    inversion 1; subst.
    now apply IH.
  - pose proof (Acc_b := well_founded_smaller b).
    induction Acc_b as [b H IH].
    constructor.
    inversion 1; subst.
    now apply IH.
Defined.

Inductive smaller_sigT
  {A : Type} {B : A -> Type}
  (RA : A -> A -> Prop) (RB : forall {a : A}, B a -> B a -> Prop)
  : sigT B -> sigT B -> Prop :=
| smaller_sigT_l :
    forall (a1 a2 : A) (b1 : B a1) (b2 : B a2),
      RA a1 a2 -> smaller_sigT RA (@RB) (existT _ a1 b1) (existT _ a2 b2)
| smaller_sigT_r :
    forall (a : A) (b1 b2 : B a),
      RB b1 b2 -> smaller_sigT RA (@RB) (existT _ a b1) (existT _ a b2).

#[export, refine] Instance WfTranslation_sigT
  {A : Type} {B : A -> Type}
  {WA : WfTranslation A} {WB : forall a : A, WfTranslation (B a)}
  : WfTranslation (sigT B) :=
{
  smaller := smaller_sigT smaller (fun a => @smaller _ (WB a));
}.
Proof.
  intros [a b].
  pose proof (Acc_a := well_founded_smaller a).
  revert b; induction Acc_a as [a Ha IHa]; intros b.
  constructor.
  intros [a' b']; inversion 1; subst.
  - now apply IHa.
  - clear Ha H H1.
    pose proof (Acc_b := well_founded_smaller b').
    revert IHa; induction Acc_b as [b' Hb IHb].
    constructor.
    intros [a'' b'']; inversion 1; subst.
    + now apply IHa.
    + apply IHb; only 3: easy.
Abort.

Module List.

Inductive DirectSubterm {A : Type} : list A -> list A -> Prop :=
| DS_tail : forall (h : A) (t : list A), DirectSubterm t (h :: t).

Inductive Subterm {A : Type} : list A -> list A -> Prop :=
| S_step  : forall {l1 l2 : list A}, DirectSubterm l1 l2 -> Subterm l1 l2
| S_trans : forall {l1 l2 l3 : list A}, DirectSubterm l1 l2 -> Subterm l2 l3 -> Subterm l1 l3.

Lemma wf_DirectSubterm :
  forall {A : Type},
    well_founded (@DirectSubterm A).
Proof.
  unfold well_founded.
  now induction a; constructor; inversion 1.
Qed.

Inductive DeepDirectSubterm {A : Type} (R : A -> A -> Prop) : list A -> list A -> Prop :=
| DDS_head : forall (h1 h2 : A) (t : list A), R h1 h2 -> DeepDirectSubterm R (h1 :: t) (h2 :: t)
| DDS_tail : forall (h : A) (t : list A), DeepDirectSubterm R t (h :: t).

Inductive DeepSubterm {A : Type} (R : A -> A -> Prop) : list A -> list A -> Prop :=
| DS_step  :
    forall {l1 l2 : list A},
      DeepDirectSubterm R l1 l2 -> DeepSubterm R l1 l2
| DS_trans :
    forall {l1 l2 l3 : list A},
      DeepDirectSubterm R l1 l2 -> DeepSubterm R l2 l3 -> DeepSubterm R l1 l3.

Lemma wf_DeepDirectSubterm :
  forall {A : Type} {R : A -> A -> Prop},
    well_founded R -> well_founded (DeepDirectSubterm R).
Proof.
  unfold well_founded.
  intros A R wf.
  induction a as [| h t]; constructor; [now inversion 1 |].
  intros t' HDS; inversion HDS; subst; clear HDS; [| easy].
  specialize (wf h1).
  clear H1.
  induction wf.
  constructor.
  intros t'' HDS; inversion HDS; subst; clear HDS; [| easy].
  now apply H0.
Qed.

Lemma DS_DDS :
  forall {A : Type} (l1 l2 : list A),
    DirectSubterm l1 l2 <-> DeepDirectSubterm (fun _ _ => False) l1 l2.
Proof.
  split.
  - now intros []; constructor.
  - now intros []; [| constructor].
Qed.

Lemma DDS_DS :
  forall {A : Type} (R : A -> A -> Prop) (l1 l2 : list A),
    DeepDirectSubterm R l1 l2
      <->
    DirectSubterm l1 l2
      \/
    exists (h1 h2 : A) (t : list A),
      (l1 = h1 :: t)%list /\
      (l2 = h2 :: t)%list /\
      R h1 h2.
Proof.
  split.
  - intros [].
    + now right; eauto 7.
    + now left.
  - intros [| (h1 & h2 & t & -> & -> & r)].
    + now inversion H; right.
    + now left.
Qed.

Inductive VeryDeepDirectSubterm {A : Type} (R : A -> A -> Prop) : list A -> list A -> Prop :=
| VDDS_head :
    forall {h1 h2 : A} (t : list A),
      R h1 h2 -> VeryDeepDirectSubterm R (h1 :: t) (h2 :: t)
| VDDS_tail :
    forall (h : A) {t1 t2 : list A},
      VeryDeepDirectSubterm R t1 t2 -> VeryDeepDirectSubterm R (h :: t1) (h :: t2).

Lemma wf_VeryDeepDirectSubterm :
  forall {A : Type} {R : A -> A -> Prop},
    well_founded R -> well_founded (VeryDeepDirectSubterm R).
Proof.
  unfold well_founded.
  intros A R wf.
  induction a as [| h t]; constructor; [now inversion 1 |].
  intros t' VDDS.
  remember (h :: t) as l.
  revert h t Heql IHt.
  induction VDDS as [h1 h2 t'' r | h' t1 t2 VDDS].
  - intros h t [= -> ->] HAcc.
    clear h r.
    specialize (wf h1).
    revert t HAcc; induction wf as [h1 H IH]; intros t HAcc.
    constructor.
    inversion 1; subst.
    + now apply IH.
    + clear IH. constructor. admit.
  - intros h t [= -> ->] HAcc.
Restart.
  unfold well_founded.
  intros A R wf [| h t]; constructor; [now inversion 1 |].
  intros t' VDDS.
  remember (h :: t) as l.
  revert h t Heql.
  induction VDDS as [h1 h2 t'' r | h' t1 t2 VDDS].
  - intros h t [= -> ->].
    clear h r.
    specialize (wf h1).
    revert t; induction wf as [h1 H IH]; intros t.
    constructor; inversion 1; subst.
    + now apply IH.
    + clear IH H0.
      induction H3.
      *
Abort.

End List.

Module BT.

Inductive BT (A : Type) : Type :=
| E : BT A
| N : A -> BT A -> BT A -> BT A.

Arguments E {A}.
Arguments N {A} _ _ _.

Inductive DeepDirectSubterm {A : Type} (R : A -> A -> Prop) : BT A -> BT A -> Prop :=
| DDS_v :
    forall {v1 v2 : A} (l r : BT A),
      R v1 v2 -> DeepDirectSubterm R (N v1 l r) (N v2 l r)
| DDS_l :
    forall (v : A) (l r : BT A),
      DeepDirectSubterm R l (N v l r)
| DDS_r :
    forall (v : A) (l r : BT A),
      DeepDirectSubterm R r (N v l r).

End BT.


(*! Utilities | Decidable equality typeclass !*)
Require Import Coq.Strings.String.
Require Import Coq.Vectors.Vector.

Class EqDec (T: Type) :=
  { eq_dec: forall t1 t2: T, { t1 = t2 } + { t1 <> t2 } }.

Definition beq_dec {A} {EQ: EqDec A} a1 a2 : bool :=
  if eq_dec a1 a2 then true else false.

Lemma beq_dec_iff {A} (EQ: EqDec A) a1 a2 :
  beq_dec a1 a2 = true <-> a1 = a2.
Proof.
  unfold beq_dec; destruct eq_dec; subst.
  - firstorder.
  - split; intro; (eauto || congruence).
Qed.

Lemma beq_dec_false_iff {A} (EQ: EqDec A) a1 a2 :
  beq_dec a1 a2 = false <-> a1 <> a2.
Proof.
  unfold beq_dec; destruct eq_dec; subst;
    intuition congruence.
Qed.

Hint Extern 1 (EqDec _) => econstructor; decide equality : typeclass_instances.
Hint Extern 1 ({ _ = _ } + { _ <> _ }) => apply eq_dec : typeclass_instances.

Instance EqDec_bool : EqDec bool := _.
Instance EqDec_ascii : EqDec Ascii.ascii := _.
Instance EqDec_string : EqDec string := _.
Instance EqDec_unit : EqDec unit := _.
Instance EqDec_nat : EqDec nat := {| eq_dec := PeanoNat.Nat.eq_dec |}.
Instance EqDec_pair A B `{EqDec A} `{EqDec B} : EqDec (A * B) := _.
Instance EqDec_option A `{EqDec A} : EqDec (option A) := _.
Instance EqDec_vector A (sz: nat) {EQ: EqDec A}: EqDec (Vector.t A sz).
Proof. econstructor; intros; eapply Vector.eq_dec; apply beq_dec_iff. Defined.
Instance EqDec_eq_true {A} (f: A -> bool) (a: A) : EqDec (f a = true).
Proof. constructor; left; apply Eqdep_dec.UIP_dec, eq_dec. Qed.

Import EqNotations.

Lemma eq_dec_rew_type_family {T} {EQ: EqDec T} (family: T -> Type):
  forall (t: T) (Heq: t = t) (a: family t),
    rew Heq in a = a.
Proof.
  intros. apply eq_sym, Eqdep_dec.eq_rect_eq_dec, eq_dec.
Qed.

Lemma eq_rect_eqdec_irrel {A} {EQ: EqDec A} (x: A) {P: A -> Type} {px: P x} {y: A}:
  forall (pr2 pr1: x = y),
    eq_rect x P px y pr1 =
    eq_rect x P px y pr2.
Proof.
  destruct pr1; cbn; intros.
  symmetry; apply eq_dec_rew_type_family.
Qed.

Lemma eq_dec_refl {A} {EQ: EqDec A}:
  forall a, eq_dec a a = left eq_refl.
Proof.
  intros.
  destruct eq_dec.
  - generalize e; apply Eqdep_dec.K_dec_type.
    + apply eq_dec.
    + reflexivity.
  - congruence.
Qed.

Lemma beq_dec_refl {A} {EQ: EqDec A}:
  forall a, beq_dec a a = true.
Proof.
  intros.
  unfold beq_dec.
  rewrite eq_dec_refl; reflexivity.
Qed.


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L Require Import UpToC.
From Undecidability.L Require Import Functions.EqBool.

From Undecidability.L.Datatypes Require Export List.List_enc.
Set Default Proof Using "Type".

Section list_in.
  Variable (X : Type).
  Variable (eqb : X -> X -> bool).
  Variable eqb_correct : forall a b,  a = b <-> eqb a b = true.

  Definition list_in_decb := fix rec (l : list X) (x : X) : bool :=
  match l with [] => false
          | (l :: ls) => eqb l x || rec ls x
  end.

  Lemma list_in_decb_iff (l : list X) : forall x, list_in_decb l x = true <-> x el l.
  Proof using eqb_correct.
    intros x. induction l.
    - cbn. firstorder.
    - split.
      + intros [H1 | H1]%orb_true_elim. left. now apply eqb_correct.
        apply IHl in H1. now right.
      + intros [H | H].
        cbn. apply orb_true_intro; left; now apply eqb_correct.
        cbn. apply orb_true_intro; right; now apply IHl.
  Qed.

  Lemma list_in_decb_iff' (l : list X) : forall x, list_in_decb l x = false <-> not (x el l).
  Proof using eqb_correct.
    intros x. split.
    - intros H H'. apply list_in_decb_iff in H'. congruence.
    - intros H'. destruct (list_in_decb l x) eqn:H.
      + now apply list_in_decb_iff in H.
      + reflexivity.
  Qed.

  Fixpoint list_incl_decb (a b : list X) :=
    match a with
    | [] => true
    | (x::a) => list_in_decb b x && list_incl_decb a b
    end.

  Lemma list_incl_decb_iff (a b : list X) : a <<= b <-> list_incl_decb a b = true.
  Proof using eqb_correct.
    induction a; cbn; [firstorder | ].
    split; intros.
    - rewrite andb_true_iff. split; [ | apply IHa; firstorder].
      apply list_in_decb_iff; firstorder.
    - apply andb_true_iff in H as (H1 & H2). intros x [-> | H3].
      + now apply list_in_decb_iff.
      + apply IHa in H2. apply H2, H3.
  Qed.

  Lemma list_incl_decb_iff' (a b : list X) : not (a <<= b) <-> list_incl_decb a b = false.
  Proof using eqb_correct.
    split.
    - intros H'. destruct (list_incl_decb a b) eqn:H.
      + now apply list_incl_decb_iff in H.
      + reflexivity.
    - intros H H'. apply list_incl_decb_iff in H'. congruence.
  Qed.
End list_in.

Section list_in_time.
  Variable (X : Type).
  Context {H : encodable X}.
  Context (eqbX : X -> X -> bool).
  Context {Xeq : eqbClass eqbX}.
  Context {XeqbComp : eqbCompT X}.

  Definition c__listInDecb := 21.
  Fixpoint list_in_decb_time (l : list X) (e : X) :=
    match l with
    | [] => c__listInDecb
    | x :: l => eqbTime (X := X) (size (enc x)) (size (enc e)) + c__listInDecb + list_in_decb_time l e
    end.
  Global Instance term_list_in_decb : computableTime' (@list_in_decb X eqbX) (fun l _ => (5, fun x _ => (list_in_decb_time l x, tt))).
  Proof.
    extract. solverec.
    all: unfold c__listInDecb; solverec.
  Qed.

  Definition c__list_incl_decb := 22.
  Fixpoint list_incl_decb_time (a b : list X) :=
    match a with
    | [] => c__list_incl_decb
    | (x::a) => list_in_decb_time b x + list_incl_decb_time a b + c__list_incl_decb
    end.

  Global Instance term_list_incl_decb : computableTime' (@list_incl_decb X eqbX)
    (fun a _ => (5, fun b _ => (list_incl_decb_time a b, tt))).
  Proof.
    extract. solverec. all: unfold c__list_incl_decb; solverec.
  Qed.
End list_in_time.

Section dupfree_dec.
  Variable (X : Type).
  Variable (eqbX : X -> X -> bool).
  Variable (eqbX_correct : forall a b, a = b <-> eqbX a b = true).

  Fixpoint dupfreeb (l : list X) : bool :=
    match l with [] => true
            | (x :: ls) => negb (list_in_decb eqbX ls x) && dupfreeb ls
  end.

  Lemma dupfreeb_correct (l : list X) : reflect (dupfree l) (dupfreeb l).
  Proof using eqbX_correct.
    destruct dupfreeb eqn:H; constructor.
    - induction l; constructor. all: cbn in H; apply andb_prop in H.
      all: cbn in H; destruct H. apply ssrbool.negbTE in H.
      now intros H1%(list_in_decb_iff eqbX_correct).
      now apply IHl.
    - intros H0. induction H0. cbn in H; congruence.
      apply IHdupfree. cbn in H; apply andb_false_elim in H. destruct H.
      apply ssrbool.negbFE in e. apply (list_in_decb_iff eqbX_correct) in e. tauto.
      assumption.
  Qed.

  Lemma dupfreeb_iff (l : list X) : dupfreeb l = true <-> dupfree l.
  Proof using eqbX_correct.
    specialize (dupfreeb_correct l) as H0.
    destruct dupfreeb. inv H0. split; eauto. inv H0; split; eauto.
  Qed.
End dupfree_dec.

Section dupfree_dec_time.
  Context {X : Type}.
  Context {H : encodable X}.
  Context (eqbX : X -> X -> bool).
  Context {Xeq : eqbClass eqbX}.
  Context {XeqbComp : eqbCompT X}.

  Definition c__dupfreeb := 25.
  Fixpoint dupfreeb_time (l : list X) :=
    match l with
    | [] => c__dupfreeb
    | l :: ls => list_in_decb_time ls l + c__dupfreeb + dupfreeb_time ls
    end.

  Global Instance term_dupfreeb: computableTime' (@dupfreeb X eqbX) (fun l _ => (dupfreeb_time l, tt)).
  Proof.
    extract.
    solverec. all: unfold c__dupfreeb; solverec.
  Qed.
End dupfree_dec_time.