From Coq Require Import Arith ZArith Psatz Bool String List Program.Equality.
Require Import Sequences IMP.
Import ListNotations.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope list_scope.

(** The target language: a stack machine *)

(** Instruction set *)
Inductive instr : Type :=
  | Iconst (n: Z)           (** push the integer [n] *)
  | Ivar (x: ident)         (** push the current value of variable [x] *)
  | Isetvar (x: ident)      (** pop an integer and assign it to variable [x] *)
  | Iadd                    (** pop two integers, push their sum *)
  | Iopp                    (** pop one integer, push its opposite *)
  | Ibranch (d: Z)          (** skip forward or backward [d] instructions *)
  | Ibeq (d1: Z) (d0: Z)    (** pop two integers, skip [d1] instructions if equal, [d0] if not equal *)
  | Ible (d1: Z) (d0: Z)    (** pop two integer, skip [d1] instructions if less or equal, [d0] if greater *)
  | Iinput                  (** read input and push it *)
  | Ioutput                 (** pop an integer and output it *)
  | Ihalt.                  (** stop execution *)

Definition code := list instr.

Definition codelen (c: code) : Z := Z.of_nat (List.length c).

(** Operational semantics *)

Definition stack : Type := list Z.

(** [instr_at C pc = Some i] if [i] is the instruction at position [pc] in [C]. *)
Fixpoint instr_at (C: code) (pc: Z) : option instr :=
  match C with
  | nil => None
  | i :: C' => if pc =? 0 then Some i else instr_at C' (pc - 1)
  end.

(** The compilation scheme *)

(** The code for an arithmetic expression [a] executes in sequence (no branches),
  and deposits the value of [a] at the top of the stack.
  This is the familiar translation to "reverse Polish notation".
  The only twist here is that the machine has no "subtract" instruction.
  However, it can compute the difference [a - b] by adding [a] and the opposite of [b].
*)

Fixpoint compile_aexp (a: aexp) : code :=
  match a with
  | CONST n => Iconst n :: nil
  | VAR x => Ivar x :: nil
  | PLUS a1 a2  => compile_aexp a1 ++ compile_aexp a2 ++ Iadd :: nil
  | MINUS a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Iopp :: Iadd :: nil
  end.

(** For Boolean expressions [b], we could produce code that deposits [1] or [0]
  at the top of the stack, depending on whether [b] is true or false.
  The compiled code for [IFTHENELSE] and [WHILE] commands would, then,
  compare this 0/1 value against 0 and branch to the appropriate piece of code.

  However, it is simpler and more efficient to compile a Boolean expression [b]
  to a piece of code that directly jumps [d1] or [d0] instructions forward,
  depending on whether [b] is true or false.  The actual value of [b] is
  never computed as an integer, and the stack is unchanged.
*)

Fixpoint compile_bexp (b: bexp) (d1: Z) (d0: Z) : code :=
  match b with
  | TRUE => if d1 =? 0 then nil else Ibranch d1 :: nil
  | FALSE => if d0 =? 0 then nil else Ibranch d0 :: nil
  | EQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Ibeq d1 d0 :: nil
  | LESSEQUAL a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Ible d1 d0 :: nil
  | NOT b1 => compile_bexp b1 d0 d1
  | AND b1 b2 =>
      let code2 := compile_bexp b2 d1 d0 in
      let code1 := compile_bexp b1 0 (codelen code2 + d0) in
      code1 ++ code2
  end.

(** See the slides for an explanation of the mysterious offsets in the [AND] case. *)

(** The code for a command [c]:
  - updates the store (the values of variables) as prescribed by [c]
  - preserves the stack
  - finishes "at the end" of the generated code: the next instruction
    executed is the instruction that will follow the generated code.
  Again, see the slides for explanations of the generated branch offsets.
*)

Fixpoint compile_com (c: com) : code :=
  match c with
  | SKIP =>
      nil
  | ASSIGN x a =>
      compile_aexp a ++ Isetvar x :: nil
  | SEQ c1 c2 =>
      compile_com c1 ++ compile_com c2
  | IFTHENELSE b ifso ifnot =>
      let code_ifso := compile_com ifso in
      let code_ifnot := compile_com ifnot in
      compile_bexp b 0 (codelen code_ifso + 1)
      ++ code_ifso
      ++ Ibranch (codelen code_ifnot)
      :: code_ifnot
  | WHILE b body =>
      let code_body := compile_com body in
      let code_test := compile_bexp b 0 (codelen code_body + 1) in
      code_test
      ++ code_body
      ++ Ibranch (- (codelen code_test + codelen code_body + 1)) :: nil
  | INPUT x =>
      Iinput :: Isetvar x :: nil
  | OUTPUT a =>
      compile_aexp a ++ Ioutput :: nil
  end.

(** The code for a program [p] (a command) is similar, but terminates
  cleanly on an [Ihalt] instruction. *)

Definition compile_program (p: com) : code :=
  compile_com p ++ Ihalt :: nil.

(** Defining the relation between IMP states and stack machine states. *)
Inductive code_at: code -> Z -> code -> Prop :=
  | code_at_intro: forall C1 C2 C3 pc,
      pc = codelen C1 ->
      code_at (C1 ++ C2 ++ C3) pc C2.

Inductive compile_cont (C: code): cont -> Z -> Prop :=
  | ccont_stop: forall pc,
      instr_at C pc = Some Ihalt ->
      compile_cont C Kstop pc
  | ccont_seq: forall c k pc pc',
      code_at C pc (compile_com c) ->
      pc' = pc + codelen (compile_com c) ->
      compile_cont C k pc' ->
      compile_cont C (Kseq c k) pc
  | ccont_while: forall b c k pc d pc' pc'',
      instr_at C pc = Some(Ibranch d) ->
      pc' = pc + 1 + d ->
      code_at C pc' (compile_com (WHILE b c)) ->
      pc'' = pc' + codelen (compile_com (WHILE b c)) ->
      compile_cont C k pc'' ->
      compile_cont C (Kwhile b c k) pc
  | ccont_branch: forall d k pc pc',
      instr_at C pc = Some(Ibranch d) ->
      pc' = pc + 1 + d ->
      compile_cont C k pc' ->
      compile_cont C k pc.

Lemma codelen_cons:
  forall i c, codelen (i :: c) = codelen c + 1.
Proof.
  unfold codelen; intros; cbn; lia.
Qed.

Lemma codelen_app:
  forall c1 c2, codelen (c1 ++ c2) = codelen c1 + codelen c2.
Proof.
  induction c1; intros.
- auto.
- cbn [app]. rewrite ! codelen_cons. rewrite IHc1. lia.
Qed.

Lemma instr_at_app:
  forall i c2 c1 pc,
  pc = codelen c1 ->
  instr_at (c1 ++ i :: c2) pc = Some i.
Proof.
  induction c1; simpl; intros; subst pc.
- auto.
- assert (A: codelen (a :: c1) =? 0 = false).
  { apply Z.eqb_neq. unfold codelen. cbn [length]. lia. }
  rewrite A. rewrite codelen_cons. apply IHc1. lia.
Qed.

