Add LoadPath "~/AU/Coq/coq-supplementary".

Require Import List.
Import ListNotations.
Require Import Omega.

Require Export BigZ.
Require Export Id.
Require Export State.
Require Export Expr.

(* The type of statements *)
Inductive stmt : Type :=
  | SKIP  : stmt
  | Assn  : id -> expr -> stmt
  | READ  : id -> stmt
  | WRITE : expr -> stmt
  | Seq   : stmt -> stmt -> stmt
  | If    : expr -> stmt -> stmt -> stmt
  | While : expr -> stmt -> stmt.

(* Supplementary notation *)
Notation "x  '::=' e"                         := (Assn  x e    ) (at level 37, no associativity).
Notation "s1 ';;'  s2"                        := (Seq   s1 s2  ) (at level 35, right associativity).
Notation "'COND' e 'THEN' s1 'ELSE' s2 'END'" := (If    e s1 s2) (at level 36, no associativity).
Notation "'WHILE' e 'DO' s 'END'"             := (While e s    ) (at level 36, no associativity).

(* Configuration *)
Definition conf :=  (state Z * list Z * list Z)%type.

Reserved Notation "c1 '==' s '==>' c2" (at level 0).

(* Big-step evaluation relation *)
Notation "st [ x '<-' y ]" := (update Z st x y) (at level 0).