Lemma code_at_head:
  forall C pc i C',
  code_at C pc (i :: C') ->
  instr_at C pc = Some i.
Proof.
  intros. inversion H. simpl. apply instr_at_app. auto.
Qed.

Lemma code_at_tail:
  forall C pc i C',
  code_at C pc (i :: C') ->
  code_at C (pc + 1) C'.
Proof.
  intros. inversion H.
  change (C1 ++ (i :: C') ++ C3)
    with (C1 ++ (i :: nil) ++ C' ++ C3).
  rewrite <- app_ass. constructor. rewrite codelen_app. subst pc. auto.
Qed.

Lemma code_at_app_left:
  forall C pc C1 C2,
  code_at C pc (C1 ++ C2) ->
  code_at C pc C1.
Proof.
  intros. inversion H. rewrite app_ass. constructor. auto.
Qed.

Lemma code_at_app_right:
  forall C pc C1 C2,
  code_at C pc (C1 ++ C2) ->
  code_at C (pc + codelen C1) C2.
Proof.
  intros. inversion H. rewrite app_ass. rewrite <- app_ass. constructor. rewrite codelen_app. subst pc. auto.
Qed.

Lemma code_at_app_right2:
  forall C pc C1 C2 C3,
  code_at C pc (C1 ++ C2 ++ C3) ->
  code_at C (pc + codelen C1) C2.
Proof.
  intros. apply code_at_app_right. apply code_at_app_left with (C2 := C3). rewrite app_ass; auto.
Qed.

Lemma code_at_nil:
  forall C pc C1,
  code_at C pc C1 -> code_at C pc nil.
Proof.
  intros. inversion H. subst. change (C1 ++ C3) with (nil ++ C1 ++ C3).
  constructor. auto.
Qed.

Lemma instr_at_code_at_nil:
  forall C pc i, instr_at C pc = Some i -> code_at C pc nil.
Proof.
  induction C; cbn; intros.
- discriminate.
- destruct (pc =? 0) eqn:PC.
+ assert (pc = 0) by (apply Z.eqb_eq; auto). subst pc.
  change (a :: C) with (nil ++ nil ++ (a :: C)). constructor. auto.
+ assert (A: code_at C (pc - 1) nil) by eauto.
  inversion A; subst.
  apply code_at_intro with (C1 := a :: C1) (C3 := C3). rewrite codelen_cons. lia.
Qed.

Global Hint Resolve code_at_head code_at_tail code_at_app_left code_at_app_right
      code_at_app_right2 code_at_nil instr_at_code_at_nil: code.
Hint Rewrite codelen_app codelen_cons Z.add_assoc Z.add_0_r : code.


(** * Proof by reflection **)

(** The idea of proof by reflection is to prove a class of theorems using
certified decision procedures, that is, Coq functions that have a theorem
showing their correctness. *)

(** ** Overview **)

(** Reflection applies to small, self-contained cases of using decision
procedures. However, in practice, the most common way to use reflection is both
more involved and follows a common structure:
- 1. Write down the syntax of the expressions you want to prove something about,
  say in an inductive type [term].
- 2. Interpret the terms back into what they represent, say [denote : term -> A].
  The type [A] might be a different expression or directly a [Prop].
- 3. Implement some procedure over terms; maybe [simplifier: term -> term] or
  [check: term -> bool].
- 4. Prove a soundness property of this procedure over what the terms denote,
  maybe [forall t, equivalent t (simplifier t)] or [forall t, check t = true -> denote t].
- 5. Reify the target language [A] into [term]. Typically this is implemented in
  Ltac since we need to turn calls like [add x y] into a constructor, which can't
  be implemented in Gallina.

This step is occasionally called "reflection", though "reification" is a clearer
term since "relection" can refer to the whole approach or just the use of a
certified decision procedure.

Now, given a goal that uses the target language (here values of type [A]), the
user can use reification to produce a term [t], then apply the soundness
property to get some proof about [denote t], which after simplification will be
a proof about some [a:A] that appears in the goal. *)

(** ** A motivating example **)

(** The best way to understand proof by reflection is to look at an example.
We'll use reflection to normalize an addition expression. *)

Require Import Coq.Arith.PeanoNat.

Inductive term :=
| Const (n:nat)
| Add (e1 e2:term).

Fixpoint denote (t:term) : nat :=
  match t with
  | Const n => n
  | Add e1 e2 => denote e1 + denote e2
  end.

Fixpoint flatten (x0:term) (t:term) : term :=
  match t with
  | Const n => Add x0 (Const n)
  | Add e1 e2 => flatten (flatten x0 e1) e2
  end.

Eval cbn [denote flatten] in
    fun x y z w => denote (flatten (Const 0)
                                (Add (Add (Const x) (Const y))
                                     (Add (Const z) (Const w)))).

(* the property we'll prove is that flattening does not change the denotation of
a term; to do so we need to first prove a more general property to get the
induction to go through *)

Theorem flatten_sound_general t : forall x,
  denote (flatten x t) = denote x + denote t.
Proof.
  induction t; simpl; intros; auto.
  rewrite IHt2, IHt1.
  rewrite Nat.add_assoc; auto.
Qed.

Theorem flatten_sound t :
  denote t = denote (flatten (Const 0) t).
Proof.
  rewrite flatten_sound_general; simpl; auto.
Qed.

Ltac reify e :=
  match e with
  | ?x + ?y =>
    let r_x := reify x in
    let r_y := reify y in
    constr:(Add r_x r_y)
  | _ => constr:(Const e)
  end.

Theorem demo x y z :
  x + (y + z) = x + y + z.
Proof.
  match goal with
  | |- ?e = ?e' => let t := reify e in
                 let t' := reify e' in
                 change (denote t = denote t')
  end.
  match goal with
  | |- denote ?t = denote ?t' =>
    rewrite (flatten_sound t), (flatten_sound t')
  end.
  (* this is where the magic becomes apparent: the soundness theorem applies to
  any term, but flatten computes to a particular expression when applied to
  these concrete terms *)
  cbn [denote flatten].
  reflexivity.
Qed.

(* we can wrap up the process of simplifying expressions in a tactic *)
Ltac canonical_assoc e :=
  let t := reify e in
  change e with (denote t);
  rewrite (flatten_sound t);
  cbn [denote flatten].

Theorem larger_demo x y z w :
  x + (y + z + w) + x + (y + z) =
  x + (y + z) + (w + (x + y)) + z.
Proof.
  match goal with
  | |- ?e = ?e' => canonical_assoc e;
                   canonical_assoc e'
  end.
  reflexivity.
Qed.

(** ** Why use reflection? **)

(** Reflection offers a number of benefits.

I think the most important aspect of reflection is robustness. A reflective
tactic defines an explicit syntax for the goals it handles and then implements
the rest of the work in a certified decision procedure. Now instead of reasoning
about what some Ltac procedure might do, you can just focus on what the
soundness theorem says. In some cases the certified procedure is partial (that
is, it might fail and not prove anything); in these cases you might also want to
check to see where it fails.

*)

(** ** A more abstract introduction **)

(** Computational reflection is a technique for proving theorems using
computation in the meta-language (that is, computation in Coq), as opposed to
building a proof term using only logical rules (eg, constructors in an inductive
type).

It relies on the conversion rule of dependent theory:

<<
x : A    A ≡ B
------------- conv
    x : B
>>

The judgement A ≡ B is where the magic happens: in dependent type theory, this
equivalence allows _computation_, and so this rule is what allows type-checking
to simplify computations appearing in types. *)

(** For example, we can write the following in Coq: *)
Definition bool_or_nat : bool :=
  (fun x => match x return (if x then bool else nat) with
         | true => x
         | false => 0
         end) true.

(** the type of the right-hand side is [if true then bool else nat], but Coq
simplifies this expression and can also give it the type bool *)

(** Recall that Coq propositions are types and the proof of a proposition P is a
term (pf:P) (this is the Curry-Howard isomorphism). In that light, we can use
the conv rule with theorem statements that are computed. This is what proof by
reflection is.

 I believe the "reflection" is reflection of the desired proof into the
 computation, but I must confess I'm not sure what the original intention is and
 it's possible the writing on proof by reflection has gotten confused over time.
 *)


Require Export ssreflect ssrfun.
Require Import Logic.ProofIrrelevance Logic.FunctionalExtensionality Logic.PropExtensionality.

Export EqNotations.

Set Bullet Behavior "Strict Subproofs".
Set Primitive Projections.
Set Universe Polymorphism.

Notation prfE := proof_irrelevance.
Notation funE := (functional_extensionality _ _).
Notation dfunE := functional_extensionality_dep.
Notation propE := propositional_extensionality.

Lemma unfunE {A B : Type} (f g : A -> B) : f = g -> forall x, f x = g x.
Proof. by move=> ->. Qed.

Global Hint Resolve prfE : core.

Ltac build := unshelve esplit=>//=.

Scheme eq_ind := Induction for eq Sort Type.
Arguments eq_ind [A] x P f y e.

Record sig (A : Type) (B : A -> Type) : Type :=
  Sig {pi1 : A; pi2 : B pi1}.

Arguments Sig [A] [B] pi1 pi2.
Arguments pi1 {A B} _ /.
Arguments pi2 {A B} _ /.

Definition sub (A : Type) (P : A -> Prop) : Type :=
  sig A P.

Set Warnings "-notation-overridden".
Notation "{ x : A & B }" := (sig A (fun x:A => B)) : type_scope.
Notation "{ x : A | B }" := (sub A (fun x:A => (B : Prop))) : type_scope.
Notation "( x , y , .. , z )" := (Sig .. (Sig x y) .. z) : core_scope.
Set Warnings "default".

Definition prod (A B : Type) := {_:A & B}.
Infix "×" := prod (at level 60).

Definition pair {A B} (a : A) (b : B) : A × B :=
  Sig a b.

Lemma sigE {A} {B : A -> Type} : forall (p q : {x : A & B x}) (u : pi1 p = pi1 q) (v : rew u in pi2 p = pi2 q), p = q.
Proof.
  move=> [a +] [x +] //= h; move: x h.
  by apply: eq_ind=> b1 b2//= ->.
Qed.

Lemma subE {A} {P : A -> Prop} : forall (p q : {x : A | P x}), pi1 p = pi1 q -> p = q.
Proof. by move=>???; apply: sigE. Qed.

Lemma prodE {A B} : forall (p q : A × B), pi1 p = pi1 q -> pi2 p = pi2 q -> p = q.
Proof.
  move=> [a1 +] [a2 +] //= h; move: a2 h.
  by apply: eq_ind=> b1 b2 ->.
Qed.

Record iso (A B : Type) :=
  {fwd : A -> B;
   bwd : B -> A;
   fwd_bwd : forall x, fwd (bwd x) = x;
   bwd_fwd : forall x, bwd (fwd x) = x}.

Arguments fwd [_] [_] _.
Arguments bwd [_] [_] _.
Arguments bwd_fwd [_] [_] _.
Arguments fwd_bwd [_] [_] _.

Infix "≅" := iso (at level 100).

Lemma push_iso {A B C} (α : A ≅ B) : (forall x : A, C (fwd α x)) -> forall x : B, C x.
Proof.
  move=> H x.
  by rewrite -[x](fwd_bwd α).
Defined.

Definition iso_fun {A A' B B'} (α : A ≅ A') (β : B ≅ B') : (A -> B) ≅ (A' -> B').
Proof.
  unshelve esplit.
  - by move=> f x; apply/(fwd β)/f/(bwd α)/x.
  - by move=> f x; apply/(bwd β)/f/(fwd α)/x.
  - abstract (by move=> f; apply: funE => ?; rewrite ? fwd_bwd).
  - abstract (by move=> f; apply: funE => ?; rewrite ? bwd_fwd).
Defined.

Definition iso_trans {A B C} (α : A ≅ B) (β : B ≅ C) : A ≅ C.
Proof.
  build.
  - move=> x; apply/(fwd β)/(fwd α)/x.
  - move=> x; apply/(bwd α)/(bwd β)/x.
  - abstract (by move=> f /=; rewrite ? fwd_bwd).
  - abstract (by move=> f /=; rewrite ? bwd_fwd).
Defined.

Definition iso_id {A} : A ≅ A.
Proof. build; by []. Defined.

Class Connective (A A' : Type) :=
  {conn_def : A' ≅ A}.

#[export] Hint Mode Connective + - : core.

Section Rules.
  Context {A A'} `{Connective A A'}.
  Definition intro : A' -> A := fwd conn_def.
  Definition elim : A -> A' := bwd conn_def.
  Definition beta : forall x, elim (intro x) = x := bwd_fwd conn_def.
  Definition eta : forall x, intro (elim x) = x := fwd_bwd conn_def.
End Rules.

Lemma push_conn {A B C} `{Connective B A} : (forall x : A, C (intro x)) -> forall x : B, C x.
Proof.
  move=> K x.
  by rewrite -[x](@eta B A).
Defined.


Set Warnings "-notation-overridden,-parsing".
From LF Require Import Maps.
From LF Require Import Imp.

Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - reflexivity.
  - reflexivity.
  -
    assert (st' = st'0) as EQ1.
    { apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  -
    apply IHE1. assumption.
  -
    rewrite H in H5. inversion H5.
  -
    rewrite H in H5. inversion H5.
  -
    apply IHE1. assumption.
  -
    reflexivity.
  -
    rewrite H in H2. inversion H2.
  -
    rewrite H in H4. inversion H4.
  -
    assert (st' = st'0) as EQ1.
    { apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption. Qed.

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

Example auto_example_1' : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P->Q) -> (P->S)) ->
  T ->
  P ->
  U.
Proof. auto. Qed.

Example auto_example_3 : forall (P Q R S T U: Prop),
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  auto.
  auto 6.
Qed.

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof. auto. Qed.

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.

Hint Resolve le_antisym.

Example auto_example_6' : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto. Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto. Abort.

Hint Unfold is_fortytwo.

Example auto_example_7' : forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof. auto. Qed.

Theorem ceval_deterministic': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
       induction E1; intros st2 E2; inv E2; auto.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  -
    +
      rewrite H in H5. inversion H5.
  -
    +
      rewrite H in H5. inversion H5.
  -
    +
      rewrite H in H2. inversion H2.
  -
    rewrite H in H4. inversion H4.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

Theorem ceval_deterministic'_alt: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1;
           intros st2 E2; inv E2...
  -
    assert (st' = st'0) as EQ1...
    subst st'0...
  -
    +
      rewrite H in H5. inversion H5.
  -
    +
      rewrite H in H5. inversion H5.
  -
    +
      rewrite H in H2. inversion H2.
  -
    rewrite H in H4. inversion H4.
  -
    assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; auto.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  -
    +
      rwinv H H5.
  -
    +
      rwinv H H5.
  -
    +
      rwinv H H2.
  -
    rwinv H H4.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto. Qed.

Ltac find_rwinv :=
  match goal with
    H1: ?E = true,
    H2: ?E = false
    |- _ => rwinv H1 H2
  end.

Theorem ceval_deterministic''': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  -
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  -
    +
      assert (st' = st'0) as EQ1 by auto.
      subst st'0.
      auto. Qed.

Theorem ceval_deterministic'''': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  -
    rewrite (IHE1_1 st'0 H1) in *. auto.
  -
    +
      rewrite (IHE1_1 st'0 H3) in *. auto. Qed.

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.

Theorem ceval_deterministic''''': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
    repeat find_eqn; auto.
Qed.

Module Repeat.

Inductive com : Type :=
  | CSkip
  | CAsgn (x : string) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com)
  | CRepeat (c : com) (b : bexp).

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'TEST' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (TEST b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (TEST b1 THEN c1 ELSE c2 FI) st'
  | E_WhileFalse : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileTrue : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : forall st st' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop : forall st st' st'' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (CRepeat c1 b1) st'' ->
      ceval st (CRepeat c1 b1) st''.

Notation "st '=[' c ']=>' st'" := (ceval st c st')
                                 (at level 40).

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  -
    +
       find_rwinv.
  -
     +
        find_rwinv.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto.
Qed.

End Repeat.

Example ceval_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  apply E_Seq with (X !-> 2).
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

Example ceval'_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  eapply E_Seq.   - apply E_Ass.     reflexivity.   - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.

Definition st12 := (Y !-> 2 ; X !-> 1).
Definition st21 := (Y !-> 1 ; X !-> 2).

Example eauto_example : exists s',
  st21 =[
    TEST X <= Y
      THEN Z ::= Y - X
      ELSE Y ::= X + Z
    FI
  ]=> s'.
Proof. eauto. Qed.


(****************************************************************)
(*  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.
Require Import FunctionalExtensionality.
Set Automatic Coercions Import.
Require Import relations.

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

Section Functional.
Variable n : nat.
Variable A : 'I_n -> Set.
Variable B : 'I_n -> Set.
Variable C : Set.

Definition FuncType : Type :=
  forall (T : monadType), nProd (fun i => A i -> T (B i)) -> T C.
End Functional.

Section Purity.
Variable n : nat.
Variable A : 'I_n -> Set.
Variable B : 'I_n -> Set.
Variable C : Set.

Definition isPure (F : FuncType A B C) : Prop
  := forall (T T' : monadType) (TRacc : TRaccType T T'),
       (nProdR (fun i =>
         IdR (X := A i) =R=> (TR TRacc) _ _ (IdR (X := B i))) =R=>
          (TR TRacc) _ _ (IdR (X := C))) (F T) (F T').
End Purity.

Section Strategy.
Variable n : nat.
Variable A : 'I_n -> Set.
Variable B : 'I_n -> Set.
Variable C : Set.

Inductive Tree :=
  | Ans : C -> Tree
  | Que : forall i, A i -> (B i -> Tree) -> Tree.

Definition fun2tree (F : FuncType A B C)
  := F (Cont Tree) (tuple Que) Ans.

Fixpoint tree2funT (T : monadType) (t : Tree) :=
  match t with
    | Ans c => fun _ => @tval T _ c
    | Que i a f =>
        fun (k : nProd (fun i => A i -> T (B i))) =>
          tbind ((proj i k) a) (fun b => tree2funT T (f b) k)
  end.

Definition tree2fun (t : Tree) : FuncType A B C.
move => T. by refine (tree2funT t).
Defined.

Lemma tree2fun_simpl (t : Tree) (T : monadType) :
  @tree2fun t T = tree2funT t.
Proof.
by rewrite /tree2fun.
Qed.

Lemma tree2fun_pure (t : Tree) : isPure (@tree2fun t).
Proof.
rewrite /isPure.
elim: t => [ | i a f Hind].
- rewrite /ArrR. by intuition; apply TRacc.
- rewrite /ArrR /=. rewrite /ArrR /= in Hind.
  move => T T' TRacc k k' H /=.
  have Htmp := nProdR_elim H i.
  eapply (proj2 (Acc TRacc)); first by apply Htmp.
  rewrite /ArrR => b b' /=; elim. by apply: Hind.
Qed.

Lemma tree2fun2tree (t : Tree) : fun2tree (tree2fun t) = t.
Proof.
rewrite /fun2tree.
elim: t => [// | i a f Hind /=].
- f_equal. by apply: functional_extensionality.
Qed.

Section conversion.
Variable S : Type.
Variable q : nProd (fun i => A i -> (B i -> S) -> S).
Variable a : C -> S.

Definition conv (t : Tree) := @tree2funT (Cont S) t q a.

Definition TRacc1 : TRaccType (Cont Tree) (Cont S).
exists
  (fun X X' (R : Rel X X') => fun H H' =>
    forall h h', (R =R=> Gr conv) h h' -> Gr conv (H h) (H' h')).
split.
- by move => /=; intuition.
- move => X X' Y Y' Q R f f' t t' H H0.
  move => h h' Hhh'. apply: H => x x' Hxx'. by firstorder.
Defined.
End conversion.

Lemma fun2tree2fun_Cont S (F : FuncType A B C) (Hpure : isPure F) :
  @tree2funT (Cont S) (fun2tree F) = F (Cont S).
Proof.
extensionality q.
extensionality a.
suff H : Gr (conv q a) (F (Cont Tree) (tuple Que) Ans) (F (Cont S) q a); first by elim H.
have H := @Hpure _ _ (TRacc1 q a) => {Hpure}.
apply: H.
- elim: q => q i.
  move => a1 a1' /=; elim.
  move => h h' Hhh'.
  rewrite /Gr /conv /=.
  f_equal. extensionality b. by firstorder.
- by move => c c'; elim.
Qed.

Definition Phi (T : monadType)
               (F : nProd (fun i => A i -> Cont (T C) (B i)) -> Cont (T C) C)
  : nProd (fun i => A i -> T (B i)) -> T C.
elim => h.
by refine (F (tuple (fun i => (@tbind _ _ _) \o h i)) (@tval _ _)).
Defined.

Definition TRacc2 (T : monadType) : TRaccType (Cont (T C)) T.
exists
  (fun X X' (R : Rel X X') => fun H H' =>
    forall h h', (R =R=> @IdR (T C)) h h' ->
      (@IdR (T C) (H h) (tbind H' h'))).
split.
- move => X X' R x x' H h h' H1 /=. rewrite taxiom0. by intuition.
- move => X X' Y Y' Q R f f' t t' H H0.
  move => h h' Hhh'. rewrite taxiom2 //. apply: H => x x' Hxx'. by apply: H0.
Defined.

Lemma lem_Phi (T : monadType)
            (F : FuncType A B C) (Hpure : isPure F) :
  Phi (F (Cont (T C))) = F T.
Proof.
apply: functional_extensionality; case => g.
rewrite /Phi -[X in _ = X]taxiom1 /=.
have H := @Hpure _ _ (TRacc2 T) => {Hpure}.
apply: H.
- move => i a a'. elim. move => h h' Hhh'.
  suff Htmp: h = h'; first by rewrite Htmp.
  by extensionality x; apply: Hhh'.
- by move => c c'; elim.
Qed.

Theorem fun2tree2tree (F : FuncType A B C) (Hpure : isPure F) :
  forall (T : monadType), @tree2fun (fun2tree F) T = @F T.
Proof.
move => T.
rewrite -lem_Phi; last by apply: tree2fun_pure.
rewrite /tree2fun. rewrite fun2tree2fun_Cont //=.
by apply: lem_Phi.
Qed.

End Strategy.


Require Export Basics.

Require Export EnvListAux7.
Require Export EnvListAuxT1.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import Coq.Logic.ProofIrrelevance.

Require Import TPipStaticM2.
Require Import TPipDynamicM2.
Require Import TRInductM2.
Require Import WeakM2.
Require Import TSoundnessM2.
Require Import IdModType.

Module Hardware_bis (IdT: IdModType) <: IdModType.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Module TSoundnessC := TSoundness IdT.
Export TSoundnessC.

(**************************************************)

Definition HoareTriple_Step
           (P : W -> Prop) (Q : Exp -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (e: Exp) : Prop :=
  forall (s s': W) (e': Exp),
    EStep fenv env (Conf Exp s e) (Conf Exp s' e') ->
    P s -> Q e' s'.

Definition HoareTriple_Eval
           (P : W -> Prop) (Q : Value -> W -> Prop)
           (fenv: funEnv) (env: valEnv)
           (e: Exp) : Prop :=
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)) ->
    P s -> Q v s'.

Definition hoareTriple_ExtendedStep
           (P : W -> Prop) (fenv: funEnv) (env: valEnv)
           (e: Exp) (Q : Exp -> W -> Prop) : Prop :=
  forall (s s': W) (e': Exp),
    EClosure fenv env (Conf Exp s e) (Conf Exp s' e') ->
    P s -> Q e' s'.

Notation "{{ P }} fenv >> env >> e {{ Q }}" := (hoareTriple_ExtendedStep P fenv env e Q)
(at level 90) : state_scope.

Open Scope state_scope.

Lemma conjProp (P R : W -> Prop) (Q : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
{{ P }} fenv >> env >> e  {{ Q }}
-> {{ R }} fenv >> env >> e {{fun _ => R}}
-> {{fun s => P s/\ R s}} fenv >> env >> e {{fun a s => Q a s/\ R s}}.
Proof.
intros H1 H2.
intros s s' e'.
intros H3 H4.
destruct H4 as [H4 H5].
split.
-unfold hoareTriple_ExtendedStep in H1.
 apply H1 in H3.
 assumption. assumption.
-unfold hoareTriple_ExtendedStep in H2.
 apply H2 in H3.
 assumption. assumption.
Qed.

Definition wp (P : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
  W -> Prop := fun s => forall (e':Exp) (s': W),
       EClosure fenv env (Conf Exp s e) (Conf Exp s' e') -> P e' s'.

Lemma wpIsPrecondition (P : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
  {{ wp P fenv env e }} fenv >> env >> e {{ P }}.
Proof.
unfold hoareTriple_ExtendedStep.
intros s s' e' H1 H2.
unfold wp in H2.
apply H2 in H1.
auto.
Qed.

Lemma wpIsWeakestPrecondition(P : Exp -> W -> Prop) (Q : W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
  {{ Q }} fenv >> env >> e {{ P }} -> forall s, Q s -> (wp P fenv env e) s.
Proof.
intros H1 s H2.
unfold wp.
intros e' s' H3.
apply H1 in H3.
auto.
Qed.

Lemma postAnd :
forall (P : W -> Prop) (Q R : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
  {{ P }} fenv >> env >> e {{ Q }}
-> {{ P }} fenv >> env >> e {{ R }}
-> {{ P }} fenv >> env >> e {{ fun a s => Q a s /\ R a s }}.
Proof.
intros P Q R fenv env e H1 H2.
intros a s.
intros e' H3 H4.
split.
-unfold hoareTriple_ExtendedStep in H1.
 apply H1 in H3.
 assumption. assumption.
-apply H2 in H3.
 auto.
Qed.

Lemma preOr :
  forall (P Q : W -> Prop) (R : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
  {{ P }} fenv >> env >> e {{ R }}
-> {{ Q }} fenv >> env >> e {{ R }}
-> {{ fun s => P s \/ Q s }} fenv >> env >> e {{ R }}.
Proof.
intros P Q R fenv env e H1 H2 s.
intros s' e' H3 H4.
destruct H4.
-apply H1 in H3 .
 auto.
-apply H2 in H3.
 auto.
Qed.

Lemma preAndPost :
forall (P1 Q1 : W -> Prop) (P2  : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
{{P1}} fenv >> env >> e {{P2}} ->
{{fun s => P1 s /\ Q1 s}} fenv >> env >> e {{fun a => Q1 }} ->
{{fun s => P1 s /\ Q1 s}} fenv >> env >> e {{fun a s => P2 a s /\ Q1 s}}.
Proof.
intros P1 Q1 P2 fenv env e H1 H2 s s'.
intros e' H3 [H4 H5].
split.
-apply H1 in H3.
 auto.
-apply H2 in H3.
 apply H3.
 auto.
Qed.

Lemma andAssocHT  :
forall (P1 P2 P3 : W -> Prop) (R  : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
{{ fun s => (P1 s /\ P2 s) /\ P3 s }} fenv >> env >> e {{ R }}
<-> {{ fun s => P1 s /\ P2 s /\ P3 s }} fenv >> env >> e {{ R }}.
Proof.
intros P1 P2 P3 R fenv env e.
split.
-intro H.
 unfold hoareTriple_ExtendedStep.
 intros s s' e' H1 [H2 [H3 H4]].
 apply H in H1.
 apply H1.
 auto.
-intro s.
 unfold hoareTriple_ExtendedStep.
 intros s0 s' e' H1 [[H2 H3] H4].
 apply s in H1.
 auto.
Qed.

Lemma permutHT :
forall (P1 P2 P3 : W -> Prop) (R  : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
{{ fun s => P1 s /\ P2 s /\ P3 s }} fenv >> env >> e {{ R }}
<-> {{ fun s => P1 s /\ P3 s /\ P2 s }} fenv >> env >> e {{ R }}.
Proof.
intros P1 P2 P3 R fenv env e.
split.
-intro s.
 unfold hoareTriple_ExtendedStep.
 intros s0 s' e' H1 [H2 [H3 H4]].
 apply s in H1.
 auto.
-intro s.
 unfold hoareTriple_ExtendedStep.
 intros s0 s' e' H1 [H2 [H3 H4]].
 apply s in H1.
 auto.
Qed.
(*
split;
intro s;
unfold hoareTriple_ExtendedStep;
intros s0 s' e' H1 [H2 [H3 H4]];
apply s in H1;
auto.*)

Lemma preAnd:
 forall (P1 Q : W -> Prop) (P2  : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e: Exp),
{{P1}} fenv >> env >> e {{P2}}
-> {{fun s => P1 s /\ Q s}} fenv >> env >> e {{P2}}.
Proof.
intros P1 Q P2 fenv env e H s.
intros s' e' H1 [H2 H3].
apply H in H1.
apply H1.
auto.
Qed.

Lemma conjPrePost :
forall (P1 Q1 : W -> Prop) (P2 Q2 : Exp -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp),
{{P1}} fenv >> env >> e {{P2}} ->
{{Q1}} fenv >> env >> e {{Q2}} ->
{{fun s => P1 s /\ Q1 s}} fenv >> env >> e {{fun a s => P2 a s /\ Q2 a s}}.
Proof.
intros P1 Q1 P2 Q2 fenv env e H1 H2 s.
intros s' e' H3 [H4 H5].
split.
-apply H1 in H3.
 auto.
-apply H2 in H3.
 auto.
Qed.

End Hardware_bis.


Require Import VST.floyd.proofauto.

Require Import min2.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition ssl_is_valid_int (x: val) := exists y, x = Vint (Int.repr y) /\  Int.min_signed <= y <= Int.max_signed.

Ltac ssl_open_context :=
  lazymatch goal with
  | [ H:  ssl_is_valid_int ?x |- _ ] =>
    let x1 := fresh x in
    rename x into x1;
    let H2 := fresh H in
    let H3 := fresh H in
    destruct H as [x [H2 H3]]; rewrite H2; ssl_open_context
  | _ => idtac
  end.

Definition min2_spec :=
  DECLARE _min2
   WITH r: val, x: val, y: val
   PRE [ (tptr (Tunion _sslval noattr)), tint, tint ]
   PROP( is_pointer_or_null(r); ssl_is_valid_int(x); ssl_is_valid_int(y) )
   PARAMS(r; x; y)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [inl (Vint (Int.repr 0))] r))
   POST[ tvoid ]
   EX m: Z,
   PROP( (m <= (force_signed_int x)); (m <= (force_signed_int y)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [inl (Vint (Int.repr m))] r)).

(* Packaging the API spec all together. *)
Definition Gprog : funspecs :=
  ltac:(with_library prog [min2_spec]).

From mathcomp Require Import ssreflect ssrbool.

(** Proof that f_swap, the body of the swap() function,
 ** satisfies swap_spec, in the global context (Vprog,Gprog).
 **)
Lemma min2_swap: semax_body Vprog Gprog f_min2 min2_spec.
Proof.
  start_function.
  ssl_open_context.
  forward_if.
  - forward.
    forward.
    Exists x.
    entailer.
  - forward.
    forward.
    Exists y.
    entailer!.
Qed.


(* coq-prelude
 * Copyright (C) 2018–2019 ANSSI
 *
 * Contributors:
 * 2018–2019 Thomas Letan <thomas.letan@ssi.gouv.fr>
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program. If not, see <http://www.gnu.org/licenses/>.
 *)

Require Import Coq.Lists.List.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Program.Equality.

Require Import Prelude.Control.Sum.
Require Import Prelude.Data.Void.

Import ListNotations.
Local Open Scope list_scope.

(** If you use polymorphic definition, do no use function from the
    standard library. Define your own. *)
#[universes(polymorphic)]
Fixpoint cardinal
         {a:  Type}
         (l:  list a)
  : nat :=
  match l with
  | _ :: rst
    => S (cardinal rst)
  | nil
    => O
  end.

#[universes(polymorphic)]
Fixpoint get
         (set:  list Type)
         (n:    nat)
         {struct n}
  : Type :=
  match n, set with
  | 0, t :: _
    => t
  | S n, _ :: set'
    => get set' n
  | _, _
    => Void
  end.

(** The open [union] type. For instance, a value [(v: union [nat;
    bool])] will be either of type [nat] or [bool]. *)
#[universes(polymorphic)]
Inductive union
          (set:  list Type)
  : Type :=
| OneOf {t:  Type}
        (n:  nat)
        (Ht: get set n = t)
        (Hn: n < cardinal set )
        (x:  t)
  : union set.

Arguments OneOf [set t] (n Ht Hn x).

(** An “open product”. Similarly to [union], it is parameterized by a
    list of types. *)
#[universes(polymorphic)]
Inductive product
  : list Type -> Type :=
| Acons (a:    Type)
        (x:    a)
        (set:  list Type)
        (rst:  product set)
  : product (a :: set)
| Anil
  : product [].

Arguments Acons [a] (x) [set] (rst).

(** Given an open product [(x: product set)], get the [n]th element of
    type [get set n]. *)
#[universes(polymorphic)]
Fixpoint fetch
         {set:  list Type}
         (x:    product set)
         (n:    nat)
         (H:    n < cardinal set)
  : get set n.
case_eq set.
+ intros Heq.
  subst.
  cbn in H.
  omega.
+ intros T l Heq.
  subst.
  dependent induction x.
  induction n.
  exact x.
  cbn.
  apply fetch.
  ++ exact x0.
  ++ cbn in H.
     omega.
Defined.

(** Given an open product [(x: product set)], change the [n]th element
    of type [get set n] by a new value [v]. *)
#[universes(polymorphic)]
Fixpoint swap
         {set:  list Type}
         (x:    product set)
         (n:    nat)
         (H:    n < cardinal set)
         (v:    get set n)
         {struct x}
  : product set.
case_eq set.
+ intros Heq.
  subst.
  cbn in H.
  omega.
+ intros T l Heq.
  subst.
  dependent induction x.
  induction n.
  ++ exact (Acons v x0).
  ++ refine (Acons x _).
     apply (swap l x0 n).
     +++ cbn in H.
         omega.
     +++ exact v.
Defined.

(** Given a list of type [set] and a natural number [n], returns a
    list of type wherein the [n]th element of [set] is absent. *)
#[universes(polymorphic)]
Fixpoint remove
         (set:  list Type)
         (n:    nat)
  : list Type :=
  match set, n with
  | _ :: rst, 0
    => rst
  | x :: rst, S n
    => x :: remove rst n
  | _, _
    => []
  end.

(** Given an arbitrary list of types [set], we want to be able to tell
    whether or not it contains the type [t]. This is what the
    [Contains] typeclass is for. *)
#[universes(polymorphic)]
Class Contains
      (t:    Type)
      (set:  list Type)
  := { rank:            nat
     ; rank_get_t:      get set rank = t
     ; rank_bound:      rank < cardinal set
     }.

Arguments rank (t set) {_}.
Arguments rank_get_t (t set) {_}.
Arguments rank_bound (t set) {_}.

(** One obvious instance of [Contains] is that the type [get set n] is
    contains in [set]. *)
#[universes(polymorphic)]
Instance Contains_nat
         (set:  list Type)
         (n:    nat)
         (H:    n < cardinal set)
  : Contains (get set n) set :=
  { rank        := n
  ; rank_get_t  := eq_refl
  ; rank_bound  := H
  }.

(** Then, following what is often done in Haskell in this context, we
    can define two instances of [Contains]:

    First, a list contains its head. *)
#[program, universes(polymorphic)]
Instance Contains_head
         (t:    Type)
         (set:  list Type)
  : Contains t (cons t set) :=
  { rank        := 0
  ; rank_get_t  := eq_refl
  }.

Next Obligation.
  apply Nat.lt_0_succ.
Defined.

(** Then, if a list [set] contains a type [t], then any list
    constructed by appending an element to [set] also contains [t]. *)
#[universes(polymorphic), program]
Instance Contains_tail
         (t any:  Type)
         (set:    list Type)
         (H:      Contains t set)
  : Contains t (cons any set) :=
  { rank       := S (rank t set)
  }.

Next Obligation.
  apply rank_get_t.
Defined.

Next Obligation.
  cbn.
  apply lt_n_S.
  apply rank_bound.
Defined.

(** Using the [Contains] typeclass, we can define a useful function
    [inj] to easily construct values of arbitrary open unions. *)
#[universes(polymorphic), program]
Definition inj
           {t:    Type}
           {set:  list Type} `{Contains t set}
           (x:    t)
  : union set :=
  OneOf (rank t set) (rank_get_t t set) (rank_bound t set) x.

(** The aim of the [visit] function is two fold. Given an open product
    [x] and a function [(f: t -> a * t)] such that a value of type [t]
    is present in [x] (as enforced by the [Contains] constraint). It
    returns the result of type [a] produced by [f] along with an open
    union such that the value of type [t] has been [swap]ped with the
    value of type [t] produced by [f]. *)
Definition visit
           {t:    Type}
           {set:  list Type} `{Contains t set}
           {a:    Type}
           (x:    product set)
           (f:    t -> a * t)
  : a * product set.
  refine (match fetch x (rank t set) (rank_bound t set)
                return get set (rank t set) = t -> a * product set
          with
          | v
            => fun (H: get set (rank t set) = t)
               => _
          end (rank_get_t t set)).
  remember (f (eq_rect (get set (rank t set)) (fun X => X) v t H)) as p.
  induction p as [v' u].
  refine (v', swap x (rank t set) (rank_bound t set) _).
  refine (eq_rect t (fun X => X) u (get set (rank t set)) _).
  symmetry.
  exact H.
Defined.


(** NetKAT Automata & Language Theory *)

Require Import List Coq.Program.Equality Bool Omega FunctionalExtensionality Recdef.
Import ListNotations.
Require Export NetKAT InductiveNETKAT Sets Misc Classes Tactics.

Ltac invert H := inversion H; subst; clear H.

(** NetKAT language model.  ********************************************)
(* See the original NetKAT paper *)

Module Automata (F : FIELDSPEC) (V : VALUESPEC(F)).

Include  InductiveNETKAT.NetKAT(F)(V).

(** Guarded NetKAT Strings *******************************************)

(* P ; (P;dup)* ; P *)
Inductive gs :=
  | GS : P.t -> list P.t -> P.t -> gs.

Hint Constructors gs.

Global Arguments GS a w b : rename.

Notation "a ~( w )~ b" := (GS a w b) (at level 1, format "a ~( w )~ b").

(* equality on guarded NetKAT strings is decidable, since equality on packets
   is decidable *)
Global Program Instance : EqType gs := fun x y => match x,y with
  a~(w)~b, a'~(w')~b' => if (a,w,b) =d= (a',w',b') then left _ else right _
end.

Definition gs_length (gs : gs) :=
  let '_~(w)~_ := gs in length w.

(* Dexter also calls this the "fusion product",
   see "Automata on Guarded Strings and Applications" *)
Definition gs_conc (s1 s2 : gs) :=
  let 'a~(w)~b := s1 in
  let 'b'~(v)~c := s2 in
  if b =d= b' then Some (a~(w++v)~c) else None.

Definition take (n:nat) (s:gs) (c : P.t) : gs :=
  let 'a~(w)~b := s in
  let w' := firstn n w in
  a~(w')~c.

Definition drop (n:nat) (c : P.t) (s:gs) : gs :=
  let 'a~(w)~b := s in
  let w' := skipn n w in
  c~(w')~b.

Theorem conc_take_drop (s: gs) (n : nat) c :
  gs_conc (take n s c) (drop n c s) = Some s.
Proof.
  destruct s as [a w b]. destruct n; simpl.
  + split_if; intuition idtac.
  + split_if; intuition idtac.
    destruct w; intuition simpl.
    rewrite firstn_skipn. reflexivity.
Qed.

(** End Guarded NetKAT Strings #######################################*)

(** decidable languages over guarded NetKAT strings *****************************)

Definition gs_lang := gs -> bool.

(** UNION ****)

Definition gs_lang_union L1 L2 := [$ s : gs | s \in L1 || s \in L2 ].

Theorem lang_union_correct L1 L2 s :
  (s \in L1 = true \/ s \in L2 = true) <-> s \in gs_lang_union L1 L2 = true.
Proof. rewrite <- orb_true_iff. unfold gs_lang_union. intuition. Qed.

(** CONC ****)

Definition gs_lang_conc L1 L2 := [$ s : gs | [$ exists a |
  existsb (fun n => take n s a \in L1 && drop n a s \in L2) (seq 0 (S (gs_length s))) ] ].

Lemma firstn_app {X} (xs ys : list X) : firstn (length xs) (xs ++ ys) = xs.
Proof. induction xs; intros; intuition simpl. congruence. Qed.

Lemma skipn_app {X} (xs ys : list X) : skipn (length xs) (xs ++ ys) = ys.
Proof. induction xs; intros; intuition simpl. Qed.

Theorem lang_conc_correct L1 L2 s :
  (exists s1 s2, (Some s = gs_conc s1 s2) /\ (s1 \in L1 = true) /\ (s2 \in L2 = true))
  <-> (s \in gs_lang_conc L1 L2 = true).
Proof.
  split; intro H.
  + steffen.
    destruct s1 as [a w b]; destruct s2 as [b' v c].
    simpl in H. split_if; invert H.
    unfold gs_lang_conc. apply exists_iff. exists b'.
    apply existsb_exists. exists (length w).
    split.
    - clear H1; clear H0; induction w; simpl; intuition auto.
      simpl in IHw; destruct IHw; intuition auto.
      repeat right. rewrite <- seq_shift. apply in_map. assumption.
    - simpl. rewrite firstn_app; rewrite skipn_app.
      rewrite H1; rewrite H0. auto.
  + unfold gs_lang_conc in H; rewrite existsb_exists in H.
    steffen.
    exists (take x0 s x). exists (drop x0 x s).
    intuition idtac. symmetry. apply conc_take_drop.
Qed.

(* missing: kleene star *)
Definition gs_lang_id := [$ s : gs | let 'a~(w)~b := s in (a =b= b) && (w =b= []) ].

Fixpoint gs_lang_power L n :=
match n with
  | O => gs_lang_id
  | S n => gs_lang_conc L (gs_lang_power L n)
end.

(*
Parameter gs_lang_star : gs_lang -> gs_lang.
Axiom lang_star_correct : forall L s,
  (exists n, gs_lang_power L n s = true) <-> (gs_lang_star L s = true).
*)

(** End languages over guarded strings ########################*)

(** NetKAT NFAs over guarded strings **************************************)
(* See "A Coalgebraic Decision Procedure for NetKAT" for details *)

Record nfa := {
  nfa_state :> Type;
  nfa_finite :> Finite nfa_state;
  nfa_eqtype :> EqType nfa_state;
  nfa_s : nfa_state;
  nfa_accept : nfa_state -> P.t -> P.t -> bool;
  nfa_trans : nfa_state -> P.t -> P.t -> nfa_state -> bool
}.

Global Instance nfa_is_finite (A : nfa) : Finite (nfa_state A) := nfa_finite A.
Global Instance nfa_is_eqtype (A : nfa) : EqType (nfa_state A) := nfa_eqtype A.

Arguments nfa_accept {A} q a b : rename.
Arguments nfa_trans {A} q a b q' : rename.

(* We must define acceptance with "fuel" n as otherwise Coq cannot be convinced
   that accept terminates. *)
Fixpoint accept_n {A : nfa} (q : A) gs n :=
match gs with
  | a~([])~b => nfa_accept q a b
  | a~(b::w)~c =>
    match n with
      | O => false
      | S n => [$ exists q' | nfa_trans q a b q' && accept_n q' b~(w)~c n ]
    end
end.

Definition accept {A : nfa} (q : A) gs := accept_n q gs (gs_length gs).
Hint Unfold accept.

Inductive accept_prop {A : nfa} (q : A) : gs -> Prop :=
  | accept_atom : forall a b,
      nfa_accept q a b = true -> accept_prop q a~([])~b
  (* - - -  - - - - - - -  - - - - - - - - - - - - - - - - *)
  | accept_trans : forall a b c w q',
     nfa_trans q a b q' = true -> accept_prop q' b~(w)~c ->
        accept_prop q a~(b::w)~c.

Hint Constructors accept_prop.

Theorem accept_correct (A : nfa) (q : A) gs : accept_prop q gs <-> accept q gs = true.
Proof.
  destruct gs as [a w b].
  split; intro H; gd q; gd a; gd b; induction w; intros;
  unfold accept in *; simpl;  try invert H; steffen; eauto.
  + exists q'. steffen. intuition eauto.
Qed.

Definition nfa_lang (A : nfa) := [$ gs | accept (nfa_s A) gs ].
Hint Unfold nfa_lang.

(** primitive automata ****************************************************)

Definition nfa_pred p :=
  {| nfa_s := tt;
     nfa_accept q a b := p a b;
     nfa_trans q a b q' := false |}.

Lemma nfa_pred_correct p :
  nfa_lang (nfa_pred p) = [$ s | let 'a~(w)~b := s in (p a b) && (w =b= [])].
Proof.
  apply pred_eq_intro. intro s; destruct s as [a w b]; unfold nfa_lang.
  rewrite <- accept_correct.
  split; intro H; invert H; simpl in *; intuition; steffen.
  subst w. auto.
Qed.

Definition nfa_dup :=
  {| nfa_s := false;
     nfa_accept q a b := q && (a =b= b);
     nfa_trans q a b q' := (negb q) && q' && (a =b= b) |}.

Lemma nfa_dup_correct :
  nfa_lang nfa_dup = [$ s | let 'a~(w)~b := s in (a =b= b) && (w =b= [a])].
Proof.
  apply pred_eq_intro; intro s; destruct s as [a w b]; unfold nfa_lang;
  rewrite <- accept_correct; split; intro H; steffen.
  + invert H. invert H1. invert H2. invert H4. invert H1.
    steffen. subst. split; congruence.
    invert H2. steffen. congruence.
  + subst. right with (q':=true); intuition; simpl.
    apply eqb_refl. left. simpl. apply eqb_refl.
Qed.

(** nfa_union *****************************************************************)

Definition nfa_union (A B : nfa) :=
  {| nfa_s := None;
     nfa_accept q a b :=
       match q with
         | None => nfa_accept (nfa_s A) a b || nfa_accept (nfa_s B) a b
         | Some (inl q) => @nfa_accept A q a b
         | Some (inr q) => @nfa_accept B q a b
       end;
     nfa_trans q a b q' :=
       match q,q' with
         | _, None | Some (inl _), Some (inr _) | Some (inr _), Some (inl _) => false
         | None, Some (inl q') => nfa_trans (nfa_s A) a b q'
         | None, Some (inr q') => nfa_trans (nfa_s B) a b q'
         | Some (inl q), Some (inl q') => @nfa_trans A q a b q'
         | Some (inr q), Some (inr q') => @nfa_trans B q a b q'
       end
  |}.

Lemma nfa_union_correct_left (A B : nfa) (q:A) gs :
  @accept_prop (nfa_union A B) (Some (inl q)) gs <-> accept_prop q gs.
Proof.
  destruct gs as [a w b].
  gd a; gd b; gd q; induction w; intros;
  split; intro H; inversion H; simpl in *; eauto 2.
  + destruct q' as [[q'|q']| ]; inversion H2. econstructor; eauto.
    apply IHw. assumption.
  + econstructor. instantiate (1 := Some (inl q')). simpl. assumption.
    rewrite IHw. assumption.
Qed.

Lemma nfa_union_correct_left' (A B : nfa) (q:A) :
  [$ gs | @accept (nfa_union A B) (Some (inl q)) gs ] = [$ gs | accept q gs].
Proof.
  apply pred_eq_intro.
  intro gs. repeat rewrite <- accept_correct. apply nfa_union_correct_left.
Qed.

Lemma nfa_union_correct_right (A B : nfa) (q:B)  gs :
  @accept_prop (nfa_union A B) (Some (inr q)) gs <-> accept_prop q gs.
Proof.
  destruct gs as [a w b].
  gd a; gd b; gd q; induction w; intros;
  split; intro H; inversion H; simpl in *; eauto 2.
  + destruct q' as [[q'|q']| ]; inversion H2. econstructor; eauto.
    apply IHw. assumption.
  + econstructor. instantiate (1 := Some (inr q')). simpl. assumption.
    rewrite IHw. assumption.
Qed.

Lemma nfa_union_correct_right' (A B : nfa) (q:B) :
  [$ gs | @accept (nfa_union A B) (Some (inr q)) gs ] = [$ gs | accept q gs].
Proof.
  apply pred_eq_intro.
  intro gs. repeat rewrite <- accept_correct. apply nfa_union_correct_right.
Qed.

Lemma nfa_union_correct A B :
  nfa_lang (nfa_union A B) = gs_lang_union (nfa_lang A) (nfa_lang B).
Proof.
  unfold nfa_lang.
  apply pred_eq_intro.
  intro gs. rewrite <- lang_union_correct.
  repeat rewrite <- accept_correct.
  destruct gs as [a [ | b w] c];
  split; intro H; [ |destruct H as [H|H]| |destruct H as [H|H]];
  inversion H; simpl in *.
  - destruct (orb_prop _ _ H1) as [H3|H3]; eauto.
  - constructor. simpl. rewrite H1; simpl; reflexivity.
  - constructor. simpl. apply orb_true_intro; auto.
  - destruct q' as [[q'|q']| ]; inversion H2; [left|right];
    [rewrite nfa_union_correct_left in H5 | rewrite nfa_union_correct_right in H5];
    eauto.
  - econstructor. instantiate (1 := Some (inl q')); simpl; assumption.
    apply nfa_union_correct_left. assumption.
  - econstructor. instantiate (1 := Some (inr q')); simpl; assumption.
    apply nfa_union_correct_right. assumption.
Qed.

(** nfa_seq *****************************************************************************)

Section nfa_seq.

Definition nfa_seq A1 A2 : nfa :=
 {| nfa_s := inl (nfa_s A1);
    nfa_accept q a b :=
      match q with
        | inl q => [$ exists c | (nfa_accept q a c) && (nfa_accept (nfa_s A2) c b)]
        | inr q => nfa_accept q a b
      end;
    nfa_trans q a b q' :=
      match q,q' with
        | inl q, inl q' => nfa_trans q a b q'
        | inl q, inr q' => [$ exists c | (nfa_accept q a c) && (nfa_trans (nfa_s A2) c b q')]
        | inr q, inr q' => nfa_trans q a b q'
        | inr q, inl q' => false
      end
 |}.

Lemma bool_iff P1 P2 B1 B2 :
  (P1 <-> B1 = true) -> (P2 <-> B2 = true) -> (P1 <-> P2) -> B1=B2.
Proof.
  intros H1 H2 H.
  assert(B1 = true <-> B2 = true) by (rewrite <- H1; rewrite <- H2; assumption).
  case_eq B1; case_eq B2; intuition congruence.
Qed.

Lemma seq_inr A1 A2 q gs :
  @accept (nfa_seq A1 A2) (inr q) gs = accept q gs.
Proof.
  apply (bool_iff (@accept_prop (nfa_seq A1 A2) (inr q) gs) (accept_prop q gs));
  try apply accept_correct.
  destruct gs as [a w b].
  split; intro H; gd a; gd b; gd q; induction w; intros; invert H; simpl in *; auto.
  - destruct q'; eauto 4. invert H2.
  - econstructor. instantiate (1 := inr q'). simpl. assumption. eauto.
Qed.

Lemma seq_inl A1 A2 q s :
  (exists s1 s2, Some s = gs_conc s1 s2 /\ accept_prop q s1
                                        /\ accept_prop (nfa_s A2) s2)
  <-> (@accept (nfa_seq A1 A2) (inl q) s = true).
Proof.
  split; intro H.
  + destruct s as [a w c].
    destruct H as [[a' u b] [[b' v c'] [H1 [H2 H3]]]].
    apply accept_correct. gd a; gd w; gd c; gd b'; gd v; induction H2; intros.
    - rewrite <- conc_take_drop with (n:=0) (c:=b') in H1.
      simpl in H1. repeat split_if; invert H1; try congruence.
      invert H3.
      * left. simpl. apply exists_iff. exists b'. intuition.
      * eright. instantiate (1:=inr q'). simpl. apply exists_iff.
        exists b'. intuition. rewrite accept_correct in *. rewrite seq_inr.
        assumption.
   - simpl in H1. split_if; invert H1. eright. instantiate (1 := inl q').
     simpl; assumption. eapply IHaccept_prop. eassumption. simpl.
     split_if; intuition.
 + apply accept_correct in H. dependent induction H; simpl in H.
   - steffen. exists (a~([])~x); exists (x~([])~b). intuition eauto 2.
     simpl. split_if; intuition.
   - destruct q' as [q'|q'].
     * assert (exists s1 s2 : gs,
                  Some b~(w)~c = gs_conc s1 s2 /\
                  accept_prop q' s1 /\ accept_prop (nfa_s A2) s2) by eauto.
       steffen. destruct s1 as [b' u d]; destruct s2 as [d' v c'].
       simpl in H1. split_if; invert H1.
       exists a~(b'::u)~d'; exists d'~(v)~c'; intuition eauto 2.
       simpl. split_if; intuition.
     * steffen. exists a~([])~x; exists x~(b::w)~c; intuition eauto 2.
       simpl. split_if; intuition. eright with (q':=q'); eauto.
       rewrite accept_correct in *. rewrite <- seq_inr with (A1:=A1).
       assumption.
Qed.

Lemma nfa_seq_correct A1 A2 :
  nfa_lang (nfa_seq A1 A2) = gs_lang_conc (nfa_lang A1) (nfa_lang A2).
Proof.
  apply pred_eq_intro. intro gs. rewrite <- lang_conc_correct.
  unfold nfa_lang. simpl. rewrite <- seq_inl.
  split; intro H; destruct H as [s1 [s2 [H0 [H1 H2]]]];
  exists s1; exists s2; intuition; apply accept_correct; assumption.
Qed.

End nfa_seq.

(** nfa_star *****************************************************************************)
(* TO BE IMPLEMENTED *)

Parameter nfa_star : nfa -> nfa.

Axiom nfa_star_correct : forall A s,
  (exists n, gs_lang_power (nfa_lang A) n s = true) <-> (nfa_lang (nfa_star A) s = true).

(* NetKAT to NFA ***************************************************************)
(* this is Thompson's construction for NetKAT *)

Fixpoint netkat_nfa (p : policy) : nfa :=
match p with
  | Drop  => nfa_pred (fun _ _ => false)
  | Id    => nfa_pred (fun p p' => p =b= p')
  | Dup   => nfa_dup
  | f==n  => nfa_pred (fun p p' => (p =b= p') && ((p f) =b= n))
  | f!=n  => nfa_pred (fun p p' => (p =b= p') && ((p f) <b> n))
  | f<-n  => nfa_pred (fun p p' => p' =b= p[f:=n])
  | q+r   => nfa_union (netkat_nfa q) (netkat_nfa r)
  | q;;r  => nfa_seq (netkat_nfa q) (netkat_nfa r)
  | q*    => nfa_star (netkat_nfa q)
end.

Theorem netkat_nfa_correct (p : policy) a b v w :
  (| p |) (a,v) (b,w++v) <-> (a~(rev w)~b \in nfa_lang (netkat_nfa p) = true).
Proof.
  split; intro H.
  + dependent induction H; simpl;
    try (symmetry in x; rewrite <- app_nil_l in x; apply app_inv_tail in x; subst w);
    first [rewrite nfa_pred_correct | rewrite nfa_dup_correct |
           rewrite nfa_union_correct; apply lang_union_correct |
           rewrite nfa_seq_correct; apply lang_conc_correct | idtac];
    steffen; repeat split; eauto 3.
    - destruct h' as [c u']. destruct (bstep_prefix H) as [u H1]. subst u'.
      destruct (bstep_prefix H0) as [u' H1]. rewrite app_assoc in H1.
      assert (w=u'++u) by eauto using app_inv_tail. subst w. clear H1.
      rewrite rev_app_distr. exists (a~(rev u)~c); exists (c~(rev u')~b).
      simpl. rewrite <- app_assoc in IHbstep2. split_if; intuition eauto 2.
    - (* star case 1 *) admit.
    - (* star case 2 *) admit.
    - replace w with [b]. intuition.
      apply app_inv_tail with (l:=v). auto.
  + gd a; gd b; gd v; gd w; induction p; intros; simpl in *;
    first [rewrite nfa_pred_correct in H | rewrite nfa_dup_correct in H |
           rewrite nfa_union_correct in H; apply lang_union_correct in H |
           rewrite nfa_seq_correct in H; apply lang_conc_correct in H | idtac];
    steffen; intuition;
    try (assert (w=[]) by auto using rev_eq_nil; subst; simpl; eauto).
    - destruct s1 as [a' v' c]; destruct s2 as [c' u' b'].
      unfold gs_conc in H. split_if; invert H.
      assert (w = rev(v'++u')) by (rewrite <- H4; auto using rev_involutive). subst w.
      rewrite <- (rev_involutive v') in H0.
      rewrite <- (rev_involutive u') in H1.
      rewrite rev_app_distr. rewrite <- app_assoc.
      econstructor; eauto.
    - (* star case *) admit.
    - subst b. assert (w=[a]) by auto using rev_eq_singleton; subst w.
      simpl; eauto.
Qed.

End Automata.


Require Import VST.floyd.proofauto.
Require Import apile.
Require Import simple_spec_stdlib.
Require Import simple_spec_pile.
Require Import PileModel.

Instance APileCompSpecs : compspecs. make_compspecs prog. Defined.

Definition apile (sigma: list Z) (gv: globals): mpred :=
  !!(headptr (gv _a_pile)) && pilerep sigma (gv _a_pile).

Local Open Scope assert.

Definition Apile_add_spec :=
 DECLARE _Apile_add
 WITH n: Z, sigma: list Z, gv: globals
 PRE [ tint  ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (Vint (Int.repr n)) GLOBALS (gv)
    SEP(apile sigma gv; mem_mgr gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(apile (n::sigma) gv; mem_mgr gv).

Definition Apile_count_spec :=
 DECLARE _Apile_count
 WITH sigma: list Z, gv: globals
 PRE [  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    PARAMS () GLOBALS (gv)
    SEP(apile sigma gv; mem_mgr gv)
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(apile sigma gv; mem_mgr gv).

Definition ApileASI:funspecs := [ Apile_add_spec; Apile_count_spec].


(* Alumno: Agustín Mista *)
(* Fecha:        3/10/17 *)

(*
  Esta táctica elimina varios /\ a la vez, en goals de la forma:
       A1 ∧ A2 ∧ ... ∧ An
  generando un sub-goal para cada Ai.
*)
Ltac split_many :=
  match goal with
    |- _ => split; repeat try split
  end.

(* ------------------------------ *)
(*          Ejercicio 4           *)
(* ------------------------------ *)

Section Ejercicio3.
Variable A B C: Set.

Definition apply : (A -> B) -> A -> B :=
  fun f x => f x.

Definition o : (B -> C) -> (A -> B) -> (A -> C) :=
  fun f g x => f (g x).

Definition twice : (A -> A) -> A -> A :=
  fun f x => f (f x).

Definition apply' : forall X Y : Set, (X -> Y) -> X -> Y :=
  fun (X Y : Set) (f : X -> Y) (x : X) => f x.

Definition o' : forall X Y Z : Set, (Y -> Z) -> (X -> Y) -> (X -> Z) :=
  fun (X Y Z : Set) (f : Y -> Z) (g : X -> Y) (x : X) => f (g x).

Definition twice' : forall X : Set, (X -> X) -> X -> X :=
  fun (X : Set) (f : X -> X) (x : X) => f (f x).

End Ejercicio3.

Section Ejercicio4.

Variable A: Set.

Definition id : A -> A := fun (x : A) => x.

Theorem e4 : forall x : A, (o A A A id id) x = id x.
Proof. reflexivity. Qed.

Theorem e4' : forall x : A, (o A A A id id) x = id x.
Proof. reflexivity. Qed.

Theorem e4'' : forall x : A, (o A A A id id) x = id x.
Proof. reflexivity. Qed.

End Ejercicio4.

(* ------------------------------ *)
(*          Ejercicio 5           *)
(* ------------------------------ *)

Section Ejercicio5.

(* 5.1 *)
Definition opI : forall A : Set, A -> A
    := id.

Definition opK : forall A B : Set, A -> B -> A
  := fun (A B : Set) (a : A) (b : B) => a.

Definition opS : forall A B C : Set, (A -> B -> C) -> (A -> B) -> A -> C
  := fun (A B C : Set) (f : A -> B -> C) (g : A -> B) (x : A) => f x (g x).

(* 5.2 *)
(* Para formalizar el siguiente lema, determine los tipos ?1 ... ?8 adecuados *)
Lemma e52 : forall A B : Set, opS A (B -> A) A (opK A (B -> A)) (opK A B) = opI A.
Proof. reflexivity. Qed.

End Ejercicio5.

(* ------------------------------ *)
(*          Ejercicio 10          *)
(* ------------------------------ *)

Section Ejercicio10.

Parameter Array : Set -> nat -> Set.
Parameter emptyA : forall X : Set, Array X 0.
Parameter addA : forall (X : Set) (n : nat), X -> Array X n -> Array X (S n).

Parameter Matrix : Set -> nat -> Set.
Parameter emptyM : forall X : Set, Matrix X 0.
Parameter addM : forall (X : Set) (n : nat),
    Matrix X n -> Array X (n + 1) -> Matrix X (n + 1).

Definition M1 := addM nat 0 (emptyM nat) (addA nat 0 3 (emptyA nat)).
Definition M2 := addM nat 1 M1 (addA nat 1 2 (addA nat 0 3 (emptyA nat))).
Definition M3 := addM nat 2 M2 (addA nat 2 1 (addA nat 1 2 (addA nat 0 3 (emptyA nat)))).

Check M3.

End Ejercicio10.

(* ------------------------------ *)
(*          Ejercicio 11          *)
(* ------------------------------ *)

Section Ejercicio11.

Parameter AVLNat : forall n : nat, Set.

(* 11.1 *)
Parameter emptyAVL : AVLNat 0.

(* 11.2 *)
Parameter addAVL_eq : forall n, AVLNat n -> nat -> AVLNat n -> AVLNat (n + 1).
Parameter addAVL_lt : forall n, AVLNat n -> nat -> AVLNat (n + 1) -> AVLNat (n + 1).
Parameter addAVL_gt : forall n, AVLNat (n + 1) -> nat -> AVLNat n -> AVLNat (n + 1).

(* 11.3 *)
Definition avl : AVLNat 2
  := addAVL_eq 1
       (addAVL_eq 0 emptyAVL 2 emptyAVL)
       1
       (addAVL_eq 0 emptyAVL 3 emptyAVL).

(* 11.4 *)
Parameter AVL : forall (T : Type) (n : nat), Set.
Parameter emptyAVL' : forall (T : Type), AVL T 0.
Parameter addAVL_eq' : forall T n, AVL T n -> T -> AVL T n -> AVL T (n + 1).
Parameter addAVL_lt' : forall T n, AVL T n -> T -> AVL T (n + 1) -> AVL T (n + 1).
Parameter addAVL_gt' : forall T n, AVL T (n + 1) -> T -> AVL T n -> AVL T (n + 1).

End Ejercicio11.

(* ------------------------------ *)
(*          Ejercicio 15          *)
(* ------------------------------ *)

Section Ejercicio15.

Variable U : Set.
Variable e : U.
Variable A B : U -> Prop.
Variable P : Prop.
Variable R : U -> U -> Prop.

Lemma Ej315_1 : (forall x : U, A x -> B x) -> (forall x : U, A x)
                -> forall x : U, B x.
Proof.
  intros. exact (H x (H0 x)).
Qed.

Lemma Ej315_2 : forall x : U, A x -> ~ (forall x : U, ~ A x).
Proof.
  unfold not.
  intros. exact (H0 x H).
Qed.

Lemma Ej315_3 : (forall x : U, P -> A x) -> P -> forall x : U, A x.
Proof. intros. exact (H x H0). Qed.

Lemma Ej315_4 : (forall x y : U, R x y) -> forall x : U, R x x.
Proof. intros. exact (H x x). Qed.

Lemma Ej315_5 : (forall x y: U, R x y -> R y x) -> forall z : U, R e z -> R z e.
Proof. intros. exact (H e z H0). Qed.

End Ejercicio15.


(***************************************************************************
* Safety for Simply Typed Lambda Calculus (CBV) - Proofs                   *
* Brian Aydemir & Arthur Charguéraud, July 2007, Coq v8.1                  *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory
  STLC_Core_Definitions
  STLC_Core_Infrastructure.

(* ********************************************************************** *)
(** * Proofs *)

(** Typing is preserved by weakening. *)

Lemma typing_weaken : forall G E F t T,
   (E & G) |= t ~: T ->
   ok (E & F & G) ->
   (E & F & G) |= t ~: T.
Proof.
  introv Typ. gen_eq (E & G) as H. gen G.
  induction Typ; introv EQ Ok; subst.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs as y. apply_ih_bind* H0.
  apply* typing_app.
Qed.

(** Typing is preserved by substitution. *)

Lemma typing_subst : forall F U E t T z u,
  (E & z ~ U & F) |= t ~: T ->
  E |= u ~: U ->
  (E & F) |= [z ~> u]t ~: T.
Proof.
  introv Typt Typu. gen_eq (E & z ~ U & F) as G. gen F.
  induction Typt; introv Equ; subst; simpl subst.
  case_var.
    binds_get H0. apply_empty* typing_weaken.
    binds_cases H0; apply* typing_var.
  apply_fresh typing_abs as y.
   rewrite* subst_open_var. apply_ih_bind* H0.
  apply* typing_app.
Qed.

(** Preservation (typing is preserved by reduction). *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen t'.
  induction Typ; introv Red; inversions Red.
  inversions Typ1. pick_fresh x. rewrite* (@subst_intro x).
   apply_empty* typing_subst.
  apply* typing_app.
  apply* typing_app.
Qed.

(** Progress (a well-typed term is either a value or it can
  take a step of reduction). *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq (empty : env) as E. poses Typ' Typ.
  induction Typ; intros; subst.
  contradictions.
  left*.
  right. destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    destruct~ IHTyp2 as [Val2 | [t2' Red2]].
      inversions Typ1; inversions Val1. exists* (t0 ^^ t2).
      exists* (trm_app t1 t2').
    exists* (trm_app t1' t2).
Qed.


Require Import Coq.Arith.Arith.

Require Import Axioms.

Require Import Tactics.
Require Import Sigma.
Require Import Equality.
Require Import Ordinal.
Require Import Page.

Import List.ListNotations.

Section object.

Variable object : Type.

Inductive operator : list nat -> Type :=
| oper_univ        : operator [0]
| oper_cty         : operator [0]
| oper_con         : operator [0; 0]

| oper_karrow      : operator [0; 0]
| oper_arrow       : operator [0; 0]
| oper_pi          : operator [0; 1]
| oper_clam        : operator [0; 1]
| oper_capp        : operator [0; 0]
| oper_ctlam       : operator [0; 1; 0]
| oper_ctapp       : operator [0; 0]
| oper_lam         : operator [1]
| oper_app         : operator [0; 0]

| oper_intersect   : operator [0; 1]

| oper_fut         : operator [0]
| oper_cnext       : operator [0]
| oper_cprev       : operator [0]
| oper_next        : operator [0]
| oper_prev        : operator [0]

| oper_rec         : operator [1]

| oper_equal       : operator [0; 0; 0]
| oper_triv        : operator nil

| oper_eqtype      : operator [0; 0]

| oper_subtype     : operator [0; 0]

| oper_kuniv       : operator [0]

| oper_all         : operator [0; 0; 1]
| oper_alltp       : operator [1]

| oper_exist       : operator [0; 0; 1]

| oper_mu          : operator [1]
| oper_ispositive  : operator [1]
| oper_isnegative  : operator [1]

| oper_voidtp      : operator nil

| oper_unittp      : operator nil
| oper_cunit       : operator nil

| oper_booltp      : operator nil
| oper_btrue       : operator nil
| oper_bfalse      : operator nil
| oper_bite        : operator [0; 0; 0]

| oper_prod        : operator [0; 0]
| oper_sigma       : operator [0; 1]
| oper_cpair       : operator [0; 0]
| oper_cpi1        : operator [0]
| oper_cpi2        : operator [0]
| oper_ppair       : operator [0; 0]
| oper_ppi1        : operator [0]
| oper_ppi2        : operator [0]

| oper_set         : operator [0; 1]

| oper_quotient    : operator [0; 2]

| oper_guard       : operator [0; 0]

| oper_wt          : operator [0; 1]

(* Candidates used for impredicative quantification. *)
| oper_ext         : object -> operator nil

(* Degenerate candidates used for inductive types. *)
| oper_extt        : object -> operator nil
.

Inductive term : Type :=
| var : nat -> term
| oper : forall a, operator a -> row a -> term

with row : list nat -> Type :=
| rw_nil : row nil
| rw_cons : forall i a, term -> row a -> row (i :: a)
.

Scheme term_mut_ind := Induction for term Sort Prop
with   row_mut_ind := Induction for row Sort Prop.
Combined Scheme syntax_ind from term_mut_ind, row_mut_ind.

Scheme term_mut_rect := Induction for term Sort Type
with   row_mut_rect := Induction for row Sort Type.

Lemma row_nil_invert : forall (r : row nil), r = rw_nil.
Proof.
intros r.
apply eq_dep_impl_eq_snd.
set (a := nil) in r |- * at 1.
assert (a = nil) as Heq by reflexivity.
clearbody a.
revert Heq.
cases r; auto.
intros; discriminate.
Qed.

Lemma row_cons_invert :
  forall i a (r : row (cons i a)),
    exists m (s : row a),
      r = rw_cons i a m s.
Proof.
intros i a r.
cut (exists m s, eq_dep _ row (cons i a) r (cons i a) (rw_cons i a m s)).
  {
  intros (m & s & Heq).
  exists m, s.
  exact (eq_dep_impl_eq_snd _#5 Heq).
  }
set (b := cons i a) in r |- * at 1.
assert (b = cons i a) as Heq by reflexivity.
clearbody b.
revert Heq.
cases r; try (intros; discriminate).
intros i' a' m r Heq.
injection Heq.
intros -> ->.
exists m, r.
apply eq_dep_refl.
Qed.

Lemma row_invert_auto :
  forall a (r : row a),
    list_rect (fun a => (row a -> Prop) -> Prop)
      (fun P => P rw_nil)
      (fun i a IH P =>
         exists m,
           IH (fun r => P (rw_cons i a m r)))
      a
      (eq r).
Proof.
intros a.
induct a.

(* nil *)
{
intro r.
cbn.
apply row_nil_invert.
}

(* cons *)
{
intros i a IH rr.
cbn.
so (row_cons_invert _ _ rr) as (m & r & ->).
exists m.
force_exact (IH r).
f_equal.
fextensionality 1.
intro r'.
pextensionality.
  {
  intros <-; auto.
  }

  {
  intros Heq.
  injection Heq.
  intro H.
  injectionT H.
  auto.
  }
}
Qed.

Inductive hyp : Type :=
| hyp_tpl : hyp
| hyp_tp  : hyp
| hyp_tml : term -> hyp
| hyp_tm  : term -> hyp
| hyp_emp : hyp
.

Definition context := list hyp.

Inductive judgement : Type :=
| deq : (* tm *) term -> term -> (* cn *) term -> judgement
.

Fixpoint traverse (resolve : nat -> nat -> term) (i : nat) (m : term) {struct m} : term
  :=
  (match m with
   | var j => resolve i j
   | oper a t r => oper a t (traverse_row resolve i a r)
   end)

with traverse_row (resolve : nat -> nat -> term) (i : nat) (a : list nat) (r : row a) {struct r} : row a
  :=
  (match r
   in row a
   return row a
   with
   | rw_nil => rw_nil
   | rw_cons j a m r => rw_cons j a (traverse resolve (j+i) m) (traverse_row resolve i a r)
   end)
.

Lemma traverse_var :
  forall resolve i j,
    traverse resolve i (var j) = resolve i j.
Proof.
auto.
Qed.

Lemma traverse_oper :
  forall resolve i a t r,
    traverse resolve i (oper a t r)
    =
    oper a t (traverse_row resolve i a r).
Proof.
intros; reflexivity.
Qed.

Lemma traverse_row_cons :
  forall resolve i j a m r,
    traverse_row resolve i (cons j a) (rw_cons j a m r)
    =
    rw_cons j a
      (traverse resolve (j+i) m)
      (traverse_row resolve i a r).
Proof.
intros; reflexivity.
Qed.

Lemma traverse_row_nil :
  forall resolve i,
    traverse_row resolve i nil rw_nil = rw_nil.
Proof.
intros; reflexivity.
Qed.

Lemma traverse_parametric :
  forall (P : nat -> nat -> Prop) resolve resolve',
    (forall i i', P i i' -> P (S i) (S i'))
    -> (forall i i' j, P i i' -> resolve i j = resolve' i' j)
    -> forall i i' t, P i i' -> traverse resolve i t = traverse resolve' i' t.
Proof.
intros P resolve resolve' Pcomp.
revert resolve resolve'.
assert (forall j i i', P i i' -> P (j + i) (j + i')) as Hcomp'.
  intro j.
  induct j.
  (* 0 *)
  intros i i' H.
  exact H.

  (* S *)
  intros j IH i i' HP.
  simpl.
  auto; done.
intros resolve resolve' Hres i i' t.
revert t i i'.
apply
  (term_mut_ind
     (fun m => forall i i', P i i' -> traverse resolve i m = traverse resolve' i' m)
     (fun a r => forall i i', P i i' -> traverse_row resolve i a r = traverse_row resolve' i' a r));
try (intros; simpl; eauto; f_equal; eauto; done).
Qed.

Lemma traverse_id :
  forall resolve,
    (forall i j, resolve i j = var j)
    -> forall i t, traverse resolve i t = t.
Proof.
intros resolve Hres i m.
revert m i.
apply
  (term_mut_ind
     (fun m => forall i, traverse resolve i m = m)
     (fun a r => forall i, traverse_row resolve i a r = r));
intros; simpl; f_equal; eauto.
Qed.

Lemma traverse_compose :
  forall resolve resolve' i t,
    traverse resolve i (traverse resolve' i t)
    = traverse
      (fun i' j => traverse resolve i' (resolve' i' j))
      i t.
Proof.
intros resolve resolve' i m.
revert m i.
apply
  (term_mut_ind
     (fun m =>
        forall i,
          traverse resolve i (traverse resolve' i m)
          = traverse (fun i' j => traverse resolve i' (resolve' i' j)) i m)
     (fun a r =>
        forall i,
          traverse_row resolve i a (traverse_row resolve' i a r)
          = traverse_row (fun i' j => traverse resolve i' (resolve' i' j)) i a r));
intros; simpl; f_equal; eauto.
Qed.

(* Obsolete *)
Ltac invert_row_cons r :=
match type of r with
| row ?a =>
    let i := fresh "i"
    in let x := fresh "a"
    in let m := fresh "m"
    in let Heq := fresh "Heq"
    in
      remember a as x eqn:Heq in r;
      revert Heq;
      cases r; [intro Heq; discriminate Heq |];
      intros i' x m r Heq;
      injection Heq;
      clear Heq;
      intros -> ->;
      revert m r
end.

(* Obsolete *)
Ltac invert_row_nil r :=
let x := fresh "a"
in let Heq := fresh "Heq"
in
  remember (@nil nat) as x eqn:Heq in r;
  revert Heq;
  cases r; [| intros ? ? ? ? Heq; discriminate Heq];
  intros _.

Inductive Forallr (P : term -> Type) : forall a, row a -> Type :=
| Forallr_nil
    : Forallr P nil rw_nil

| Forallr_cons {i a m r}
    : P m
      -> Forallr P a r
      -> Forallr P (cons i a) (rw_cons i a m r)
.

Lemma term_row_rect :
  forall (P : term -> Type),
    (forall i, P (var i))
    -> (forall a t r, Forallr P a r -> P (oper a t r))
    -> forall m, P m.
Proof.
intros P H1 H2 m.
apply (term_mut_rect P (Forallr P)); eauto using Forallr.
Qed.

Lemma oper_injection :
  forall a t t' r r',
    oper a t r = oper a t' r'
    -> t = t' /\ r = r'.
Proof.
intros a t t' r r' Heq.
injection Heq.
intros Heqr Heqt.
destruct (eq_dep_impl_eq _#6 (EqdepFacts.eq_sigT_eq_dep _#6 Heqt)) as (h & Heqt').
substrefl h.
cbn in Heqt'.
destruct (eq_dep_impl_eq _#6 (EqdepFacts.eq_sigT_eq_dep _#6 Heqr)) as (h & Heqr').
substrefl h.
cbn in Heqr'.
auto.
Qed.

Lemma rw_cons_injection :
  forall j a m m' r r',
    rw_cons j a m r = rw_cons j a m' r'
    -> m = m' /\ r = r'.
Proof.
intros j a m m' r r' Heq.
injection Heq.
intros Heq' Heqm.
destruct (eq_dep_impl_eq _#6 (EqdepFacts.eq_sigT_eq_dep _#6 Heq')) as (h & Heq'').
substrefl h.
cbn in Heq''.
auto.
Qed.

(* obsolete *)
Lemma invertrow :
  forall l (r : row l),
    (fix P (l : list nat) : (row l -> Type) -> Type :=
       match l
         as l
         return (row l -> Type) -> Type
       with
       | nil => fun Q => Q rw_nil

       | cons a l' =>
           fun Q =>
             existsT x,
               P l' (fun r => Q (rw_cons _ _ x r))
       end)
    l (fun r' => r = r').
Proof.
intros l.
induct l.

(* nil *)
{
intro r.
cases r.
reflexivity.
}

(* cons *)
{
intros n a IH r.
cases r.
intros n' a' t r Heq.
injection Heq.
intros -> ->.
substrefl Heq.
exists t.
so (IH r) as H.
replace (fun r' => rw_cons n a t r = rw_cons n a t r') with (fun r' => r = r').
2:{
  fextensionality 1.
  intro r''.
  pextensionality.
  - intro.
    subst r''.
    reflexivity.

  - intro Heq.
    injectionc Heq.
    intro Heq.
    eapply inj_pair2_UIP; eauto.
    intros; apply proof_irrelevance; done.
  }
exact H.
}
Qed.

End object.

Arguments var {object}.
Arguments oper {object}.
Arguments rw_nil {object}.
Arguments rw_cons {object}.

Arguments hyp {object}.
Arguments context {object}.
Arguments judgement {object}.

Definition univ {obj} m            : @term obj := oper _ (oper_univ _) (rw_cons _ _ m rw_nil).
Definition cty {obj} m             : @term obj := oper _ (oper_cty _) (rw_cons _ _ m rw_nil).
Definition con {obj} m1 m2         : @term obj := oper _ (oper_con _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition karrow {obj} m1 m2       : @term obj := oper _ (oper_karrow _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition arrow {obj} m1 m2       : @term obj := oper _ (oper_arrow _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition pi {obj} m1 m2          : @term obj := oper _ (oper_pi _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition clam {obj} m1 m2        : @term obj := oper _ (oper_clam _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition capp {obj} m1 m2        : @term obj := oper _ (oper_capp _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition ctlam {obj} m1 m2 m3  : @term obj := oper _ (oper_ctlam _) (rw_cons _ _ m1 (rw_cons _ _ m2 (rw_cons _ _ m3 rw_nil))).
Definition ctapp {obj} m1 m2       : @term obj := oper _ (oper_ctapp _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition lam {obj} m             : @term obj := oper _ (oper_lam _) (rw_cons _ _ m rw_nil).
Definition app {obj} m1 m2         : @term obj := oper _ (oper_app _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition intersect {obj} m1 m2   : @term obj := oper _ (oper_intersect _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition fut {obj} m             : @term obj := oper _ (oper_fut _) (rw_cons _ _ m rw_nil).
Definition cnext {obj} m           : @term obj := oper _ (oper_cnext _) (rw_cons _ _ m rw_nil).
Definition cprev {obj} m           : @term obj := oper _ (oper_cprev _) (rw_cons _ _ m rw_nil).
Definition next {obj} m            : @term obj := oper _ (oper_next _) (rw_cons _ _ m rw_nil).
Definition prev {obj} m            : @term obj := oper _ (oper_prev _) (rw_cons _ _ m rw_nil).
Definition rec {obj} m             : @term obj := oper _ (oper_rec _) (rw_cons _ _ m rw_nil).
Definition equal {obj} m1 m2 m3    : @term obj := oper _ (oper_equal _) (rw_cons _ _ m1 (rw_cons _ _ m2 (rw_cons _ _ m3 rw_nil))).
Definition triv {obj}              : @term obj := oper _ (oper_triv _) rw_nil.
Definition eqtype {obj} m1 m2      : @term obj := oper _ (oper_eqtype _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition subtype {obj} m1 m2     : @term obj := oper _ (oper_subtype _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition kuniv {obj} m           : @term obj := oper _ (oper_kuniv _) (rw_cons _ _ m rw_nil).
Definition all {obj} m1 m2 m3      : @term obj := oper _ (oper_all _) (rw_cons _ _ m1 (rw_cons _ _ m2 (rw_cons _ _ m3 rw_nil))).
Definition alltp {obj} m1          : @term obj := oper _ (oper_alltp _) (rw_cons _ _ m1 rw_nil).
Definition exist {obj} m1 m2 m3    : @term obj := oper _ (oper_exist _) (rw_cons _ _ m1 (rw_cons _ _ m2 (rw_cons _ _ m3 rw_nil))).
Definition mu {obj} m              : @term obj := oper _ (oper_mu _) (rw_cons _ _ m rw_nil).
Definition ispositive {obj} m      : @term obj := oper _ (oper_ispositive _) (rw_cons _ _ m rw_nil).
Definition isnegative {obj} m      : @term obj := oper _ (oper_isnegative _) (rw_cons _ _ m rw_nil).
Definition voidtp {obj}            : @term obj := oper _ (oper_voidtp _) rw_nil.
Definition unittp {obj}            : @term obj := oper _ (oper_unittp _) rw_nil.
Definition cunit {obj}             : @term obj := oper _ (oper_cunit _) rw_nil.
Definition booltp {obj}            : @term obj := oper _ (oper_booltp _) rw_nil.
Definition btrue {obj}             : @term obj := oper _ (oper_btrue _) rw_nil.
Definition bfalse {obj}            : @term obj := oper _ (oper_bfalse _) rw_nil.
Definition bite {obj} m1 m2 m3     : @term obj := oper _ (oper_bite _) (rw_cons _ _ m1 (rw_cons _ _ m2 (rw_cons _ _ m3 rw_nil))).
Definition prod {obj} m1 m2        : @term obj := oper _ (oper_prod _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition sigma {obj} m1 m2       : @term obj := oper _ (oper_sigma _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition cpair {obj} m1 m2       : @term obj := oper _ (oper_cpair _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition cpi1 {obj} m            : @term obj := oper _ (oper_cpi1 _) (rw_cons _ _ m rw_nil).
Definition cpi2 {obj} m            : @term obj := oper _ (oper_cpi2 _) (rw_cons _ _ m rw_nil).
Definition ppair {obj} m1 m2       : @term obj := oper _ (oper_ppair _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition ppi1 {obj} m            : @term obj := oper _ (oper_ppi1 _) (rw_cons _ _ m rw_nil).
Definition ppi2 {obj} m            : @term obj := oper _ (oper_ppi2 _) (rw_cons _ _ m rw_nil).
Definition set {obj} m1 m2         : @term obj := oper _ (oper_set _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition quotient {obj} m1 m2    : @term obj := oper _ (oper_quotient _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition guard {obj} m1 m2       : @term obj := oper _ (oper_guard _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition wt {obj} m1 m2          : @term obj := oper _ (oper_wt _) (rw_cons _ _ m1 (rw_cons _ _ m2 rw_nil)).
Definition ext {obj} x             : @term obj := oper _ (oper_ext _ x) rw_nil.
Definition extt {obj} x            : @term obj := oper _ (oper_extt _ x) rw_nil.

Definition deqtype {object} a b := @deq object triv triv (eqtype a b).
Definition dsubtype {object} a b := @deq object triv triv (subtype a b).

Arguments hyp_tpl  {object}.
Arguments hyp_tp {object}.
Arguments hyp_tml {object}.
Arguments hyp_tm {object}.
Arguments hyp_emp {object}.
Arguments deq {object}.

(* The choice here is arbitrary.  Any value would do. *)
Definition arb {object} := @triv object.

Inductive same_operator {A B : Type} : forall a b, operator A a -> operator B b -> Prop :=
| same_univ :
    same_operator [0] [0] (oper_univ A) (oper_univ B)

| same_cty :
    same_operator [0] [0] (oper_cty A) (oper_cty B)

| same_con :
    same_operator [0; 0] [0; 0] (oper_con A) (oper_con B)

| same_karrow :
    same_operator [0; 0] [0; 0] (oper_karrow A) (oper_karrow B)

| same_arrow :
    same_operator [0; 0] [0; 0] (oper_arrow A) (oper_arrow B)

| same_pi :
    same_operator [0; 1] [0; 1] (oper_pi A) (oper_pi B)

| same_clam :
    same_operator [0; 1] [0; 1] (oper_clam A) (oper_clam B)

| same_capp :
    same_operator [0; 0] [0; 0] (oper_capp A) (oper_capp B)

| same_ctlam :
    same_operator [0; 1; 0] [0; 1; 0] (oper_ctlam A) (oper_ctlam B)

| same_ctapp :
    same_operator [0; 0] [0; 0] (oper_ctapp A) (oper_ctapp B)

| same_lam :
    same_operator [1] [1] (oper_lam A) (oper_lam B)

| same_app :
    same_operator [0; 0] [0; 0] (oper_app A) (oper_app B)

| same_intersect :
    same_operator [0; 1] [0; 1] (oper_intersect A) (oper_intersect B)

| same_fut :
    same_operator [0] [0] (oper_fut A) (oper_fut B)

| same_cnext :
    same_operator [0] [0] (oper_cnext A) (oper_cnext B)

| same_cprev :
    same_operator [0] [0] (oper_cprev A) (oper_cprev B)

| same_next :
    same_operator [0] [0] (oper_next A) (oper_next B)

| same_prev :
    same_operator [0] [0] (oper_prev A) (oper_prev B)

| same_rec :
    same_operator [1] [1] (oper_rec A) (oper_rec B)

| same_equal :
    same_operator [0; 0; 0] [0; 0; 0] (oper_equal A) (oper_equal B)

| same_triv :
    same_operator nil nil (oper_triv A) (oper_triv B)

| same_eqtype :
    same_operator [0; 0] [0; 0] (oper_eqtype A) (oper_eqtype B)

| same_subtype :
    same_operator [0; 0] [0; 0] (oper_subtype A) (oper_subtype B)

| same_kuniv :
    same_operator [0] [0] (oper_kuniv A) (oper_kuniv B)

| same_all :
    same_operator [0; 0; 1] [0; 0; 1] (oper_all A) (oper_all B)

| same_alltp :
    same_operator [1] [1] (oper_alltp A) (oper_alltp B)

| same_exist :
    same_operator [0; 0; 1] [0; 0; 1] (oper_exist A) (oper_exist B)

| same_mu :
    same_operator [1] [1] (oper_mu A) (oper_mu B)

| same_ispositive :
    same_operator [1] [1] (oper_ispositive A) (oper_ispositive B)

| same_isnegative :
    same_operator [1] [1] (oper_isnegative A) (oper_isnegative B)

| same_voidtp :
    same_operator nil nil (oper_voidtp A) (oper_voidtp B)

| same_unittp :
    same_operator nil nil (oper_unittp A) (oper_unittp B)

| same_cunit :
    same_operator nil nil (oper_cunit A) (oper_cunit B)

| same_booltp :
    same_operator nil nil (oper_booltp A) (oper_booltp B)

| same_btrue :
    same_operator nil nil (oper_btrue A) (oper_btrue B)

| same_bfalse :
    same_operator nil nil (oper_bfalse A) (oper_bfalse B)

| same_bite :
    same_operator [0; 0; 0] [0; 0; 0] (oper_bite A) (oper_bite B)

| same_prod :
    same_operator [0; 0] [0; 0] (oper_prod A) (oper_prod B)

| same_sigma :
    same_operator [0; 1] [0; 1] (oper_sigma A) (oper_sigma B)

| same_cpair :
    same_operator [0; 0] [0; 0] (oper_cpair A) (oper_cpair B)

| same_cpi1 :
    same_operator [0] [0] (oper_cpi1 A) (oper_cpi1 B)

| same_cpi2 :
    same_operator [0] [0] (oper_cpi2 A) (oper_cpi2 B)

| same_ppair :
    same_operator [0; 0] [0; 0] (oper_ppair A) (oper_ppair B)

| same_ppi1 :
    same_operator [0] [0] (oper_ppi1 A) (oper_ppi1 B)

| same_ppi2 :
    same_operator [0] [0] (oper_ppi2 A) (oper_ppi2 B)

| same_set :
    same_operator [0; 1] [0; 1] (oper_set A) (oper_set B)

| same_quotient :
    same_operator [0; 2] [0; 2] (oper_quotient A) (oper_quotient B)

| same_guard :
    same_operator [0; 0] [0; 0] (oper_guard A) (oper_guard B)

| same_wt :
    same_operator [0; 1] [0; 1] (oper_wt A) (oper_wt B)

| same_ext {x y} :
    same_operator nil nil (oper_ext A x) (oper_ext B y)

| same_extt {x y} :
    same_operator nil nil (oper_extt A x) (oper_extt B y)
.

Hint Constructors same_operator : same_operator.