Inductive bs_int : stmt -> conf -> conf -> Prop :=
  | bs_Skip        : forall (c : conf), c == SKIP ==> c
  | bs_Assign      : forall (s : state Z) (i o : list Z) (x : id) (e : expr) (z : Z),
                       [| e |] s => z -> (s, i, o) == x ::= e ==> (s [x <- z], i, o)
  | bs_Read        : forall (s : state Z) (i o : list Z) (x : id) (z : Z),
                       (s, z::i, o) == READ x ==> (s [x <- z], i, o)
  | bs_Write       : forall (s : state Z) (i o : list Z) (e : expr) (z : Z),
                       [| e |] s => z -> (s, i, o) == WRITE e ==> (s, i, z::o)
  | bs_Seq         : forall (c c' c'' : conf) (s1 s2 : stmt),
                       c == s1 ==> c' -> c' == s2 ==> c'' -> c ==  s1 ;; s2 ==> c''
  | bs_If_True     : forall (s : state Z) (i o : list Z) (c' : conf) (e : expr) (s1 s2 : stmt),
                       [| e |] s => Z.one -> (s, i, o) == s1 ==> c' -> (s, i, o) == COND e THEN s1 ELSE s2 END ==> c'
  | bs_If_False    : forall (s : state Z) (i o : list Z) (c' : conf) (e : expr) (s1 s2 : stmt),
                       [| e |] s => Z.zero -> (s, i, o) == s2 ==> c' -> (s, i, o) == COND e THEN s1 ELSE s2 END ==> c'
  | bs_While_True  : forall (st : state Z) (i o : list Z) (c' c'' : conf) (e : expr) (s : stmt),
                       [| e |] st => Z.one -> (st, i, o) == s ==> c' -> c' == WHILE e DO s END ==> c'' ->
                          (st, i, o) == WHILE e DO s END ==> c''
  | bs_While_False : forall (st : state Z) (i o : list Z) (e : expr) (s : stmt),
                       [| e |] st => Z.zero -> (st, i, o) == WHILE e DO s END ==> (st, i, o)
where "c1 == s ==> c2" := (bs_int s c1 c2).

(* Big-step semantics is deterministic *)
Lemma bs_int_deterministic : forall (c c1 c2 : conf) (s : stmt), c == s ==> c1 -> c == s ==> c2 -> c1 = c2.
Proof.
  assert (zero_one_contra: forall (e : expr) (s : state Z) (P : Prop),
                              [|e|] s => (Z.zero) -> [|e|] s => (Z.one) -> P).
  { intros. assert (contra: Z.zero = Z.one).
    * apply bs_eval_deterministic with (e := e) (s := s). auto. auto.
    * inversion contra. }
  intros c c1 c2 s FH. generalize dependent c2. induction FH.
  - intros. inversion H. reflexivity.
  - intros. inversion H0. replace z0 with z.
    + reflexivity.
    + apply bs_eval_deterministic with (e := e) (s := s). auto. auto.
  - intros. inversion H. reflexivity.
  - intros. inversion H0. replace z0 with z.
    + reflexivity.
    + apply bs_eval_deterministic with (e := e) (s := s). auto. auto.
  - intros. inversion H.
    assert (c'eq: c'= c'0). { apply IHFH1. auto. } rewrite <- c'eq in H5.
    apply IHFH2. auto.
  - intros. inversion H0.
    + apply IHFH. auto.
    + apply zero_one_contra with (e := e) (s := s). auto. auto.
  - intros. inversion H0.
    + apply zero_one_contra with (e := e) (s := s). auto. auto.
    + apply IHFH. auto.
  - intros. inversion H0.
    + assert (c'eq: c'= c'0). { apply IHFH1. auto. } rewrite <- c'eq in H9.
      apply IHFH2. auto.
    + apply zero_one_contra with (e := e) (s := st). auto. auto.
  - intros. inversion H0.
    + apply zero_one_contra with (e := e) (s := st). auto. auto.
    + reflexivity.
Qed.

Reserved Notation "s1 '~~~' s2" (at level 0).

Inductive bs_equivalent: stmt -> stmt -> Prop :=
  bs_eq_intro: forall (s1 s2 : stmt),
                 (forall (c c' : conf), c == s1 ==> c' <-> c == s2 ==> c') -> s1 ~~~ s2
where "s1 '~~~' s2" := (bs_equivalent s1 s2).

Module SmokeTest.

  Lemma seq_assoc : forall (s1 s2 s3 : stmt),
                      ((s1 ;; s2) ;; s3) ~~~ (s1 ;; (s2 ;; s3)).
  Proof.
    intros. apply bs_eq_intro. intros. split.
    - intros. inversion H. inversion H2. apply bs_Seq with (c' := c'1).
      auto. apply bs_Seq with (c' := c'0). auto. auto.
    - intros. inversion H. inversion H5. apply bs_Seq with (c' := c'1).
      apply bs_Seq with (c' := c'0). auto. auto. auto.
  Qed.

  Lemma while_unfolds : forall (e : expr) (s : stmt),
                          (WHILE e DO s END) ~~~ (COND e THEN s ;; WHILE e DO s END ELSE SKIP END).
  Proof.
    intros. apply bs_eq_intro. intros. split.
    - intros. inversion H.
      + apply bs_If_True. auto. apply bs_Seq with (c' := c'0). auto. auto.
      + apply bs_If_False. auto. apply bs_Skip.
    - intros. inversion H.
      + inversion H6. apply bs_While_True with (c' := c'1). auto. auto. auto.
      + inversion H6. apply bs_While_False. auto.
  Qed.

  Lemma while_false : forall (e : expr) (s : stmt) (st : state Z) (i o : list Z) (c : conf),
                        c == WHILE e DO s END ==> (st, i, o) -> [| e |] st => Z.zero.
  Proof.
    intros. remember (WHILE e DO s END) as instr. remember (st, i, o) as c'. induction H.
    - inversion Heqinstr.
    - inversion Heqinstr.
    - inversion Heqinstr.
    - inversion Heqinstr.
    - inversion Heqinstr.
    - inversion Heqinstr.
    - inversion Heqinstr.
    - inversion Heqinstr. apply IHbs_int2. auto. auto.
    - inversion Heqinstr. inversion Heqc'. congruence.
  Qed.

  Definition True := Nat 1.

  Lemma loop_eq_undefined : (WHILE True DO SKIP END) ~~~ (COND (Nat 3) THEN SKIP ELSE SKIP END).
  Proof.
    constructor. intros. split.
    - intros. exfalso. remember (WHILE True DO SKIP END). induction H.
      + inversion Heqs.
      + inversion Heqs.
      + inversion Heqs.
      + inversion Heqs.
      + inversion Heqs.
      + inversion Heqs.
      + inversion Heqs.
      + auto.
      + inversion Heqs. rewrite H1 in H. inversion H.
    - intros. inversion H.
      + inversion H5.
      + inversion H5.
Qed.

End SmokeTest.

(* Contextual equivalence *)
Inductive Context : Type :=
| Hole
| SeqL   : Context -> stmt -> Context
| SeqR   : stmt -> Context -> Context
| IfThen : expr -> Context -> stmt -> Context
| IfElse : expr -> stmt -> Context -> Context
| WhileC : expr -> Context -> Context.

(* Plugging a statement into a context *)
Fixpoint plug (C : Context) (s : stmt) : stmt :=
  match C with
  | Hole => s
  | SeqL     C  s1 => Seq (plug C s) s1
  | SeqR     s1 C  => Seq s1 (plug C s)
  | IfThen e C  s1 => If e (plug C s) s1
  | IfElse e s1 C  => If e s1 (plug C s)
  | WhileC   e  C  => While e (plug C s)
  end.

Notation "C '<~' e" := (plug C e) (at level 43, no associativity).

(* Contextual equivalence *)
Reserved Notation "e1 '~c~' e2" (at level 42, no associativity).

Inductive contextual_equivalent: stmt -> stmt -> Prop :=
  ceq_intro : forall (s1 s2 : stmt),
                (forall (C : Context), (C <~ s1) ~~~ (C <~ s2)) -> s1 ~c~ s2
where "s1 '~c~' s2" := (contextual_equivalent s1 s2).

(* Ltac siin h := simpl in h.

Ltac rew h := rewrite h.

Ltac rev_rew h := rewrite <- h.

Ltac on_plug s t1 t2 :=
  match goal with
  | H: (_ = _ <~ s) |- _ => (t1 H; t2 H)
  end. *)

Lemma eq_to_ceq: forall (s1 s2 p1 p2 : stmt) (C : Context) (c c' : conf),
  c == p1 ==> c' -> p1 = C <~ s1 -> p2 = C <~ s2 ->
    (forall (c0 c1 : conf), c0 == s1 ==> c1 -> c0 == s2 ==> c1) -> c == p2 ==> c'.
Proof.
  intros s1 s2 p1 p2 C c c' H. revert s1 s2 p2 C. induction H.
  - intros. destruct C.
    + (match goal with H: (p2 = _ <~ _) |- _ => simpl in H; rewrite H end).
      (match goal with H: (forall _ _ : conf, _ -> _) |- _ => apply H end).
      (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; rewrite <- H end).
      constructor.
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
  - intros. destruct C.
    + (match goal with H: (p2 = _ <~ _) |- _ => simpl in H; rewrite H end).
      (match goal with H: (forall _ _ : conf, _ -> _) |- _ => apply H end).
      (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; rewrite <- H end).
      constructor. assumption.
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
  - intros. destruct C.
    + (match goal with H: (p2 = _ <~ _) |- _ => simpl in H; rewrite H end).
      (match goal with H: (forall _ _ : conf, _ -> _) |- _ => apply H end).
      (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; rewrite <- H end).
      constructor.
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
  - intros. destruct C.
    + (match goal with H: (p2 = _ <~ _) |- _ => simpl in H; rewrite H end).
      (match goal with H: (forall _ _ : conf, _ -> _) |- _ => apply H end).
      (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; rewrite <- H end).
      constructor. assumption.
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
    + (match goal with H: (_ = _ <~ s1) |- _ => simpl in H; inversion H end).
  - intros. destruct C.
    + simpl in H2. rewrite H2. apply H3. simpl in H1. rewrite <- H1. apply bs_Seq with c'; assumption.
    + simpl in H2. rewrite H2. simpl in H1. inversion H1. apply bs_Seq with c'.
      * apply IHbs_int1 with (s2 := s0) (s3 := s3) (C := C); auto.
      * congruence.
    + simpl in H2. rewrite H2. simpl in H1. inversion H1. apply bs_Seq with c'.
      * congruence.
      * apply IHbs_int2 with (s1 := s0) (s3 := s3) (C := C); auto.
    + simpl in H1. inversion H1.
    + simpl in H1. inversion H1.
    + simpl in H1. inversion H1.
  - intros. destruct C.
    + simpl in H2. rewrite H2. apply H3. simpl in H1. rewrite <- H1. apply bs_If_True; assumption.
    + simpl in H1. inversion H1.
    + simpl in H1. inversion H1.
    + simpl in H2. rewrite H2. simpl in H1. inversion H1. apply bs_If_True.
      * congruence.
      * apply IHbs_int with (s2 := s0) (s3 := s3) (C := C); auto.
    + simpl in H2. rewrite H2. simpl in H1. inversion H1. apply bs_If_True; congruence.
    + simpl in H1. inversion H1.
  - intros. destruct C.
    + simpl in H2. rewrite H2. apply H3. simpl in H1. rewrite <- H1. apply bs_If_False; assumption.
    + simpl in H1. inversion H1.
    + simpl in H1. inversion H1.
    + simpl in H2. rewrite H2. simpl in H1. inversion H1. apply bs_If_False; congruence.
    + simpl in H2. rewrite H2. simpl in H1. inversion H1. apply bs_If_False.
      * congruence.
      * apply IHbs_int with (s1 := s0) (s3 := s3) (C := C); auto.
    + simpl in H1. inversion H1.
  - intros. destruct C.
    + simpl in H3. rewrite H3. apply H4. simpl in H2. rewrite <- H2. apply bs_While_True with c'; assumption.
    + simpl in H2. inversion H2.
    + simpl in H2. inversion H2.
    + simpl in H2. inversion H2.
    + simpl in H2. inversion H2.
    + simpl in H3. rewrite H3. simpl in H2. inversion H2. apply bs_While_True with c'.
      * congruence.
      * apply IHbs_int1 with (s1 := s1) (s2 := s2) (C := C); auto.
      * apply IHbs_int2 with (s1 := s1) (s2 := s2) (C := WhileC e C).
        { simpl. congruence. }
        { simpl. congruence. }
        { auto. }
  - intros. destruct C.
    + simpl in H1. rewrite H1. apply H2. simpl in H0. rewrite <- H0. apply bs_While_False; assumption.
    + simpl in H0. inversion H0.
    + simpl in H0. inversion H0.
    + simpl in H0. inversion H0.
    + simpl in H0. inversion H0.
    + simpl in H1. rewrite H1. simpl in H0. inversion H0. apply bs_While_False; congruence.
Qed.

(* Contextual equivalence is equivalent to the semantic one *)
Lemma eq_eq_ceq: forall (s1 s2 : stmt), s1 ~~~ s2 <-> s1 ~c~ s2.
Proof.
  intros. split.
  - intros. inversion_clear H. constructor. intros.
    constructor. intros. split.
    + intros. apply eq_to_ceq with s1 s2 (C <~ s1) C; auto. apply H0.
    + intros. apply eq_to_ceq with s2 s1 (C <~ s2) C; auto. apply H0.
  - intros. inversion_clear H. apply (H0 Hole).
Qed.

(* CPS-style semantics *)
Inductive cont : Type :=
| KEmpty : cont
| KStmt  : stmt -> cont.

Definition Kapp (l r : cont) : cont :=
  match (l, r) with
  | (KStmt ls, KStmt rs) => KStmt (ls ;; rs)
  | (KEmpty  , _       ) => r
  | (_       , _       ) => l
  end.

Notation "'!' s" := (KStmt s) (at level 0).
Notation "s1 @ s2" := (Kapp s1 s2) (at level 0).

Reserved Notation "k '|-' c1 '--' s '-->' c2" (at level 0).

Inductive cps_int : cont -> cont -> conf -> conf -> Prop :=
| cps_Empty       : forall (c : conf), KEmpty |- c -- KEmpty --> c
| cps_Skip        : forall (c c' : conf) (k : cont),
                      KEmpty |- c -- k --> c' ->
                      k |- c -- !SKIP --> c'
| cps_Assn        : forall (s : state Z) (i o : list Z) (c' : conf) (k : cont) (x : id) (e : expr) (n : Z),
                      [| e |] s => n ->
                      KEmpty |- (s [x <- n], i, o) -- k --> c' ->
                      k |- (s, i, o) -- !(x ::= e) --> c'
| cps_Read        : forall (s : state Z) (i o : list Z) (c' : conf) (k : cont) (x : id) (z : Z),
                      KEmpty |- (s [x <- z], i, o) -- k --> c' ->
                      k |- (s, z::i, o) -- !(READ x) --> c'
| cps_Write       : forall (s : state Z) (i o : list Z) (c' : conf) (k : cont) (e : expr) (z : Z),
                      [| e |] s => z ->
                      KEmpty |- (s, i, z::o) -- k --> c' ->
                      k |- (s, i, o) -- !(WRITE e) --> c'
| cps_Seq         : forall (c c' : conf) (k : cont) (s1 s2 : stmt),
                      !s2 @ k |- c -- !s1 --> c' ->
                      k |- c -- !(s1 ;; s2) --> c'
| cps_If_True     : forall (s : state Z) (i o : list Z) (c' : conf) (k : cont) (e : expr) (s1 s2 : stmt),
                      [| e |] s => Z.one ->
                      k |- (s, i, o) -- !s1 --> c' ->
                      k |- (s, i, o) -- !(COND e THEN s1 ELSE s2 END) --> c'
| cps_If_False    : forall (s : state Z) (i o : list Z) (c' : conf) (k : cont) (e : expr) (s1 s2 : stmt),
                      [| e |] s => Z.zero ->
                      k |- (s, i, o) -- !s2 --> c' ->
                      k |- (s, i, o) -- !(COND e THEN s1 ELSE s2 END) --> c'
| cps_While_True  : forall (st : state Z) (i o : list Z) (c' : conf) (k : cont) (e : expr) (s : stmt),
                      [| e |] st => Z.one ->
                      !(WHILE e DO s END) @ k |- (st, i, o) -- !s --> c' ->
                      k |- (st, i, o) -- !(WHILE e DO s END) --> c'
| cps_While_False : forall (st : state Z) (i o : list Z) (c' : conf) (k : cont) (e : expr) (s : stmt),
                      [| e |] st => Z.zero ->
                      KEmpty |- (st, i, o) -- k --> c' ->
                      k |- (st, i, o) -- !(WHILE e DO s END) --> c'
where "k |- c1 -- s --> c2" := (cps_int k s c1 c2).

Lemma bs_int_to_cps_int_segment: forall (c c' c'' : conf) (s : stmt) (k : cont),
  c == s ==> c' -> KEmpty |- c' -- k --> c'' -> k |- c -- !s --> c''.
Proof.
  intros c c' c'' s k H. revert c'' k. induction H.
  - intros. apply cps_Skip. assumption.
  - intros. apply cps_Assn with z. assumption. assumption.
  - intros. apply cps_Read. assumption.
  - intros. apply cps_Write with z. assumption. assumption.
  - intros. apply cps_Seq. apply IHbs_int1. unfold Kapp. destruct k.
    + inversion H1. apply IHbs_int2. rewrite H5. apply cps_Empty.
    + apply cps_Seq. unfold Kapp. apply IHbs_int2. assumption.
  - intros. apply cps_If_True. assumption. apply IHbs_int. assumption.
  - intros. apply cps_If_False. assumption. apply IHbs_int. assumption.
  - intros. apply cps_While_True. assumption. apply IHbs_int1. unfold Kapp. destruct k.
    + inversion H2. apply IHbs_int2. rewrite H6. apply cps_Empty.
    + apply cps_Seq. unfold Kapp. apply IHbs_int2. assumption.
  - intros. apply cps_While_False. assumption. assumption.
Qed.

Lemma bs_int_to_cps_int: forall (st : state Z) (i o : list Z) (c' : conf) (s : stmt),
  (st, i, o) == s ==> c' -> KEmpty |- (st, i, o) -- !s --> c'.
Proof.
  intros. apply bs_int_to_cps_int_segment with c'. assumption. constructor.
Qed.

Lemma bs_int_to_cps_int_gen: forall (c c' : conf) (s s_all : stmt) (k : cont),
  k |- c -- !s --> c' -> !s_all = !s @ k ->  c == s_all ==> c'.
Proof.
  intros c c' s s_all k H. revert s_all. induction H.
  - unfold Kapp. intros. inversion H.
  - unfold Kapp. destruct k.
    + inversion H. intros. inversion H0. apply bs_Skip.
    + intros. inversion H0. apply bs_Seq with c. apply bs_Skip. apply IHcps_int.
      unfold Kapp. reflexivity.
  - unfold Kapp. destruct k.
    + inversion H0. intros. inversion H1. apply bs_Assign. assumption.
    + intros. inversion H1. apply bs_Seq with ((s0) [x <- n], i, o).
      apply bs_Assign. assumption. apply IHcps_int. unfold Kapp. reflexivity.
  - unfold Kapp. destruct k.
    + inversion H. intros. inversion H0. apply bs_Read.
    + intros. inversion H0. apply bs_Seq with ((s0) [x <- z], i, o).
      apply bs_Read. apply IHcps_int. unfold Kapp. reflexivity.
  - unfold Kapp. destruct k.
    + inversion H0. intros. inversion H1. apply bs_Write. assumption.
    + intros. inversion H1. apply bs_Seq with (s0, i, z :: o).
      apply bs_Write. assumption. apply IHcps_int. unfold Kapp. reflexivity.
  - unfold Kapp. destruct k.
    + intros. apply IHcps_int. unfold Kapp. apply H0.
    + intros. inversion H0. assert ((c) == s1;; s2;; s0 ==> (c')).
      { apply IHcps_int. unfold Kapp. reflexivity. }
      inversion H1. inversion H8. apply bs_Seq with c'1.
      * apply bs_Seq with c'0. assumption. assumption.
      * assumption.
  - unfold Kapp. destruct k.
    + intros. inversion H1. apply bs_If_True. assumption. apply IHcps_int.
      unfold Kapp. reflexivity.
    + intros. inversion H1. assert ((s0, i, o) == s1 ;; s3 ==> c').
      { auto. }
      inversion H2. apply bs_Seq with c'0. apply bs_If_True.
      assumption. assumption. assumption.
  - unfold Kapp. destruct k.
    + intros. inversion H1. apply bs_If_False. assumption. apply IHcps_int.
      unfold Kapp. reflexivity.
    + intros. inversion H1. assert ((s0, i, o) == s2 ;; s3 ==> c').
      { auto. }
      inversion H2. apply bs_Seq with c'0. apply bs_If_False.
      assumption. assumption. assumption.
  - unfold Kapp. destruct k.
    + assert (((st, i, o)) == s0 ;; WHILE e DO s0 END ==> (c')).
      { apply IHcps_int. unfold Kapp. reflexivity. }
      intros. inversion H2. inversion H1. apply bs_While_True with c'0.
      assumption. assumption. assumption.
    + assert (((st, i, o)) == s0 ;; WHILE e DO s0 END ;; s1 ==> (c')).
      { apply IHcps_int. unfold Kapp. reflexivity. }
      inversion H1. inversion H7. intros. inversion H14. apply bs_Seq with c'1.
      * apply bs_While_True with c'0. assumption. assumption. assumption.
      * assumption.
  - unfold Kapp. destruct k.
    + inversion H0. intros. inversion H1. apply bs_While_False. assumption.
    + intros. inversion H1. apply bs_Seq with (st, i, o).
      * apply bs_While_False. assumption.
      * apply IHcps_int. unfold Kapp. reflexivity.
Qed.

Lemma cps_int_to_bs_int: forall (st : state Z) (i o : list Z) (c' : conf) (s : stmt),
  KEmpty |- (st, i, o) -- !s --> c' -> (st, i, o) == s ==> c'.
Proof. intros. apply bs_int_to_cps_int_gen with (s := s) (k := KEmpty).
       assumption. auto. Qed.


From Coqprime Require Import UList.
Require Import List.
Require Import Crypto.Util.Decidable.

Section UList.
  Variable T : Set.
  Hypothesis dec_eq : forall x y : T, {x = y} + {x <> y}.

  (*Proof copied from standard library, may be omitted in coq version 12. *)
  Lemma in_in_remove : forall l x y, x <> y -> In x l -> In x (remove dec_eq y l).
  Proof.
    induction l as [|z l]; simpl; intros x y Hneq Hin.
    - apply Hin.
    - destruct (dec_eq y z); subst.
      + destruct Hin.
        * exfalso; now apply Hneq.
        * now apply IHl.
      + simpl; destruct Hin; [now left|right].
        now apply IHl.
  Qed.

  (*Proof copied from standard library, may be omitted in coq version 12. *)
  Lemma in_remove : forall l x y, In x (remove dec_eq y l) -> In x l /\ x <> y.
  Proof.
    induction l as [|z l]; intros x y Hin.
    - inversion Hin.
    - simpl in Hin.
      destruct (dec_eq y z) as [Heq|Hneq]; subst; split.
      + right; now apply IHl with z.
      + intros Heq; revert Hin; subst; apply remove_In.
      + inversion Hin; subst; [left; reflexivity|right].
        now apply IHl with y.
      + destruct Hin as [Hin|Hin]; subst.
        * now intros Heq; apply Hneq.
        * intros Heq; revert Hin; subst; apply remove_In.
  Qed.

  (*Proof copied from standard library, may be omitted in coq version 12. *)
  Lemma notin_remove: forall l x, ~ In x l -> remove dec_eq x l = l.
  Proof.
    intros l x; induction l as [|y l]; simpl; intros Hnin.
    - reflexivity.
    - destruct (dec_eq x y); subst; intuition.
      f_equal; assumption.
  Qed.

  Lemma remove_cons : forall x l, remove dec_eq x (x :: l) = remove dec_eq x l.
  Proof.
    intros x l; simpl; destruct (dec_eq x x); [ reflexivity | now exfalso ].
  Qed.

  Lemma incl_rem : forall l m x, incl m l -> incl (remove dec_eq x m) l.
  Proof. intros l m x H; intros a Ha; apply H; apply in_remove in Ha; destruct Ha; auto. Qed.

  Lemma incl_rem_l_l : forall l x, incl (remove dec_eq x l) l.
  Proof. intros l x; apply incl_rem, incl_refl. Qed.

  Import ListNotations.

  Lemma ulist_rem : forall l x, ulist l -> ulist (remove dec_eq x l).
  Proof.
    intros l x H; remember (length l) as len; generalize dependent l; induction len as [| len' IHlen'].
      - intros l H1 H2; assert (l = []) as Hnil by (destruct l; auto; discriminate);
        rewrite Hnil; apply ulist_nil.
      - intros l H1 H2; destruct l as [| x' l']; try auto; simpl in H2; inversion H2 as [H3]; simpl;
        destruct (dec_eq x x') as [Hxval | Hxval] eqn:dec.
          + simpl; apply IHlen'; try inversion H1; auto.
          + apply ulist_cons.
            * inversion H1; pose proof incl_rem_l_l l' x; auto.
            * apply IHlen'; try inversion H1; auto.
  Qed.

  Lemma ulist_rem_len : forall l x, ulist l -> In x l -> length l = S( length (remove dec_eq x l)).
  Proof.
    intros l x H1 H2; induction l as [|x' l' IHl']; try contradiction.
      - simpl; destruct (dec_eq x x') as [e|e].
        + inversion H1; assert (remove dec_eq x l' = l') as H' by (apply notin_remove; rewrite e; auto);
          rewrite H'; auto.
        + inversion H2 as [H|H]; try (symmetry in H; contradiction).
          inversion H1; apply (f_equal (fun y => S y)); apply IHl'; auto.
  Qed.
End UList.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) TU Dortmund University, Dortmund, Germany
*)

(*
  Decision Procedure(s):
    Two-counter Machine Reversibility (MM2_REV)

  References:
  [1] Dudenhefner, Andrej. "Certified Decision Procedures for Two-Counter Machines."
      FSCD 2022. https://drops.dagstuhl.de/opus/volltexte/2022/16297/
*)

Require Import List ListDec PeanoNat Lia Operators_Properties.
Import ListNotations.
Require Import Undecidability.MinskyMachines.MM2.
Require Import Undecidability.MinskyMachines.Util.MM2_facts.
Import MM2Notations.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

(* local facts *)
Module Facts.

(* transforms a goal (A -> B) -> C into goals A and B -> C *)
Lemma unnest : forall (A B C : Type), A -> (B -> C) -> (A -> B) -> C.
Proof. auto. Qed.

End Facts.

Import Facts.

Section Construction.
Variable M : list mm2_instr.

#[local] Notation step := (mm2_step M).
#[local] Notation l := (length M).

(* characterize reversibility via a finite number of configurations *)
Lemma finite_characterization : let t := list_prod (seq 1 l) (list_prod [0;1;2] [0;1;2]) in
  Forall (fun '(x, y) => forall z, step x z -> step y z -> x = y) (list_prod t t) ->
  mm2_reversible M.
Proof.
  move=> t. pose P := fun '(x, y) => x <> y /\ exists z, step x z /\ step y z.
  have := Exists_dec P (list_prod t t).
  apply: unnest.
  { move=> [x y]. rewrite /P.
    have [<-|?] := mm2_state_eq_dec x y.
    { right. tauto. }
    have [[z1 Hxz1]|Hx] := mm2_sig_step_dec M x.
    - have [[z2 Hyz2]|Hy] := mm2_sig_step_dec M y.
      + have [?|?] := mm2_state_eq_dec z2 z1.
        * left. subst z2. split; [done|]. by exists z1.
        * right => - [?] [? []].
          move: Hxz1 => /mm2_step_det /[apply] <-.
          by move: Hyz2 => /mm2_step_det /[apply].
      + by right => - [_ [?]] [_ /Hy].
    - by right => - [_ [?]] [/Hx]. }
  case.
  { move=> /Exists_exists [[x y]] [Hxyt] [H1Pxy [z [Hxz Hyz]]].
    by move=> /Forall_forall /(_ (x, y) Hxyt) /(_ z Hxz Hyz). }
  move=> /Forall_Exists_neg /Forall_forall HP _.
  have H''P : forall i j p1 a1 b1 p2 a2 b2 z, mm2_instr_at i p1 M -> mm2_instr_at j p2 M ->
    0 <= a1 <= 2 /\ 0 <= b1 <= 2 /\ 0 <= a2 <= 2 /\ 0 <= b2 <= 2 -> (p1, (a1, b1)) <> (p2, (a2, b2)) ->
    mm2_atom i (p1, (a1, b1)) z -> mm2_atom j (p2, (a2, b2)) z -> False.
  { move=> i j p1 a1 b1 p2 a2 b2 z /[dup] ? /mm2_instr_at_bounds Hi /[dup] ? /mm2_instr_at_bounds Hj *.
    apply: (HP ((p1, (a1, b1)), (p2, (a2, b2)))).
    - apply /in_prod; (apply /in_prod; [apply /in_seq|apply /in_prod]).
      all: move=> /=; lia.
    - split; [done|].
      eexists. by split; eexists; split; eassumption. }
  move=> x y z [i] [Hi Hxz] [j] [Hj].
  move Ezz': (z) => z' Hyz'.
  have Hij : fst x = fst y -> i = j.
  { move=> Hxy. move: Hxy Hi Hj => ->. by apply: mm2_instr_at_unique. }
  move: (Hi) (Hj) => /H''P /[apply] {}H''P.
  move: Hxz Hyz' Ezz' Hij Hi Hj H''P.
  case=> p1 => [a1 b1|a1 b1|q1 a1 b1|q1 a1 b1|q1 b1|q1 a1].
  all: case=> p2 => [a2 b2|a2 b2|q2 a2 b2|q2 a2 b2|q2 b2|q2 a2] /= [] ??? ???; subst.
  - intuition congruence.
  - intuition congruence.
  - move=> /(_ 0 0 2 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 0 0 1 1) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - intuition congruence.
  - intuition congruence.
  - intuition congruence.
  - intuition congruence.
  - move=> /(_ 0 0 1 1) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 0 0 0 2) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - intuition congruence.
  - intuition congruence.
  - move=> /(_ 2 0 0 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 1 1 0 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - have [|?] : p1 = p2 \/ p1 <> p2 by lia.
    + intuition congruence.
    + move=> /(_ 1 0 1 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 1 0 0 1) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 1 0 0 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 1 0 0 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 1 1 0 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 0 2 0 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 0 1 1 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - have [|?] : p1 = p2 \/ p1 <> p2 by lia.
    + intuition congruence.
    + move=> /(_ 0 1 0 1) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 0 1 0 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 0 1 0 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - intuition congruence.
  - intuition congruence.
  - move=> /(_ 0 0 1 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 0 0 0 1) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - intuition congruence.
  - intuition congruence.
  - intuition congruence.
  - intuition congruence.
  - move=> /(_ 0 0 1 0) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - move=> /(_ 0 0 0 1) H''P. exfalso. apply: H''P; by [|constructor|case|lia].
  - intuition congruence.
  - intuition congruence.
Qed.

(* informative decision statement for reversibility for mm2 *)
Theorem decision : (mm2_reversible M) + (not (mm2_reversible M)).
Proof.
  pose t := list_prod (seq 1 l) (list_prod [0;1;2] [0;1;2]).
  have := Forall_Exists_dec (fun '(x, y) => forall z, step x z -> step y z -> x = y) _ (list_prod t t).
  apply: unnest.
  { move=> [x y].
    have [<-|?] := mm2_state_eq_dec x y.
    { left. tauto. }
    have [[z1 Hxz1]|Hx] := mm2_sig_step_dec M x.
    - have [[z2 Hyz2]|Hy] := mm2_sig_step_dec M y.
      + have [?|?] := mm2_state_eq_dec z2 z1.
        * right. subst z2. by move=> /(_ z1 Hxz1 Hyz2).
        * left => ?.
          move: Hxz1 => /mm2_step_det /[apply] <-.
          by move: Hyz2 => /mm2_step_det /[apply].
      + by left => ?? /Hy.
    - by left => ? /Hx. }
  case.
  { move=> /finite_characterization ?. by left. }
  move=> H. right.
  move: H => /Exists_exists [[x y]] [H'xy] Hxy HM. apply: Hxy.
  by apply: HM.
Qed.

End Construction.

Require Import Undecidability.Synthetic.Definitions.

(* decision procedure for the reversibility of mm2 *)
Definition decide : list mm2_instr -> bool :=
  fun M =>
    match decision M with
    | inl _ => true
    | inr _ => false
    end.

(* decision procedure correctness *)
Lemma decide_spec : decider decide MM2_REV.
Proof.
  rewrite /decider /reflects /decide => M.
  case: (decision M); [tauto | done].
Qed.


From Coq Require Import Strings.String.

Inductive ty : Type :=
  | Top   : ty
  | Bool  : ty
  | Nat   : ty
  | List  : ty -> ty
  | Arrow : ty -> ty -> ty
  | IterNil : ty
  | IterCons : ty -> ty -> ty.

Inductive tm : Type :=
  | tru : tm
  | fls : tm
  | test0 : tm -> tm -> tm -> tm
  | test : tm -> tm -> tm -> tm

  (* Basic STLC *)
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm

  (* Boolean comparison *)
  | BBool : bool -> tm
  | BEq : tm -> tm -> tm
  | BGe : tm -> tm -> tm
  | BNot : tm -> tm
  | BAnd : tm -> tm -> tm

  (* Chaining comparison *)
  | CBGe : tm -> tm -> tm -> tm
  | Ctest : tm -> tm -> tm -> tm -> tm -> tm

  (* generator *)
  | gen : tm -> tm -> tm
  | genob : tm -> tm
  | next : tm -> tm

  (* iterator *)
  | iterNil :  tm
  | iterCons : tm -> tm -> tm
  | iterHead : tm -> tm

  (* numbers *)
  | const : nat -> tm
  | scc : tm -> tm
  | prd : tm -> tm

  (* lists *)
  | tnil : ty -> tm
  | tcons : tm -> tm -> tm
  | LHead : tm -> tm

  (* fix *)
  | tfix  : tm -> tm.

Reserved Notation "'[' x ':=' s ']' t" (at level 20).
Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Fixpoint beq_nat n m :=
  match n, m  with
    | O, O => true
    | O, _ => false
    | S n', O => false
    | S n', S m' => beq_nat n' m'
  end.

Fixpoint ble_nat n m  :=
  match n, m  with
    | O, _ => true
    | S n', O => false
    | S n', S m' => ble_nat n' m'
  end.

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  (* boolean *)
  | tru => tru
  | fls => fls

  | test0 t1 t2 t3 =>
      test0 ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  | test t1 t2 t3 =>
      test ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)

  (* Basic STLC *)
  | var y =>
      if eqb_string x y then s else t
  | abs y T t1 =>
      abs y T (if eqb_string x y then t1 else ([x:=s] t1))
  | app t1 t2 =>
      app ([x:=s] t1) ([x:=s] t2)

  (* boolean operation *)
  | BEq t1 t2 => BEq ([x:=s] t1) ([x:=s] t2)
  | BGe t1 t2 => BGe ([x:=s] t1) ([x:=s] t2)
  | BNot t1 => BNot ([x:=s] t1)
  | BAnd t1 t2 => BAnd ([x:=s] t1) ([x:=s] t2)

  (* chaining comparison *)
  | CBGe t1 t2 t3 =>
      CBGe ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  | Ctest t1 t2 t3 t4 t5 =>
      Ctest ([x:=s] t1) ([x:=s] t2) ([x:=s] t3) ([x:=s] t4) ([x:=s] t5)

  (* generator *)
  | gen t1 t2 => gen ([x:=s] t1) ([x:=s] t2)
  | genob t1 => genob ([x:=s] t1)
  | next t1 => next ([x:=s] t1)

  (* numbers *)
  | const n =>
      const n
  | scc t1 =>
      scc ([x:=s] t1)
  | prd t1 =>
      prd ([x:=s] t1)

  (* lists *)
  | tnil T => tnil T
  | tcons t1 t2 => tcons ([x:=s] t1) ([x:=s] t2)
  | LHead t1 => LHead ([x:=s] t1)

  (* iterator *)
  | iterNil => iterNil
  | iterCons t1 t2 => iterCons ([x:=s] t1) ([x:=s] t2)
  | iterHead t1 => iterHead ([x:=s] t1)

  | tfix t1 => tfix ([x:=s] t1)

  (* unit *)
  | unit => unit
  end

where "'[' x ':=' s ']' t" := (subst x s t).

Inductive value : tm -> Prop :=
  (* basic pure STLC values*)
  | v_abs : forall x T11 t12,
      value (abs x T11 t12)

  (* Numbers are values: *)
  | v_nat : forall n1,
      value (const n1)

  (* A list is a value iff its head and tail are values: *)
  | v_lnil : forall T, value (tnil T)
  | v_lcons : forall v1 vl,
      value v1 ->
      value vl ->
      value (tcons v1 vl)

  (* Iterator values: *)
  | v_iternil : value iterNil
  | v_itercons : forall v vr,
      value v ->
      value vr ->
      value (iterCons v vr).

Reserved Notation "t1 '-->' t2" (at level 40).
Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

Inductive step : tm -> tm -> Prop :=
  (* pure STLC *)
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (app (abs x T11 t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         (app t1 t2) --> (app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         (app v1 t2) --> (app v1 t2')

  (* Test nat *)
  | ST_Test1 : forall t1 t1' t2 t3,
       t1 --> t1' ->
       test0 t1 t2 t3 --> test0 t1' t2 t3
  | ST_TestZero : forall t2 t3,
       (test0 (const 0) t2 t3) --> t2
  | ST_TestNonzero : forall n t2 t3,
       (test0 (const (S n)) t2 t3) --> t3

  (* Test bool *)
  | ST_TestTru : forall t1 t2,
      test tru t1 t2 --> t1
  | ST_TestFls : forall t1 t2,
      test fls t1 t2 --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      test t1 t2 t3 --> test t1' t2 t3

  (* Boolean operations *)
  | ST_BEq : forall t1 t1' t2,
              t1 --> t1' ->
              BEq t1 t2 --> BEq t1' t2
  | ST_BEqNat : forall n1 n2,
              BEq (const n1) (const n2) --> BBool(beq_nat n1 n2)
  | ST_BEqString : forall s1 s2,
              (BEq (var s1) (var s2)) --> BBool(eqb_string s1 s2)
  | ST_BEqVal: forall v1 t2 t2',
                value v1 ->
                t2 --> t2' ->
                (BEq v1 t2) --> (BEq v1 t2')

  | ST_BGe : forall t1 t1' t2,
              t1 --> t1' ->
              BGe t1 t2 --> BGe t1' t2
  | ST_BGeVal: forall v1 t2 t2',
                value v1 ->
                t2 --> t2' ->
                (BGe v1 t2) --> (BGe v1 t2')
  | ST_BGeConst:  forall n1 n2,
                  BGe (const n1) (const n2) --> BBool(ble_nat n2 n1)

  | ST_BNot : forall t1 t1',
              t1 --> t1' ->
              BNot t1 --> BNot t1'
  | ST_BNotVal: forall b1,
                BNot (BBool b1) --> BBool(negb b1)

  | ST_BAnd : forall t1 t1' t2,
              t1 --> t1' ->
              BAnd t1 t2 --> BAnd t1' t2
  | ST_BAndBool: forall b1 b2,
                BAnd (BBool b1) (BBool b2) --> BBool(andb b1 b2)
  | ST_BAndVal: forall v1 t2 t2',
                value v1 ->
                t2 --> t2' ->
                BAnd v1 t2 --> BAnd v1 t2'

  (* chaining comparison *)
  | ST_CBGe : forall t1 t1' t2 t3,
              t1 --> t1' ->
              CBGe t1 t2 t3 --> CBGe t1' t2 t3
  | ST_CBGeVal1: forall v1 t2 t2' t3,
                value v1 ->
                t2 --> t2' ->
                CBGe v1 t2 t3 --> CBGe v1 t2' t3
  | ST_CBGeVal2: forall v1 v2 t3 t3',
                value v1 ->
                value v2 ->
                t3 --> t3' ->
                CBGe v1 v2 t3 --> CBGe v1 v2 t3'
  | ST_CBGeConst: forall n1 n2 n3,
                  CBGe (const n1) (const n2) (const n3) -->
                  BAnd(BGe (const n1) (const n2)) (BGe (const n2) (const n3))

  | ST_CTest : forall t1 t2 t3 t4 t5,
      Ctest t1 t2 t3 t4 t5 --> test (CBGe t1 t2 t3) t4 t5

  (* numbers *)
  | ST_Succ : forall t1 t1',
       t1 --> t1' ->
       (scc t1) --> (scc t1')
  | ST_SuccNat : forall n1,
       (scc (const n1)) --> (const (S n1))
  | ST_Pred : forall t1 t1',
       t1 --> t1' ->
       (prd t1) --> (prd t1')
  | ST_PredNat : forall n1,
       (prd (const n1)) --> (const (pred n1))

  (* recursive functions *)
  | ST_Fix1 : forall t1 t1',
         t1 --> t1' ->
         (tfix t1) --> (tfix t1')
  | ST_FixAbs : forall y T t1,
         (tfix (abs y T t1)) --> [y:=(tfix (abs y T t1))]t1
  | ST_AppFunc : forall x T11 t12 v2,
         value v2 ->
         (app (abs x T11 t12) v2) --> [x:=v2]t12

  (* Generator *)
  | ST_Gen1 : forall t1 t1' t2,
              t1 --> t1' ->
              gen t1 t2 --> gen t1' t2

  | ST_Gen2 : forall v1 t2 t2',
              value v1 ->
              t2 --> t2' ->
              gen v1 t2 --> gen v1 t2'

  | ST_Gen : forall v1 v2 t1 t2 f,
       value v1 -> value v2 ->
       gen (abs t1 Bool v1) (abs t2 Nat v2) -->
       tfix
        (abs f (Arrow (Arrow Bool Nat) (List Nat) )
          (abs t1 Bool
            (abs t2 Nat
              (test (var t1)
                (tcons (var t2) (
                  (test0 (var t2)
                    (app (var f)(app (fls)(const 0)))
                    (app (var f)(app (tru) (prd (var t2) ) ) ) ) ) )
                (tnil Nat) ) ) ) )

  (* Generator Object *)
  | ST_Genob : forall t1 t1',
         t1 --> t1' ->
         genob t1 --> genob t1'
  | ST_GenobVal : forall v1,
         genob v1 --> iterCons v1 iterNil

 (* Next Call to Generator Object *)
  | ST_Next : forall t1 t1',
       t1 --> t1' ->
       next t1 --> next t1'
  | ST_NextVal : forall v1,
       next v1 --> iterHead (v1)

  (* lists *)
  | ST_Cons1 : forall t1 t1' t2,
       t1 --> t1' ->
       (tcons t1 t2) --> (tcons t1' t2)
  | ST_Cons2 : forall v1 t2 t2',
       value v1 ->
       t2 --> t2' ->
       (tcons v1 t2) --> (tcons v1 t2')
  | ST_Head : forall t1 t1',
              t1 --> t1'->
              LHead t1 --> LHead t1'
  | ST_HeadVal : forall h1 l1,
              value h1->
              LHead (tcons h1 l1)--> h1

  (* Iterators *)
  | ST_IterCons1 : forall t1 t1' t2,
       t1 --> t1' ->
       (iterCons t1 t2) --> (iterCons t1' t2)
  | ST_IterCons2 : forall v1 t2 t2',
       value v1 ->
       t2 --> t2' ->
       (iterCons v1 t2) --> (iterCons v1 t2')
  | ST_IterHead : forall t1 t1',
              t1 --> t1'->
              iterHead t1 --> iterHead t1'
  | ST_IterHeadVal : forall h1 l1,
              value h1->
              iterHead (iterCons h1 l1)--> h1

where "t1 '-->' t2" := (step t1 t2).

Definition total_map (A : Type) := string -> A.

Definition partial_map (A : Type) := total_map (option A).

Definition context := partial_map ty.

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

Reserved Notation "T '<:' U" (at level 40).

Inductive subtype : ty -> ty -> Prop :=
  | S_Refl : forall T,
      T <: T
  | S_Trans : forall S U T,
      S <: U ->
      U <: T ->
      S <: T
  | S_Top : forall S,
      S <: Top
  | S_Arrow : forall S1 S2 T1 T2,
      T1 <: S1 ->
      S2 <: T2 ->
      (Arrow S1 S2) <: (Arrow T1 T2)

  | S_ItrWidth0 : forall T1 T2,
    (IterCons T1 T2) <: IterNil

  | S_ItrWidth1 : forall S1 S2 T1 T2,
    S1 <: T1 ->
    S2 <: T2 ->
    (IterCons S1 S2) <: (IterCons T1 T2)

where "T '<:' U" := (subtype T U).

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  (* pure STLC *)
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- (var x) \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      (update Gamma x T11) |- t12 \in T12 ->
      Gamma |- (abs x T11 t12) \in (Arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (Arrow T1 T2) ->
      Gamma |- t2 \in T1 ->
      Gamma |- (app t1 t2) \in T2

  (* numbers *)
  | T_Nat : forall Gamma n1,
      Gamma |- (const n1) \in Nat
  | T_Succ : forall Gamma t1,
      Gamma |- t1 \in Nat ->
      Gamma |- (scc t1) \in Nat
  | T_Pred : forall Gamma t1,
      Gamma |- t1 \in Nat ->
      Gamma |- (prd t1) \in Nat

  (* Boolean operation types *)
  | T_BBool : forall Gamma b1,
      Gamma |- (BBool b1) \in Bool
  | T_BEq : forall Gamma t1 t2 T,
      Gamma |- t1 \in T ->
      Gamma |- t2 \in T ->
      Gamma |- (BEq t1 t2) \in Bool
  | T_BGe : forall Gamma t1 t2 T,
      Gamma |- t1 \in T ->
      Gamma |- t2 \in T ->
      Gamma |- (BGe t1 t2) \in Bool
  | T_BNot : forall Gamma t1,
      Gamma |- t1 \in Bool ->
      Gamma |- (BNot t1) \in Bool
  | T_BAnd : forall Gamma t1 t2,
      Gamma |- t1 \in Bool ->
      Gamma |- t2 \in Bool ->
      Gamma |- (BAnd t1 t2) \in Bool

  | T_Test : forall Gamma t1 t2 t3 T1,
      Gamma |- t1 \in Bool ->
      Gamma |- t2 \in T1 ->
      Gamma |- t3 \in T1 ->
      Gamma |- (test t1 t2 t3) \in T1
  | T_Test0 : forall Gamma t1 t2 t3 T1,
      Gamma |- t1 \in Nat ->
      Gamma |- t2 \in T1 ->
      Gamma |- t3 \in T1 ->
      Gamma |- (test0 t1 t2 t3) \in T1

  (* chaining comparison *)
  | T_CBGe : forall Gamma t1 t2 t3,
      Gamma |- t1 \in Bool ->
      Gamma |- t2 \in Bool ->
      Gamma |- t3 \in Bool ->
      Gamma |- (CBGe t1 t2 t3) \in Bool
  | T_CTest : forall Gamma t1 t2 t3 t4 t5 T1,
      Gamma |- t1 \in Bool ->
      Gamma |- t2 \in Bool ->
      Gamma |- t3 \in Bool ->
      Gamma |- t4 \in T1 ->
      Gamma |- t5 \in T1 ->
      Gamma |- (Ctest t1 t2 t3 t4 t5) \in T1

  (* Iterator*)
  | Iter_Nil : forall Gamma,
      Gamma |- iterNil \in IterNil
  | T_IterCons : forall Gamma t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      Gamma |- (iterCons t tr) \in (IterCons T Tr)

  (* Generator Function*)
  | T_Gen : forall Gamma t1 t2,
      Gamma |- t1 \in Bool ->
      Gamma |- t2 \in Nat ->
      Gamma |- (gen t1 t2) \in List Nat

  (* Generator Object*)
  | T_Genob : forall Gamma t1 T1,
      Gamma |- t1 \in List T1 ->
      Gamma |- genob t1 \in IterCons T1 IterNil

  (* next*)
  | T_Next : forall Gamma t1 T1 T2,
      Gamma |- t1 \in IterCons T1 T2 ->
      Gamma |- next t1 \in T1

  (* fix recursion*)
  | T_Fix : forall Gamma t1 T1,
      Gamma |- t1 \in (Arrow T1 T1) ->
      Gamma |- tfix t1 \in T1

  (* lists *)
  | T_Nil : forall Gamma T,
      Gamma |- (tnil T) \in (List T)
  | T_Cons : forall Gamma t1 t2 T1,
      Gamma |- t1 \in T1 ->
      Gamma |- t2 \in (List T1) ->
      Gamma |- (tcons t1 t2) \in (List T1)

  (* Subsumption Rule*)
  | T_Sub : forall Gamma t S T,
      Gamma |- t \in S ->
      S <: T ->
      Gamma |- t \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).


Require Import List.
Require Import Strings.String.
Import StringSyntax.
Open Scope string.

  Inductive Ty :=
  | dp | s | ArrL : Ty -> Ty -> Ty
  | ArrR : Ty -> Ty -> Ty
  | Pair : Ty -> Ty -> Ty
  | Comp : Ctx -> Ty -> Ctx -> Ty
  with
    Ctx := | Empty | Cons : Ctx -> Ty -> Ctx.

Module Ling.
  Parameter (E : Type).
  Parameter (e : string -> E).
  Parameter (eet : string -> E -> E -> Prop).
  Parameter (et : string -> E -> Prop).
  Parameter (baseAdj : string -> E -> Prop).
  Parameter (Wants : Prop -> E -> Prop).
  Parameter (Knows : Prop -> E -> Prop).
  Parameter (know : E -> Prop -> Prop).
  Parameter (Mother : E -> E).

  Fixpoint interpTy (t : Ty) :=
    match t with
    | dp => E
    | s => Prop
    | ArrL x y => interpTy x -> interpTy y
    | ArrR x y => interpTy y -> interpTy x
    | Pair x y => (interpTy x * interpTy y)%type
    | Comp G t D =>
      (interpCtx D -> interpTy t -> Prop) -> interpCtx G -> Prop
    end
    with
    interpCtx (g : Ctx) :=
      match g with
      | Empty => unit
      | Cons g' t => interpCtx g' * interpTy t end.

  Coercion interpTy : Ty >-> Sortclass.
  Coercion interpCtx : Ctx >-> Sortclass.

  Notation "x \ y" := (ArrL x y) (at level 40).
  Notation "x / y" := (ArrR x y).

  Notation "G |- t -| D" := (Comp G t D) (at level 30).
  Notation "<>" := (Empty).
  Notation "G ;; t" := (Cons G t) (at level 29, left associativity, format "G  ';;'  t").

  Notation "x ** y" := (Pair x y) (at level 40).

  Parameter (alt : Prop -> ((dp) -> Prop) -> (dp) -> Prop).

  (* Some helper typeclasses.
     This first one, Proj, turns one larger discourse into another smaller discourse.
     If the mapping is ambiguous, it prefers the mapping using the most recent variables. *)

  (* This order of writing Proj down gets the most recent discourse referent that fits. This should be more programmable *)
  Class Proj (G1 G2 : Ctx) := proj : G1 -> G2.
  Instance proj_refl g : Proj g g := fun x => x.
  Instance proj_cons_different g1 g2 t `{Proj g1 g2} : Proj (g1 ;; t) g2 :=
    fun g1t =>
      proj (fst g1t).
  Instance proj_cons_same g1 g2 t `{Proj g1 g2} : Proj (g1 ;; t) (g2 ;;t) :=
    fun g1t =>
      (proj (fst g1t), snd g1t).

  Fixpoint getCtx (G: Ctx) (i : nat) : option Ty :=
    match G with
    | Empty => None
    | Cons g' t =>
      match i with
      | 0 => Some t
      | S i' => getCtx g' i' end end.

  Class GetCtx G i t := getCtx_witness : getCtx G i = Some t.
  Instance GetCtx_last G t : GetCtx (G ;; t) 0 t := eq_refl.
  Instance GetCtx_next G t t2 i `{GetCtx G i t} : GetCtx (G ;; t2) (S i) t := @getCtx_witness G i t _.

  Definition typeAt (G: Ctx) (i : nat) : Type :=
    match getCtx G i with
    | None => unit
    | Some  t => t end.

  Fixpoint recall' (G : Ctx) (i : nat) : interpCtx G -> typeAt G i.
    destruct G.
    apply (fun x => x).
    destruct i.
    apply (fun g => snd g).
    apply (fun g => recall' G i (fst g)).
  Defined.

  Definition recall (G : Ctx) (i : nat) (t : Ty) `{GetCtx G i t} : interpCtx G -> t.
    remember (recall' G i) as p.
    clear Heqp.
    unfold typeAt in p.
    rewrite H in p.
    apply p.
  Defined.

  Definition lift {t : Ty} {G : Ctx} (x : t) : G |- t -| G :=
    fun k g => k g x.

  (* You can lower and evaluate any sentence that doesn't have any free variables in it. *)
  Definition lower {D} (c : <> |- s -| D): s :=
    (c (fun _ p => p) tt).

  (* Lifting the arrow combinators to computations, just like 'cleft' and 'cright' as before. *)

  Definition compL {G D E : Ctx} {t1 t2 : Ty}
             (X : G |- t1 -| D)
             (Y : D |- t1 \ t2 -| E) : G |- t2 -| E :=
    (fun k g => X (fun d x => Y (fun e f => k e (f x)) d) g).

  Definition compR {G D E : Ctx} {t1 t2 : Ty} (X : G |- t1 / t2 -| D) (Y : D |- t2 -| E) : G |- t1 -| E :=
    (fun k g => X (fun d f => Y (fun e x => k e (f x)) d) g).

  Notation "x <| y" := (compL x y) (at level 41).
  Notation "x |> y" := (compR x y) (at level 40).

  Definition tv st : (dp \ s) / dp := eet st.
  Definition iv st : dp \ s := et st.

  Definition everyone {G : Ctx} : G |- dp -| G :=
    fun k g => forall x, k g x.

  Definition someone {G : Ctx} : G |- dp -| G;;dp :=
    fun k g => exists x, k (g, x) x.

  Definition everyone_sleeps : <> |- s -| <> :=
    everyone <| lift (iv "sleeps").

  Eval compute in (lower everyone_sleeps).
  (* forall x, et "sleeps" x *)

  (** Evaluation order stuff **)

  (* Force runs the first argument, and returns a dummy version to be used later. *)
  Definition force {G D} {t t'}
             (c : G |- t -| D)
             (f : G |- t -| D -> G |- t' -| D) : G |- t' -| D :=
  (fun k g => c (fun d x => f (fun f0 _ => f0 d x) k g) g).

  (* everyone loves someone *)
  Eval compute in (lower (everyone <| lift (tv "loves") |> someone)).

  (* The inverse reading is done using this 'force' combinator. There are likely more
     natural encodings of reverse evaluation order as well. Maybe the verb induces inverse evaluation? *)
  Eval compute in (lower
                     (force someone
                    (fun s => everyone <| lift (tv "loves") |> s))).

  Definition mk_dp s : dp := e s.
  Definition john := mk_dp "john".
  Definition alice := mk_dp "alice".

  Definition add {G D:Ctx} {t :Ty} (c : G |- t -| D) (t':Ty) (x : t') : G |- t -| D ;; t' :=
     fun k g => c (fun d y => k (d, x) y) g.

  (* The bind combinator adds the local type to the discource. *)
  Definition bind {G D: Ctx} {t : Ty} (c : G |- t -| D) : G |- t -| D ;; t :=
    (fun k g => c (fun d x => k (d, x) x) g).

  (* If there is a dp available in the discourse G, 'he' selects the most recent one.
   (This can be tweaked to account for features such as grammatical gender, number, etc ) *)

  (* A more general version of 'he', but for arbitrary types t. *)
  Definition retrieve {G} t i `{GetCtx G i t} : G |- t -| G :=
    (fun k g => k g (recall G i t g)).

  Definition he {G : Ctx} i `{GetCtx G i dp} : G |- dp -| G :=
    retrieve dp i.

  (* 'weak' weakens the discourse. You are allowed to grow the input, and shrink the output. *)
  Definition weak G D {G' D'} {t} `{Proj G G'} `{Proj D' D} (c : G' |- t -| D') : G |- t -| D :=
    (fun k g => c (fun d' x => k (proj d') x) (proj g)).

  Definition and : (s \ s) / s := fun x y => x /\ y.

  (* Capture takes a computation, and both 1) evaluates it; but 2) puts itself, unevaluated, onto the discourse *)
  Definition capture {G D} {t} (c : G |- t -| D) :
    G |- t -| D ;; (G |- t -| D) :=
    fun k g => c (fun d x => k (d, c) x) g.

  (* 'run' says that if you have a computation that returns another computation, you can extract the inner computation.

   For example, consider "he is muddy", with type <> ;; dp |- s -| <>;; dp.

   If it is stored in a bigger context and recalled,
     you have something of type (bigger context) |- (<> ;; dp |- s -| <> ;; dp) -| (same bigger context). This allows you to move from this double-computation to the inner computation.

*)
  Definition run {G G1 D1 : Ctx} `{Proj G G1} {t} (c : G |- (G1 |- t -| D1) -| G) : G |- t -| D1.
    simpl in *.
    intros k g.
    refine (c _ g).
    intros d k2.
    apply (k2 k (proj g)).
  Defined.

  Parameter knows : (dp \ s) / s.

  (* Example: John knows he is muddy, and alice does too. *)

  (* John knows himself *)

  Definition john_knows_he_is_muddy : <> |- s -| <> ;; dp ;; (<> ;; dp |- dp \ s -| <> ;; dp) :=
    bind (lift john) <| capture (lift knows |> (he 0 <| lift (iv "muddy"))).

  (* In the covariant version, alice is bound, so alice fills in the dp hole in "knows (s)he is muddy " *)
  Eval compute in (lower (john_knows_he_is_muddy <| lift and |> (bind (lift alice) <| run (retrieve _ 1)))).
  (* knows (et "muddy" (e "alice")) (e "alice") /\ knows (et "muddy" (e "john")) (e "john") *)

  (* In the invariant version, we do not bind alice, so john is still the most recent dp. *)
  Eval compute in (lower (john_knows_he_is_muddy <| lift and |> ((lift alice) <| run (retrieve _ 0)))).
  (* knows (et "muddy" (e "john")) (e "alice") /\ knows (et "muddy" (e "john")) (e "john") *)

  (* This version of FOC doesn't take in a structured antecedent,
but instead takes in *two* antecedents. this can be adapted so as to not
get strange readings *)
  Definition FOC {G G'} {I} `{Proj G I} i1 i2 `{GetCtx G i1 dp} `{GetCtx G i2 (I |- dp \ s -| I)} (c : G |- dp -| G') : G |- dp -| G'.
    intros k g.
    assert (j := recall G i1 _ g).
    assert (pred :=
                fun (x:dp) => (recall G i2 _) g (fun _ p => p x) (proj g)).
    apply (c (fun o x => k o x /\ alt (pred j) pred x) g).
  Defined.

  Eval compute in (lower (john_knows_he_is_muddy <| lift and |> (FOC 1 0 (lift alice) <| run (retrieve _ 0)))).

(*
  john kissed ben, and ALICE did too

want:

     (eet "kiss" (e "john") (e "ben") /\ eet "kiss" (e "alice") (e "ben")) /\
       alt (eet "kiss" (e "john") (e "ben"))
         (fun y : E => eet "kiss" y (e "ben")) (e "alice")
*)

End Ling.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e256m2e32m977_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Basics.Overture Basics.Tactics.
Require Import Types.Forall.
Require Import WildCat.Core WildCat.Opposite WildCat.Universe WildCat.Prod.

(** * Bifunctors between WildCats *)

Class IsBifunctor {A B C : Type} `{IsGraph A, IsGraph B, Is1Cat C}
  (F : A -> B -> C)
  := {
    bifunctor_isfunctor_10 : forall a, Is0Functor (F a);
    bifunctor_isfunctor_01 :
    forall b, Is0Functor (flip F b);
    bifunctor_isbifunctor :
    forall a0 a1 (f : a0 $-> a1) b0 b1 (g : b0 $-> b1),
      fmap (F _) g $o fmap (flip F _) f $==
        fmap (flip F _) f $o fmap (F _) g
  }.

#[export] Existing Instance bifunctor_isfunctor_10.
#[export] Existing Instance bifunctor_isfunctor_01.
Arguments bifunctor_isbifunctor {A B C} {_ _ _ _ _ _}
  F {_} {a0 a1} f {b0 b1} g.

Definition bifunctor_hom {C : Type} `{IsGraph C}
  : C^op -> C -> Type := @Hom C _.

Local Instance is0functor_hom01 {C : Type} `{Is1Cat C}
  : forall c, Is0Functor (bifunctor_hom c).
Proof.
  intro c; srapply Build_Is0Functor.
  rapply cat_postcomp.
Defined.

Local Instance is0functor_hom10 {C : Type} `{Is1Cat C}
  : forall c, Is0Functor (flip bifunctor_hom c).
Proof.
  intro c; srapply Build_Is0Functor.
  intros ? ? f; cbn.
  rapply cat_precomp.
  exact f.
Defined.

(** [Hom] is a bifunctor whenever [C] is a strong 1-category. *)
Global Instance isbifunctor_hom {C : Type} `{Is1Cat_Strong C}
  : IsBifunctor (bifunctor_hom (C:=C)).
Proof.
  srapply Build_IsBifunctor.
  intros ? ? f ? ? g x; cbn.
  unfold cat_precomp, cat_postcomp.
  symmetry; apply cat_assoc_strong.
Defined.

Definition fmap01 {A B C : Type} `{Is01Cat A, Is01Cat B, Is1Cat C}
  (F : A -> B -> C) `{!IsBifunctor F}
  (a : A) {b0 b1 : B} (g : b0 $-> b1)
  : F a b0 $-> F a b1 := fmap (F a) g.

Definition fmap10 {A B C : Type} `{Is01Cat A, Is01Cat B, Is1Cat C}
  (F : A -> B -> C) `{!IsBifunctor F}
  {a0 a1 : A} (f : a0 $-> a1) (b : B)
  : (F a0 b) $-> (F a1 b) := fmap (flip F b) f.

Global Instance isbifunctor_compose {A B C D : Type}
  `{IsGraph A, IsGraph B, Is1Cat C, Is1Cat D}
  (F : A -> B -> C) (G : C -> D) `{!Is0Functor G, !Is1Functor G}
  `{P : !IsBifunctor F}
  : IsBifunctor (fun a b => G (F a b)).
Proof.
  srapply Build_IsBifunctor.
  intros ? ? f ? ? g; cbn.
  refine ((fmap_comp G _ _)^$ $@ _ $@ fmap_comp G _ _).
  rapply fmap2.
  apply P.
Defined.

(** There are two possible ways to define this, which will only agree in the event that F is a bifunctor. *)
#[export] Instance Is0Functor_uncurry_bifunctor {A B C : Type}
  `{IsGraph A, IsGraph B, Is1Cat C}
  (F : A -> B -> C)
  `{forall a, Is0Functor (F a), forall b, Is0Functor (flip F b)}
  : Is0Functor (uncurry F).
Proof.
  srapply Build_Is0Functor.
  intros [a1 b1] [a2 b2] [f g]; cbn in f, g.
  unfold uncurry; cbn.
  exact ((fmap (flip F b2) f) $o (fmap (F a1) g)).
Defined.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl 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.

  VPrl 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 VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export universe.

Definition decidable (P: Type):= (P + (notT P))%type.
Definition d2b {x} (d : decidable x) : bool := if d then true else false.
Definition dassert {x} (d : decidable x) : Prop := d2b d = true.

Inductive void : Type := .

(* ========= Here is a constuctive iff ======== *)

(*Definition t_iff A B := (A -> B) # (B -> A).*)

Inductive t_iff (A B : Type) : Type :=
 | t_iff_cons : (A -> B) -> (B -> A) -> t_iff A B.

Notation "x <o> y" := (t_iff x y) (at level 95, no associativity).

Lemma tiff_trans :
  forall a b c, (a <o> b) -> (b <o> c) -> (a <o> c).
Proof.
  intros a b c i1 i2.
  destruct i1 as [i11 i12].
  destruct i2 as [i21 i22].
  split; intro k.
  apply i11 in k; apply i21 in k; auto.
  apply i22 in k; apply i12 in k; auto.
Qed.

Ltac dtiff :=
  match goal with
      [ H : ?x <o> ?y |- _ ] => destruct H
  end.

Ltac dtiffs := repeat dtiff.

Ltac dprod :=
  match goal with
      [ H : ?x ## ?y |- _ ] => destruct H
  end.

Ltac dprods := repeat dprod.

Ltac dsum :=
  match goal with
      [ H : ?x [[+]] ?y |- _ ] => destruct H
  end.

Ltac dsums := repeat dsums.

Ltac dall :=
  repeat match goal with
           | [ H : ?x <o> ?y |- _ ] => destruct H
           | [ H : ?x ## ?y   |- _ ] => destruct H
           | [ H : ?x [[+]] ?y |- _ ] => destruct H
         end.

Definition tiff_fst :=
  fun {A B : Type} (p : A <o> B) => let (x, _) := p in x.

Definition tiff_snd :=
  fun {A B : Type} (p : A <o> B) => let (_, y) := p in y.

Lemma tiff_is_prod_implies1 :
  forall A B,
    (A <o> B) <o> ((A -> B) ## (B -> A)).
Proof.
  intros; split; intros k; split; intros; destruct k; auto.
Qed.

Lemma tiff_is_prod_implies2 :
  forall A B : Type,
    ((A -> B) ## (B -> A)) <o> (A <o> B).
Proof.
  intros; split; intros k; split; intros; destruct k; auto.
Qed.

Lemma combine_t_iff_proofs_imp :
  forall {A B A' B' : Type},
    (A <o> A') -> (B <o> B') -> ((A -> B) <o> (A' -> B')).
Proof.
  intros; dall; constructor; auto.
Qed.

Lemma combine_t_iff_proofs_t_iff :
  forall {A B A' B'},
    (A <o> A')
    -> (B <o> B')
    -> ((A <o> B) <o> (A' <o> B')).
Proof.
  intros.
  dall; constructor; intro; dall; constructor; auto.
Qed.

Lemma combine_t_iff_proofs_prod :
  forall {A B A' B'},
    (A <o> A')
    -> (B <o> B')
    -> ((A ## B) <o> (A' ## B')).
Proof.
  intros.
  dall; constructor; intro; dall; auto.
Qed.

Lemma combine_t_iff_proofs_sum :
  forall {A B A' B'},
    (A <o> A')
    -> (B <o> B')
    -> ((A [[+]] B) <o> (A' [[+]] B')).
Proof.
  intros.
  dall; constructor; intro; dall; auto.
Qed.

Lemma combine_t_iff_proofs_not :
  forall {A A'},
    (A <o> A')
    -> (notT A <o> notT A').
Proof.
  intros.
  dall; constructor; repeat intro; auto.
Qed.

Lemma t_iff_refl :
  forall A, A <o> A.
Proof.
  intros; constructor; auto.
Qed.

Lemma t_iff_sym :
  forall {A B}, (A <o> B) -> (B <o> A).
Proof.
  intros.
  dall; constructor; auto.
Qed.

(* this build a proof object of T <o> T[b/a] where p is the proof of a<o>b.
*)
Ltac build_tiff_term T a b p :=
  match T with
    | a => p
    | ?x -> ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_imp l r)
    | ?x <o> ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_t_iff l r)
    | ?x ## ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_prod l r)
    | ?x [[+]] ?y =>
      let l := build_tiff_term x a b p in
      let r := build_tiff_term y a b p in
      constr:(combine_t_iff_proofs_sum l r)
    | notT ?x =>
      let l := build_tiff_term x a b p in
      constr:(combine_t_iff_proofs_not l)
    | _ => constr:(t_iff_refl T)
  end.

Tactic Notation "thin_last" :=
  match goal with H: ?T |- _ => clear H end.

Ltac apply' H1 H2 :=
  let H3 := fresh in (
    (pose proof (H1 H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (H1 _ _ _ _ H2) as H3; clear H2; pose proof H3 as H2; clear H3)).

Ltac build_and_rewrite H :=
  let T := type of H in
  match goal with
    | [ |- ?C ] =>
      match T with
        | ?A <o> ?B =>
          let d := build_tiff_term C A B H in
          let name := fresh H in
          remember d as name;
            thin_last;
            apply  name;
            clear name
      end
  end.

Ltac build_and_rewrite_hyp H H2 :=
  let T := type of H in
  let C := type of H2 in
  match T with
    | ?A <o> ?B =>
      let d := build_tiff_term C A B H in
      let name := fresh H in
      remember d as name;
        thin_last;
        apply' (tiff_fst name) H2;
        clear name
  end.

Ltac build_and_rewrite_rev H :=
  let T := type of H in
  match goal with
    | [ |- ?C ] =>
      match T with
        | ?A <o> ?B =>
          let d := build_tiff_term C B A (t_iff_sym H) in
          let name := fresh H in
          remember d as name;
            thin_last;
            apply name;
            clear name
      end
  end.

Ltac build_and_rewrite_hyp_rev H H2 :=
  let T := type of H in
  let C := type of H2 in
  match T with
    | ?A <o> ?B =>
      let d := build_tiff_term C B A (t_iff_sym H) in
      let name := fresh H in
      remember d as name;
        thin_last;
        apply' (tiff_fst name)  H2;
        clear name
  end.

Tactic Notation "trewrite" ident(H) :=
       build_and_rewrite H.

Tactic Notation "trewrite" ident(H) "in" ident (H') :=
       build_and_rewrite_hyp H H'.

Tactic Notation "trewrite" "<-" ident(H) :=
       build_and_rewrite_rev H.

Tactic Notation "trewrite" "<-" ident(H) "in" ident(H') :=
       build_and_rewrite_hyp_rev H H'.

Ltac get_instance_of  T  H Hn :=
  match H with
    | _ =>
     let name:= fresh "Htemp" in
      (* idtac "trying gio" H;*)
     progress (
        (pose proof (fun h:H => (tiff_fst T) h) as name)||
        (pose proof (fun h:H => (tiff_fst (T _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_fst (T _ _ _ _ _ _ _ _)) h) as name)
      ); (* idtac "succeded" H; *)
     let H2 := type of name in
         match H2 with
           | ?H -> ?H => fail 1 (* both sides are the same, we won't rewrite anything *)
           | ?H -> ?H2 =>
             clear name;
               assert (H <o> H2) as Hn by (apply T)
         (*; idtac "really succeded" H *)
         end

    | ?Hl <o> ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | ?Hl ## ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | ?Hl [[+]] ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
    | notT ?Hl => get_instance_of T Hl Hn
    | ?Hl -> ?Hr => get_instance_of T Hl Hn || get_instance_of T Hr Hn
  end.

Ltac get_instance_of_rev  T  H Hn :=
  match H with
    | _ =>
     let name:= fresh "Htemp" in
      (* idtac "trying gio" H;*)
     progress (
        (pose proof (fun h:H => (tiff_snd T) h) as name)||
        (pose proof (fun h:H => (tiff_snd (T _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _ _)) h) as name) ||
        (pose proof (fun h:H => (tiff_snd (T _ _ _ _ _ _ _ _)) h) as name)
      ); (* idtac "succeded" H;*)
     let H2 := type of name in
         match H2 with
           | ?H -> ?H => fail 1 (* both sides are the same, we won't rewrite anything *)
           | ?H -> ?H2 =>
             clear name;
               assert (H2 <o> H) as Hn by (apply T)
         (** H2 in LHS; apply does not automatically take care
                    of symmetry *)
         (*; idtac "really succeded" H*)
         end

    | ?Hl <o> ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | ?Hl ## ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | ?Hl [[+]] ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
    | notT ?Hl => get_instance_of_rev T Hl Hn
    | ?Hl -> ?Hr => get_instance_of_rev T Hl Hn || get_instance_of_rev T Hr Hn
  end.

(** rewrite using a universally quantified t_iff relation T  in the conclusion *)
Ltac trw T :=
  match goal with
      [  |- ?C ] =>
      let name:= fresh "Hget_instance_of_in_concl" in
      get_instance_of T C name;
        build_and_rewrite name; clear name
  end.

Ltac trw_rev  T :=
  match goal with
      [  |- ?C ] =>
      let name:= fresh "Hget_instance_of_in_concl" in
      get_instance_of_rev T C name;
        build_and_rewrite_rev name ; clear name
  end.

Ltac trw_h T h :=
  let C := type of h in
  let name:= fresh "Hget_instance_of_in_concl" in
  get_instance_of T C name;
    build_and_rewrite_hyp name h; clear name.

Ltac trw_rev_h T h :=
  let C := type of h in
  let name:= fresh "Hget_instance_of_in_concl" in
  get_instance_of_rev T C name;
    build_and_rewrite_hyp_rev name h; clear name.

(* Some general notation to use the above tactics *)

Tactic Notation "rw" constr(T) :=
  trw T || rewrite T.
Tactic Notation "rw" "<-" constr(T) :=
  trw_rev T || rewrite <- T.
Tactic Notation "rw" constr(T) "in" ident(H) :=
  trw_h T H || rewrite T in H.
Tactic Notation "rw" "<-" constr(T) "in" ident(H) :=
  trw_rev_h T H || rewrite <- T in H.

Tactic Notation "onerw" :=
       match goal with
         | [ H : _ |- _ ] => progress (trw H || rewrite H)
       end.

Tactic Notation "allrw" := repeat onerw.

Tactic Notation "allrw" "<-" :=
  repeat match goal with
           | [ H : _ |- _ ] => progress (trw_rev H || rewrite <- H)
          end.

(*
Tactic Notation "onerw" constr(T) :=
       match goal with
         | [ H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
       end.

Tactic Notation "allrw" constr(T) := repeat (onerw T).
*)

Tactic Notation "onerw" constr(T) :=
       let t := type of T in
       match goal with
         | [ H : _, H' : t |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
         | [ H : t |- _ ] => fail 1
         | [ H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
       end.

Tactic Notation "allrw" constr(T) := repeat (onerw T).

Tactic Notation "rww" ident(T) :=
  let t := type of T in
  repeat match goal with
           | [ H1 : t, H : _ |- _ ] =>
             progress (trw_h T H || trw T || rewrite T in H || rewrite T)
         end.

Tactic Notation "allrw" "<-" constr(T) :=
  repeat match goal with
           | [ H : _ |- _ ] =>
             progress (trw_rev_h T H || trw_rev T || rewrite <- T in H || rewrite <- T)
         end.

Tactic Notation "rww" "<-" ident(T) :=
  let t := type of T in
  repeat match goal with
           | [ H1 : t, H : _ |- _ ] =>
             progress (trw_rev_h T H || trw_rev T || rewrite <- T in H || rewrite <- T)
         end.

(* ------------------------ *)

(*
Theorem trw_demo: forall (P Q: nat -> Type),
 (forall n, P n <o> Q n )
  -> ((P 1 * void -> void ) <o> (Q 1 * void -> void )).
Proof.
  intros ? ?  Hiff.
  assert (P 1) by aXdmit.
  trw_h Hiff  X.
  trw Hiff .  apply t_iff_refl.
Qed.

(*
Theorem trw_demo2:
  forall (P Q: nat -> Type),
    (forall n, P n <o> forall m, Q m )
    -> ((P 1 * void -> void ) <o> ((forall m, Q m) * void -> void )).
Proof.
  intros ? ?  Hiff.
  constructor; intros.
  destruct X; auto.
  destruct X; auto.
Qed.
*)

Theorem trw_demo2:
  forall (P Q: nat -> Type),
    (forall n, P n <o> forall m, Q m )
    -> ((P 1 * void -> void ) <o> ((forall m, Q m) * void -> void )).
Proof.
  intros ? ?  Hiff.
  trw Hiff.
  apply t_iff_refl.
Qed.
*)

(**  --- setoid stuff -- delete? *)

Require Export Coq.Setoids.Setoid.

Inductive Cast (t : Type) : Prop :=
| cast : t -> Cast t.
Hint Constructors Cast.

Inductive Cast2 (p : Prop) : Type :=
| cast2 : p -> Cast2 p.
Hint Constructors Cast2.

Definition c_t_iff : relation Type :=
  fun A B : Type => Cast (A <o> B).

Notation "x <==> y" := (c_t_iff x y) (at level 95, no associativity).

Definition t_c_iff : relation Type :=
  fun A B : Type => Cast (A -> B) /\ Cast (B -> A).

Notation "x <~> y" := (t_c_iff x y) (at level 95, no associativity).

Lemma CType_S : Setoid_Theory Type c_t_iff.
Proof.
  split.

  repeat constructor; auto.

  unfold Symmetric; intros.
  inversion H; subst.
  dall.
  repeat constructor; auto.

  unfold Transitive; intros.
  inversion H; inversion H0; subst.
  dall.
  repeat constructor; auto.
Qed.

Lemma TypeC_S : Setoid_Theory Type t_c_iff.
Proof.
  split.

  repeat constructor; auto.

  unfold Symmetric; intros.
  destruct H.
  inversion H; subst.
  inversion H0; subst.
  repeat constructor; auto.

  unfold Transitive; intros.
  destruct H; destruct H0.
  inversion H; inversion H0; inversion H1; inversion H2; subst.
  repeat constructor; auto.
Qed.

Add Setoid Type c_t_iff CType_S as Type_iff_reg.
Add Setoid Type t_c_iff TypeC_S as Type_iff_reg2.

Hint Resolve (Seq_refl  Type c_t_iff CType_S): setoid.
Hint Resolve (Seq_sym   Type c_t_iff CType_S): setoid.
Hint Resolve (Seq_trans Type c_t_iff CType_S): setoid.

Hint Resolve (Seq_refl  Type t_c_iff TypeC_S): setoid.
Hint Resolve (Seq_sym   Type t_c_iff TypeC_S): setoid.
Hint Resolve (Seq_trans Type t_c_iff TypeC_S): setoid.

(* ============================================== *)

(*
Lemma test :
  forall a b (*c f*), (a <o> b) -> Cast a. (*.  ## { x : c | f x }.*)
Proof.
  intros.
  rewrite X.
Qed.
*)

(** should not be required anymore? *)

Tactic Notation "trewrite" "<-" ident(H) ident(p1) :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_rev name;
    clear name.

Tactic Notation "trewrite" "<-" ident(H) ident(p1) ident(p2) :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_rev name;
    clear name.
Tactic Notation "trewrite" ident(H) ident(p1) :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite name;
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) ident(p2) :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite name;
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) "in" ident (H') :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_hyp name H';
    clear name.

Tactic Notation "trewrite" ident(H) ident(p1) ident(p2) "in" ident (H') :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_hyp name H';
    clear name.
Tactic Notation "trewrite" "<-" ident(H) ident(p1) "in" ident(H') :=
  let name := fresh H in
  generalize (H p1);
    intro name;
    build_and_rewrite_hyp_rev name H';
    clear name.

Tactic Notation "trewrite" "<-" ident(H) ident(p1) ident(p2) "in" ident(H') :=
  let name := fresh H in
  generalize (H p1 p2);
    intro name;
    build_and_rewrite_hyp_rev name H';
    clear name.

Theorem dont_touch_forall :
  forall (P Q : (nat : Set) -> Type),
    (forall (n : (nat : Set)), P n <o> (forall (m : (nat : Set)), Q (m+n)))
    -> P (1 : (nat : Set))
    -> forall (m : (nat : Set)), Q (m+1).
Proof.
  intros ? ? Hif Hp1.

  rw Hif in Hp1; trivial.
Qed.

Theorem dont_touch_forall2 :
  forall (P Q : nat -> Type),
    (forall n, P n <o> (forall m, Q (m+n)))
    -> P 1
    -> forall m, Q (m+1).
Proof.
  intros ? ?  Hif Hp1.
  trw_rev Hif. trivial.
Qed.

Theorem dont_touch_forall3 :
  forall (P Q: nat -> Type),
    (forall n, P n <o> (forall m, Q (m+n)))
    -> (forall m, Q (m+1))
    -> P 1.
Proof.
  intros ? ? Hif Hq .
  trw_rev_h Hif Hq. trivial.
Qed.


From mathcomp Require Import all_ssreflect.
Require Import Coq.Unicode.Utf8_core.

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

(*#############################################################################*)
(** The logic of canonical structure for class system.

    We can use canonical structures to simulate a class system in the
    object-oriented programming style. Here is a construction template.
*)

(** The Construction of a class. Here we assume the parameter for the class is
    [T : Type], which can be changed. *)
Module ClassName.
Section ClassDef.

(** The current class may be inherited from multiple classes. Type [mixin_of]
    contains all extra constructions or properties for this class.

    Note that information about base classes should be type of [class_of], not
    [mixin_of].
    *)
Structure mixin_of (T : Type) (** <extra parameters> *) := Mixin {

    (** <some definition here> *)

}.

(** The class information for this type, including the class information
    [class_of] for base classes and the extra mixin. *)
#[projections(primitive)]
Structure class_of (T : Type) := Class {

    (** <some definition here> *)

    mixin : mixin_of T (** <extra parameters> *);
}.

(** If the current class has no base classes, then [class_of] is identical with
    [mixin_of], and can be defined as an abbreviation:

Definition class_of := mixin_of.
*)

(** <some local coercions from [class_of] to base classes> *)

Structure type (** <template parameter> *) := Pack { obj; _ : class_of obj }.

Local Coercion obj : type >-> Sortclass.

Variables (T : Type) (cT : type).

(** This definition is meant to take out the class information of an instance. *)
Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.

(** This definition is for convenient construction of instances. The method
    takes in a [mixin_of] instance and outputs a class instance. *)
Definition pack (m : mixin_of T) : type := Pack (@Class T m).

(** If [class_of] is defined as an abbreviation, then so should pack be:

Definition pack := Pack.
*)

(** Here we should define some transformation to base class instances. *)

End ClassDef.

(** We can give some extra definition about this class here. *)

Module Exports.
(** <Coercion of class information> *)
#[reversible]
Coercion mixin : class_of >-> mixin_of.
(** Coercion to parameter [T]
    IMPORTANT : most of the time we want Coq to go through all of its base
    classes one by one. In such cases this direct coercion should be removed.
*)
#[reversible]
Coercion obj : type >-> Sortclass.
(** <Coercion and Canonical to base type instances> *)

(** Some renaming *)
Notation classType := type.
Notation ClassType T m := (@pack T m).

(** Here we can define some descriptive notations like [[ classType of T ]],
    but they are not necessary because reversible coercions can act the same.*)
End Exports.

End ClassName.
Export ClassName.Exports.

(** The procedure of constructing an instance is as follows:
    1. Construct a [mixin_of] term.
    2. Construct the canonical structure using [ClassName] method.
*)


Require Import HoTT.
From HoTT.Categories Require Import Category Functor NaturalTransformation.
Require Import GR.bicategories.bicategories.
Require Import GR.bicategories.lax_functors.
Require Import GR.bicategories.lax_transformations.
From GR.groupoid Require Import
     groupoid_quotient.gquot
     groupoid_quotient.gquot_functor
     groupoid_quotient.gquot_principles
     grpd_bicategory.grpd_bicategory
     path_groupoid.path_groupoid.
From GR.basics Require Import
     general.

Section Unit.
  Context `{Univalence}.

  Definition unit_map (G : groupoid)
    : grpd⟦G,path_groupoid(gquot_functor G)⟧.
  Proof.
    simple refine (Build_Functor _ _ _ _ _ _) ; simpl.
    - exact (gcl G).
    - exact (@gcleq G).
    - exact (@gconcat G).
    - exact (ge G).
  Defined.

  Definition unit_gq_1
             {G₁ G₂ : groupoid}
             {x y : G₁}
             (F : Functor G₁.1 G₂.1)
             (g : hom G₁ x y)
    : ap (gquot_functor_map F) (gcleq G₁ g) @ 1
      =
      1 @ gcleq G₂ (F _1 g)%morphism.
  Proof.
    exact ((concat_p1 _)
             @ (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _)
             @ (concat_1p _)^).
  Qed.

  Definition unit_gq_2
             {G₁ G₂ : groupoid}
             {x y : G₁}
             (F : Functor G₁.1 G₂.1)
             (g : hom G₁ x y)
    : gcleq G₂ (F _1 g)%morphism @ 1
      =
      1 @ ap (gquot_functor_map F) (gcleq G₁ g).
  Proof.
    exact ((concat_p1 _)
             @ (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _)^
             @ (concat_1p _)^).
  Qed.

  Definition unit_gq_d
    : PseudoTransformation_d
        (lax_id_functor grpd)
        (lax_comp path_groupoid_functor gquot_functor).
  Proof.
    make_pseudo_transformation.
    - exact unit_map.
    - intros G₁ G₂ F.
      simple refine (Build_NaturalTransformation _ _ _ _).
      + reflexivity.
      + intros x y g.
        exact (unit_gq_1 F g).
    - intros G₁ G₂ F.
      simple refine (Build_NaturalTransformation _ _ _ _).
      + reflexivity.
      + intros x y g.
        exact (unit_gq_2 F g).
  Defined.

  Definition unit_gq_is_lax
    : is_pseudo_transformation_p unit_gq_d.
  Proof.
    make_is_pseudo_transformation.
    - intros G₁ G₂ F₁ F₂ α.
      apply path_natural_transformation.
      intros x ; simpl.
      rewrite ap10_path_forall.
      rewrite !concat_1p, !concat_p1.
      reflexivity.
    - intros G.
      apply path_natural_transformation.
      intros x ; simpl.
      rewrite ap10_path_forall.
      rewrite ge.
      reflexivity.
    - intros G₁ G₂ G₃ F₁ F₂.
      apply path_natural_transformation.
      intro x ; simpl.
      rewrite ap10_path_forall.
      rewrite !ge.
      reflexivity.
    - intros G₁ G₂ F.
      apply path_natural_transformation.
      intros x ; simpl.
      reflexivity.
    - intros G₁ G₂ F.
      apply path_natural_transformation.
      intro ; reflexivity.
  Qed.

  Definition unit_gq
    : PseudoTransformation
        (lax_id_functor grpd)
        (lax_comp path_groupoid_functor gquot_functor)
    := Build_PseudoTransformation unit_gq_d unit_gq_is_lax.
End Unit.


(* Narjes Jomaa and David Nowak,
   Pip code refactored by Mohamed Sami Cherif *)
(**PIP STATE *)
Require Import List Bool Arith Omega Lib.
Import List.ListNotations.

Axiom tableSize nbLevel nbPage: nat.
Axiom nbLevelNotZero: nbLevel > 0.
Axiom nbPageNotZero: nbPage > 0.
Axiom tableSizeIsEven : Nat.Even tableSize.
Definition tableSizeLowerBound := 14.
Axiom tableSizeBigEnough : tableSize > tableSizeLowerBound.

Record index := {
  i :> nat ;
  Hi : i < tableSize }.

Record page := {
  p :> nat;
  Hp : p < nbPage }.

Definition paddr := (page * index)%type.

Record vaddr := {
  va :> list index ;
  Hva : length va = nbLevel + 1}.

Record level := {
  l :> nat ;
  Hl : l < nbLevel }.

Record count := {
  c :> nat ;
  Hnb : c <= (3*nbLevel) + 1  ;
 }.

Parameter index_d : index.
Parameter page_d : page.
Parameter level_d : level.

Require Import Coq.Program.Tactics.

Program Definition CIndex  (p : nat) : index :=
if (lt_dec p tableSize) then
Build_index p _ else index_d.

Program Definition CPage (p : nat) : page :=
if (lt_dec p nbPage) then Build_page p _ else  page_d.

Program Definition CVaddr (l: list index) : vaddr :=
if ( Nat.eq_dec (length l)  (nbLevel+1))
  then Build_vaddr l _
  else Build_vaddr (repeat (CIndex 0) (nbLevel+1)) _.

Program Definition CLevel ( a :nat) : level :=
if lt_dec a nbLevel then  Build_level a _
else level_d .

(* BEGIN NOT SIMULATION *)

Next Obligation.
apply repeat_length.
Qed.

(* END NOT SIMULATION *)

Record Pentry : Type:=
{read :bool;
 write : bool ;
 exec : bool;
 present : bool;
 user    : bool;
 pa      : page
}.

Record Ventry : Type:=
{
 pd : bool;
 vad : vaddr
}.

Inductive value : Type:=
|PE : Pentry -> value
|VE : Ventry -> value
|PP : page -> value
|VA : vaddr -> value
|I  : index -> value.

Record state : Type := {
 currentPartition : page;
 memory : list (paddr * value)
}.

Definition multiplexer := CPage 1.

(** Fix virtual addresses positions into the partition descriptor
    of the partition (+1 to get the physical page position) *)
Definition PRidx := CIndex 0.   (* descriptor *)
Definition PDidx := CIndex 2.   (* page directory *)
Definition sh1idx := CIndex 4.  (* shadow1 *)
Definition sh2idx := CIndex 6.  (* shadow2 *)
Definition sh3idx := CIndex 8.  (* configuration pages list*)
Definition PPRidx := CIndex 10. (* parent (virtual address is null) *)

Definition beqIndex (a b : index) : bool := a =? b.
Definition beqPage (a b : page) : bool := a =? b.
Definition beqVAddr (a b : vaddr) : bool := eqList a b beqIndex.

(** default values *)
Definition defaultIndex := CIndex 0.
Definition defaultVAddr := CVaddr (repeat (CIndex 0) nbLevel).
Definition defaultPage := CPage 0.

(** Define first level number *)
Definition fstLevel :=  CLevel 0.

(** Define the entry position of the kernel mapping into the first indirection
    of partitions *)
Definition Kidx := CIndex 1.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.Semantics.StrongSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Class SepconSemantics
      (L: Language)
      {sepconL: SepconLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
  denote_sepcon: forall x y, Same_set _ (Kdenotation M (x * y)) (StrongSemantics.sepcon (Kdenotation M x) (Kdenotation M y)).

Class WandSemantics
      (L: Language)
      {wandL: WandLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
  denote_wand: forall x y, Same_set _ (Kdenotation M (x -* y)) (WeakSemantics.wand (Kdenotation M x) (Kdenotation M y)).

Class EmpSemantics
      (L: Language)
      {empL: EmpLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
  denote_emp: Same_set _ (Kdenotation M emp) WeakSemantics.emp.

Lemma sat_sepcon
      {L: Language}
      {sepconL: SepconLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {dsepconSM: SepconSemantics L MD M SM}:
  forall m x y,
    KRIPKE: M , m |= x * y <->
    exists m0 m1 m2, m0 <= m /\
                     join m1 m2 m0 /\
                     KRIPKE: M , m1 |= x /\
                     KRIPKE: M, m2 |= y.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_sepcon x y).
  split; [apply H | apply H0].
Qed.

Lemma sat_wand
      {L: Language}
      {wandL: WandLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {dwandSM: WandSemantics L MD M SM}:
  forall m x y,
    KRIPKE: M , m |= x -* y <->
    forall m1 m2, join m m1 m2 ->
                  KRIPKE: M , m1 |= x ->
                  KRIPKE: M, m2 |= y.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_wand x y).
  split; [apply H | apply H0].
Qed.

Lemma sat_emp
      {L: Language}
      {empL: EmpLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {dempSM: EmpSemantics L MD M SM}:
  forall (m: Kworlds M), KRIPKE: M, m |= emp <-> increasing m.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct denote_emp.
  split; [apply H | apply H0].
Qed.


Require Export D.

(** 1 star, optional (proj2)  *)
Theorem proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros P Q H. destruct H as [HP HQ]. apply HQ.
Qed.


Require Import datatypes.

(*** Section 4 of the paper ***)

CoFixpoint Bs := Cons B Bs.

CoFixpoint same (a:Sym) := Cons a (same a).

CoFixpoint blink (a b:Sym) := Cons a (Cons b (blink a b)).

CoFixpoint merge (h k:HTape) :=
           match h with | Cons a h' =>
           match k with | Cons b k' => Cons a (Cons b (merge h' k'))
           end end.

CoInductive EqH: HTape -> HTape -> Prop :=
            eqh: forall a:Sym, forall h k:HTape,
                 EqH h k -> EqH (Cons a h) (Cons a k).

Lemma unfold_HTape: forall h:HTape,
                    h = match h with | Cons a k => Cons a k end.
destruct h. auto.
Qed.

Lemma unfold_same: forall a:Sym, same a = (Cons a (same a)).
intro. apply (unfold_HTape (same a)).
Qed.

Lemma unfold_blink: forall a b:Sym, blink a b = (Cons a (Cons b (blink a b))).
intros. apply (unfold_HTape (blink a b)).
Qed.

Lemma unfold_merge: forall a b:Sym, forall h k:HTape,
      merge (Cons a h) (Cons b k) = (Cons a (Cons b (merge h k))).
intros. apply (unfold_HTape (merge (Cons a h) (Cons b k))).
Qed.

Lemma example: forall a b:Sym,
               EqH (merge (same a) (same b))
                   (blink a b).
cofix co_hp. intros.
rewrite unfold_same. rewrite (unfold_same b). rewrite unfold_merge.
rewrite (unfold_blink a b).
do 2 apply eqh. apply co_hp.
Qed.