(**
MathComp の subset について
======
2019/05/01

この文書のソースコードは以下にあります。

https://github.com/suharahiromichi/coq/blob/master/pearl/ssr_subset.v

 *)

(**
OCaml 4.07.1, Coq 8.9.0, MathComp 1.9.0
 *)

(**
# 説明

MathComp では、``∈`` を示す `\in` は広く使われるために、``ssrbool.v`` で導入されますが、
部分集合 ``⊆`` を示す、``\subset`` は、fintype.v で導入されています。

要素がすべて列挙できる有限型 ``T : finType`` の上で、そのT の enumを全集合とすることで、
ひと通りの集合演算が定義できるようになるからです。

``T : finType`` のとき、booleanな関数 ``P : T -> bool`` を集合と同一視して、
``P x`` を ``x \in P`` と同一視します。

すると、その上で、集合 A と B の積を
``x ∈ A ∩ B`` <-> `` (λx. A x ∧ B x) x``

P の補集合を
``x ∈ P^c`` <-> `` (λx. ¬ P x)``

と定義できます。

T の enum に対してPでフィルタすることで、Pの要素がすべて求められるので、
その数を数えるとPの濃度を求めることができます。

表記法 Notation については、文献[1.]の表5.1などを参照してください。

また、``P : T -> bool`` を ``P : pred T`` と書くこともありますが、
これは表記のみの違いです。

さて、ここからが本題です。

集合Aが集合Bの部分集合 ``A ⊆ B`` であるとは、A の任意の要素が B の要素であることです。
``\subset`` 演算子が定義されている MathComp の finset.v のコメントには、
実際、そのように記載されています。

``A \subset B == all x \in A satisfy x \in B.`` ..................... (1)

しかし、MathComp の実際の定義は、

``pred0b [predI A & [predC B]]`` .................................... (2)

となっていて、これは、
「論理式 A を満たし、論理式 B を満たさない要素の数が 0 である」という意味です。

(1)と(2)は同値のはずですが、それを証明する補題がなかった（見つけられなかった）ので、
証明してみました。

*)

(**
# コード例

最初に、通常の Prop 型論理式について同値であることを証明します。

 ``s1 ⊆ s2 <-> ∀x. x ⊆ s1 -> x ⊆ s2``

その後、（MathComp らしく）boolean な論理式について真偽値が一致することを証明します。
*)

From mathcomp Require Import all_ssreflect.

Section Test.

  Variable T : finType.

(**
## Prop な論理式での証明
 *)

  Lemma subsetP (s1 s2 : pred T) :
    s1 \subset s2 <-> (forall x, x \in s1 -> x \in s2).
  Proof.
    rewrite subset_disjoint /disjoint.
    split.
    - move/pred0P => H.
      move=> x Hs1.
      move: (H x) => {H} /= /eqP.
      rewrite inE eqbF_neg negb_and /=.
      move/orP => [Hn1 | Hnn2].
      + by move/negP : Hn1.
      + by rewrite Bool.negb_involutive in Hnn2.

    - move=> H.
      apply/pred0P => x.
      apply/andP => [[H1 Hn2]].
      rewrite inE /= in Hn2.
      move/negP in Hn2.
        by apply/Hn2/H.
  Qed.

(**
## boolean な論理式での証明
 *)

  Lemma subsetE (s1 s2 : pred T) :
    s1 \subset s2 = [forall x, (x \in s1) ==> (x \in s2)].
  Proof.
    apply/idP/idP.
    - move=> H.
      apply/forallP => x.
      apply/implyP.
      by apply/subsetP : x.

    - move=> H.
      apply/subsetP => x.
      move/forallP in H.
      by move: (H x) => {H} /implyP H /=.
  Qed.

(**
# 最初に使った箇所

単一化の証明 http://fetburner.hatenablog.com/entry/2015/12/06/224619

Unify.v を MathComp への移植するときに必要になりました。移植例：

https://github.com/suharahiromichi/coq/blob/master/unify/ssr_unify_bool_3.v
*)

(**
# おまけ

## 直接 boolean の式を証明する
 *)

  Lemma subsetE' (s1 s2 : pred T) :
    s1 \subset s2 = [forall x, (x \in s1) ==> (x \in s2)].
  Proof.
    rewrite subset_disjoint /disjoint.
    apply/idP/idP.
    - move/pred0P => H.
      apply/forallP => x.
      apply/implyP => Hs1.
      move: (H x) => {H} /= /eqP.
      rewrite inE eqbF_neg negb_and /=.
      move/orP => [Hn1 | Hnn2].
      + by move/negP : Hn1.
      + by rewrite Bool.negb_involutive in Hnn2.

    - move/forallP => H.
      apply/pred0P => x.
      move: (H x) => {H} /implyP H /=.
      apply/andP => [[H1 Hn2]].
      rewrite inE /= in Hn2.
      move/negP in Hn2.
        by apply/Hn2/H.
  Qed.

End Test.

(**
# 参考文献

[1.] 萩原学 アフェルト・レナルド 「Coq/SSReflect/MathCompによる定理証明」 森北出版

*)

(* END *)


Require Export SfLib.

(* ********************************************** *)
(* Problem 1 *)
(* ********************************************** *)

Inductive suffix {X : Type} : list X -> list X -> Prop :=
  | suffix_1 : forall xs,
     suffix xs xs
  | suffix_2 : forall x xs ys,
     suffix xs ys -> suffix (x::xs) (ys).

Theorem suffix_app : forall (X:Type) (x:X) (xs ys:list X),
  suffix xs ys -> exists ws, xs = ws ++ ys.
Proof.
  intros.
  induction H.
  - exists ([]). reflexivity.
  - inversion H. subst.
    + exists ([x0]). reflexivity.
   + inversion H. subst.
      * exists([x0]). simpl. rewrite H4. reflexivity.
      * subst. inversion IHsuffix.
        exists(x0::x3). rewrite H1. simpl. reflexivity.
Qed.

Inductive member {X : Type} : X -> list X -> Prop :=
  | member_here : forall x xs,
      member x (x :: xs)
  | member_later : forall x y xs,
      member x xs -> member x (y :: xs).

Theorem app_member_left : forall (X:Type) (x:X) (xs ys: list X),
  member x xs -> member x (xs ++ ys).
Proof.
  intros.
  induction H.
  + simpl. apply member_here.
  + simpl. apply member_later.
     apply IHmember.
Qed.

Theorem app_member_right : forall (X:Type) (x:X) (xs ys: list X),
  member x ys -> member x (xs ++ ys).
Proof.
  intros.
  induction xs.
  + simpl. assumption.
  + simpl. constructor. assumption.
Qed.

Theorem or_app_member : forall (X:Type) (x:X) (xs ys: list X),
  member x xs \/ member x ys -> member x (xs ++ ys).
Proof.
  intros.
  inversion H.
  + generalize dependent H0. apply app_member_left.
  + generalize dependent H0. apply app_member_right.
Qed.

Theorem app_or_member : forall (X:Type) (x:X) (xs ys: list X),
  member x (xs ++ ys) -> member x xs \/ member x ys.
Proof.
  intros.
  induction xs.
  + right. simpl in H. assumption.
  + inversion H. subst.
     * left. constructor.
     * apply IHxs in H2. destruct H2.
        - left. constructor. assumption.
        - right. assumption.
Qed.

(* ********************************************** *)
(* Problem 2 *)
(* ********************************************** *)

(* States *)

Definition state := id -> nat.

Definition empty_state : state :=
  fun _ => 0.

Definition update (st : state) (x : id) (n : nat) : state :=
  fun x' => if eq_id_dec x x' then n else st x'.

(* Arithmetic and boolean expressions *)

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Tactic Notation "aexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ANum" | Case_aux c "AId" | Case_aux c "APlus"
  | Case_aux c "AMinus" | Case_aux c "AMult" ].

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Tactic Notation "bexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "BTrue" | Case_aux c "BFalse" | Case_aux c "BEq"
  | Case_aux c "BLe" | Case_aux c "BNot" | Case_aux c "BAnd" ].

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => ble_nat (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

(* Commands *)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";;"
  | Case_aux c "IFB" | Case_aux c "WHILE"
  | Case_aux c "CRepeat" ].

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

(* Evaluation relation *)

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st || (update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || st' ->
      c2 / st' || st'' ->
      (c1 ;; c2) / st || st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st || st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st || st' ->
      (WHILE b DO c END) / st' || st'' ->
      (WHILE b DO c END) / st || st''
  (* !!! *)
  | E_RepeatEnd : forall st st' b c,
      c / st || st' ->
       beval st' b = true ->
       (REPEAT c UNTIL b END) / st || st'
  | E_LoopLoop : forall st st' st'' b c,
        c / st || st' ->
        beval st' b = false ->
        (REPEAT c UNTIL b END) / st' || st'' ->
        (REPEAT c UNTIL b END) / st || st''

  where "c1 '/' st '||' st'" := (ceval c1 st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop"
  | Case_aux c "E_RepeatEnd" | Case_aux c "E_LoopLoop" ].

(* Assertions *)

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* Hoare triples *)

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

(* Assertions *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(* Assignment *)

(*
             ------------------------------ (hoare_asgn)
             {{Q [X |-> a]}} X::=a {{Q}}
*)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

(* Consequence *)

(*
                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

(* Skip *)

(*
             --------------------  (hoare_skip)
             {{ P }} SKIP {{ P }}
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* Sequencing *)

(*
               {{ P }} c1 {{ Q }}
               {{ Q }} c2 {{ R }}
              ---------------------  (hoare_seq)
              {{ P }} c1;;c2 {{ R }}
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

(* Conditional *)

(*
              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  Case "b is true".
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  Case "b is false".
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(* While *)

(*
               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}
    The proposition [P] is called an _invariant_ of the loop.
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on [He], because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just [c]. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  ceval_cases (induction He) Case;
    try (inversion Heqwcom); subst; clear Heqwcom.
  Case "E_WhileEnd".
    split. assumption. apply bexp_eval_false. assumption.
  Case "E_WhileLoop".
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

(* Repeat *)
(*
                      {{P}} c {{Q}}
                     Q /\ ~b ->> P
      --------------------------------------------------------(hoare_loop)
        {{P}} REPEAT c UNTIL b END {{Q /\ b }}
*)

(* !!! *)

Theorem hoare_loop: forall P Q b c,
  {{P}} c {{Q}} ->
  (fun st => Q st /\ ~ ((bassn b) st)) ->> P ->
  {{P}} REPEAT c UNTIL b END {{fun st => Q st /\ ((bassn b) st)}}.
Proof.
  intros P Q b c Htriple Himp st st' He HP.
  remember (REPEAT c UNTIL b END) as rcom eqn : Heqrcom.
  ceval_cases (induction He) Case;
  inversion Heqrcom; subst; clear Heqrcom.
  + (* E_RepeatEnd *)
     split.
     - apply (Htriple st st'). assumption. assumption.
     - apply bexp_eval_true. assumption.
  + (* E_LoopLoop *)
     apply IHHe2. reflexivity.
     apply (Himp st').
     split.
     - apply (Htriple st st'). assumption. assumption.
     - apply bexp_eval_false. assumption.
Qed.

(* ********************************************** *)
(* Problem 3 *)
(* ********************************************** *)

(* Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty
  | TTree   : ty -> ty.

(* Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm
  | tbranch : tm -> tm -> tm -> tm
  | tcase : tm -> tm -> id -> id -> id -> tm -> tm
  | tleaf : tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "ttrue"
  | Case_aux c "tfalse" | Case_aux c "tif"
  | Case_aux c "tbranch" | Case_aux c "tcase"
  | Case_aux c "tleaf" ].

(* Values *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse
  | v_leaf:
      value tleaf
  | v_branch : forall v1 v2 v3,
      value v1 -> value v2 -> value v3 ->
      value (tbranch v1 v2 v3).

Hint Constructors value.

(* Substitution *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if eq_id_dec x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if eq_id_dec x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  | tbranch t1 t2 t3 =>
      tbranch ([x:=s] t1) ([x:=s] t2)([x:=s] t3)
  | tcase t1 t2 xt y zt t3 =>
      tcase ([x:=s] t1) ([x:=s] t2) xt y zt
      (if eq_id_dec x xt then
            t3
        else if eq_id_dec x y then
            t3
        else if eq_id_dec x zt then
            t3
        else
            ([x:=s] t3))
  | tleaf =>
     tleaf
  end

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

(* Evaluation relation *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)
  (* !!! *)
  | ST_BranchLeft : forall t1 t2 t3 t1',
       t1 ==> t1' ->
      (tbranch t1 t2 t3) ==> (tbranch t1' t2 t3)
  | ST_BranchMiddle : forall v1 t2 t3 t2',
       value v1 ->
       t2 ==> t2' ->
      (tbranch v1 t2 t3) ==> (tbranch v1 t2' t3)
  | ST_BranchRight : forall t3 v1 v2 t3',
       t3 ==> t3' -> value v1 -> value v2 ->
      (tbranch v1 v2 t3) ==> (tbranch v1 v2 t3')
  | ST_TCase : forall t1 t1' t2 t3 xt y zt,
       t1 ==> t1' ->
      (tcase t1 t2 xt y zt t3) ==> (tcase t1' t2 xt y zt t3)
  | ST_TCaseLeaf : forall t2 t3 xt y zt,
      (tcase tleaf t2 xt y zt t3) ==> t2
  | ST_TCaseBranch : forall v11 v12 v13 t2 t3 xt y zt,
       value v11 -> value v12 -> value v13 ->
      (tcase (tbranch v11 v12 v13) t2 xt y zt t3) ==> ([xt := v11]([y := v12]([zt:=v13] t3)))

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

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1"
  | Case_aux c "ST_App2" | Case_aux c "ST_IfTrue"
  | Case_aux c "ST_IfFalse" | Case_aux c "ST_If"
  | Case_aux c "ST_BranchLeft" | Case_aux c "ST_BranchMiddle"
  | Case_aux c "ST_BranchRight" | Case_aux c "ST_TCase"
  | Case_aux c "ST_TCaseLeaf" | Case_aux c "ST_TCaseBranch"].

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

(* Contexts *)

Module PartialMap.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

(** Informally, we'll write [Gamma, x:T] for "extend the partial
    function [Gamma] to also map [x] to [T]."  Formally, we use the
    function [extend] to add a binding to a partial map. *)

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if eq_id_dec x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite eq_id. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  x2 <> x1 ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.

End PartialMap.

Definition context := partial_map ty.

(* Typing relation *)

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

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      extend Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T
  (* !!! *)
  | T_Leaf : forall Gamma T,
        Gamma |- tleaf \in (TTree T)
  | T_Branch : forall Gamma T t1 t2 t3,
        Gamma |- t1 \in (TTree T) ->
        Gamma |- t2 \in T ->
        Gamma |- t3 \in (TTree T) ->
        Gamma |- (tbranch t1 t2 t3) \in (TTree T)
  | T_TCase : forall Gamma t0 t1 t2 T T' xt y zt,
        Gamma |- t0 \in (TTree T) ->
        Gamma |- t1 \in T' ->
        extend (extend (extend Gamma xt (TTree T)) y T) zt (TTree T)
               |- t2 \in T' ->
        Gamma |- (tcase t0 t1 xt y zt t2) \in T'

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

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs"
  | Case_aux c "T_App" | Case_aux c "T_True"
  | Case_aux c "T_False" | Case_aux c "T_If"
  | Case_aux c "T_Leaf" | Case_aux c "T_Branch"
  | Case_aux c "T_TCase"].

Hint Constructors has_type.

(* Canonical Forms *)

Lemma cannonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma cannonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x. exists t0.  auto.
Qed.

(* Progress, by induction on type derivation *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Ht) Case; subst Gamma...
  Case "T_Var".
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  Case "T_App".
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    SCase "t1 is a value".
      destruct IHHt2...
      SSCase "t2 is also a value".
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply cannonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      SSCase "t2 steps".
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    SCase "t1 steps".
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  Case "T_If".
    right. destruct IHHt1...

    SCase "t1 is a value".
      destruct (cannonical_forms_bool t1); subst; eauto.

    SCase "t1 also steps".
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
  (* !!! *)
  Case "T_Branch".
    destruct IHHt1...
       SCase "t1 is a value".
          destruct IHHt2...
          SSCase "t2 is also a value".
            destruct IHHt3...
                SSSCase "t3 is a step".
                right. inversion H1.  exists (tbranch t1 t2 x)...
          SSCase "t2 steps".
            inversion H0.
            right. exists (tbranch t1 x t3)...
        SCase "t1 steps".
        right. inversion H. exists (tbranch x t2 t3)...

   Case "T_TCase".
       destruct IHHt1...
       SCase "t0 is a value".
           inversion H; subst; try solve by inversion...
       SCase "t0 steps".
           right. inversion H. exists (tcase x t1 xt y zt t2)...
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Definition unit  := unit.

Parameter qtmark : Type.

Parameter at1: forall (a:Type), a -> qtmark -> a.

Implicit Arguments at1.

Parameter old: forall (a:Type), a -> a.

Implicit Arguments old.

Parameter fib: Z -> Z.

Axiom fib0 : ((fib 0%Z) = 0%Z).

Axiom fib1 : ((fib 1%Z) = 1%Z).

Axiom fibn : forall (n:Z), (2%Z <= n)%Z ->
  ((fib n) = ((fib (n - 1%Z)%Z) + (fib (n - 2%Z)%Z))%Z).

Axiom Abs_le : forall (x:Z) (y:Z), ((Zabs x) <= y)%Z <-> (((-y)%Z <= x)%Z /\
  (x <= y)%Z).

Parameter div: Z -> Z -> Z.

Parameter mod1: Z -> Z -> Z.

Axiom Div_mod : forall (x:Z) (y:Z), (~ (y = 0%Z)) -> (x = ((y * (div x
  y))%Z + (mod1 x y))%Z).

Axiom Div_bound : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z <  y)%Z) ->
  ((0%Z <= (div x y))%Z /\ ((div x y) <= x)%Z).

Axiom Mod_bound : forall (x:Z) (y:Z), (~ (y = 0%Z)) -> ((0%Z <= (mod1 x
  y))%Z /\ ((mod1 x y) <  (Zabs y))%Z).

Axiom Mod_1 : forall (x:Z), ((mod1 x 1%Z) = 0%Z).

Axiom Div_1 : forall (x:Z), ((div x 1%Z) = x).

Inductive t  :=
  | mk_t : Z -> Z -> Z -> Z -> t .

Definition a11(u:t): Z := match u with
  | (mk_t a111 _ _ _) => a111
  end.

Definition a12(u:t): Z := match u with
  | (mk_t _ a121 _ _) => a121
  end.

Definition a21(u:t): Z := match u with
  | (mk_t _ _ a211 _) => a211
  end.

Definition a22(u:t): Z := match u with
  | (mk_t _ _ _ a221) => a221
  end.

Definition mult(x:t) (y:t): t :=
  (mk_t (((a11 x) * (a11 y))%Z + ((a12 x) * (a21 y))%Z)%Z
  (((a11 x) * (a12 y))%Z + ((a12 x) * (a22 y))%Z)%Z
  (((a21 x) * (a11 y))%Z + ((a22 x) * (a21 y))%Z)%Z
  (((a21 x) * (a12 y))%Z + ((a22 x) * (a22 y))%Z)%Z).

Parameter power: t -> Z -> t.

Axiom Power_0 : forall (x:t), ((power x 0%Z) = (mk_t 1%Z 0%Z 0%Z 1%Z)).

Axiom Power_s : forall (x:t) (n:Z), (0%Z <= n)%Z -> ((power x
  (n + 1%Z)%Z) = (mult x (power x n))).

Axiom Power_1 : forall (x:t), ((power x 1%Z) = x).

Axiom Power_sum : forall (x:t) (n:Z) (m:Z), ((0%Z <= n)%Z /\ (0%Z <= m)%Z) ->
  ((power x (n + m)%Z) = (mult (power x n) (power x m))).

Axiom Power_mult : forall (x:t) (n:Z) (m:Z), (0%Z <= n)%Z -> ((0%Z <= m)%Z ->
  ((power x (n * m)%Z) = (power (power x n) m))).

(* YOU MAY EDIT THE CONTEXT BELOW *)
Hint Resolve fib0 fib1.
(* DO NOT EDIT BELOW *)

Theorem fib_m : forall (n:Z), (0%Z <= n)%Z -> let p := (power (mk_t 1%Z 1%Z
  1%Z 0%Z) n) in (((fib (n + 1%Z)%Z) = (a11 p)) /\ ((fib n) = (a21 p))).
(* YOU MAY EDIT THE PROOF BELOW *)
intros n hn.
pattern n; apply natlike_ind; intuition.
rewrite Power_0.
unfold a11, a21; simpl; auto.
replace (Zsucc  x) with (x+1)%Z by omega.
rewrite Power_s; auto.
destruct H0 as (h1,h2).
split.
rewrite fibn; try omega.
ring_simplify (x+1+1-1)%Z.
ring_simplify (x+1+1-2)%Z.
unfold a11, mult.
rewrite <- h1. rewrite <- h2.
unfold a11, a12. ring.
unfold a21, mult.
rewrite <- h1. rewrite <- h2.
unfold a21, a22. ring.
Qed.
(* DO NOT EDIT BELOW *)


Require Import UniDB.
Require Import List.
Import ListNotations.

Inductive Ty : Set :=
  | arr (σ τ : Ty)
  | top.

Inductive Tm : Set :=
  | var (i : Ix)
  | abs (σ : Ty) (t : Tm)
  | app (t1 t2 : Tm)
  | ttt.

Fixpoint trTm {Ξ : Type} `{Lk Tm Ξ, Up Ξ} (t : Tm) (ξ : Ξ) : Tm :=
  match t with
  | var i     => lk Tm Ξ ξ i
  | abs σ t   => abs σ (trTm t ξ↑₁)
  | app t1 t2 => app (trTm t1 ξ) (trTm t2 ξ)
  | ttt       => ttt
  end.

Instance UniDBTm : UniDBVar Tm := {| VrT := var; TrT := @trTm |}.
Instance UnidebTmLemmas : UniDBVarLemmas Tm.
Proof. unidb_derive_instance. Qed.

Fixpoint getvar (Γ : list Ty) (i : Ix) : option Ty :=
  match Γ , i with
   | []       , _    => None
   | T  :: Γ' , O    => Some T
   | T' :: Γ' , S i' => getvar Γ' i'
  end.

Inductive Typing (Γ : list Ty) : Tm → Ty → Prop :=
  | T_Var {i τ} :
      getvar Γ i = Some τ →
      Typing Γ (var i) τ
  | T_Unit :
      Typing Γ ttt top
  | T_Abs {t σ τ} :
      Typing (σ :: Γ) t τ →
      Typing Γ (abs σ t) (arr σ τ)
  | T_App {t1 t2 σ τ} :
      Typing Γ t1 (arr σ τ) → Typing Γ t2 σ →
      Typing Γ (app t1 t2) τ.

(* Substitute 0 for s in x *)
Definition subTm {X : Type} `{Tr Tm X} (s : Tm) (x : X) : X :=
  tr Tm X (Reg Tm) x (beta₁ Tm (Reg Tm) s).

Inductive red : Tm → Tm → Prop :=
  | red_app1 {t1 t1' t2} :
      red t1 t1' → red (app t1 t2) (app t1' t2)
  | red_app2 {t1 t2 t2'} :
      red t2 t2' → red (app t1 t2) (app t1 t2')
  | red_abs  {σ t t'} :
      red t t' → red (abs σ t) (abs σ t')
  | red_beta₁ {σ s t} :
      red (app (abs σ t) s) (subTm s t).

(* Metatheory. *)

Section StrongNormalization.

  Definition Cand := Tm → Prop.
  Definition Neutral : Cand :=
    fun t => match t with
               | abs _ _ => False
               | _       => True
             end.

  Inductive SN (t : Tm) : Prop :=
    | sn_i : (∀ t', red t t' → SN t') → SN t.

  Record CR (P : Cand) :=
    { cr_sn : ∀ t, P t → SN t;
      cr_cl : ∀ t, P t → ∀ t', red t t' → P t';
      cr_nt : ∀ t, Neutral t → (∀ t', red t t' → P t') → P t
    }.
  Arguments cr_sn [_] _ [_] _.
  Arguments cr_cl [_] _ [_] _ [_] _.
  Arguments cr_nt [_] _ [_] _ _.

  Lemma sn_d {t} (sn_t: SN t) : ∀ t', red t t' → SN t'.
  Proof. destruct sn_t; auto. Qed.

  Lemma cr_SN : CR SN.
  Proof. constructor; eauto using sn_d, sn_i. Qed.

  Lemma sn_ttt : SN ttt.
  Proof. constructor; inversion 1. Qed.

  Lemma sn_inv_app {t1} t2 (sn: SN (app t1 t2)) : SN t1.
  Proof. depind sn; constructor; eauto using red. Qed.

  Lemma red_ap {t t' : Tm} (r : red t t') :
    ∀ (ξ : Reg Tm), red t[ξ] t'[ξ].
  Proof.
    induction r; cbn; intros; try constructor; auto.
    repeat change (trTm ?t ?ξ) with (t[ξ]); usimpl; constructor.
  Qed.

  Lemma sn_beta_var {t} n (sn: SN (t[beta₁ Tm (Reg Tm) (var n)])) : SN t.
  Proof. depind sn; constructor; eauto using red_ap. Qed.

  Lemma cr_var {P:Cand} (crP : CR P) : ∀ n, P (var n).
  Proof. intros; apply cr_nt; simpl; auto; inversion 1. Qed.

  Definition ARR (P R: Cand) : Cand :=
    fun (t1: Tm) => ∀ t2, P t2 → R (app t1 t2).
  Definition PI (F: Cand → Cand) : Cand :=
    fun M => ∀ P, CR P → F P M.

  Lemma cr_ARR {P R} {CR_P: CR P} {CR_R: CR R} : CR (ARR P R).
  Proof with cbn; eauto using red.
    constructor.
    - intros t ARR_t; eapply (sn_inv_app (var 0)), (cr_sn CR_R), ARR_t, cr_var...
    - intros t ARR_t t' r s P_s; eapply (cr_cl CR_R)...
    - intros t nt_t Hyp t' P_t'; apply (cr_nt CR_R)...
      generalize (cr_sn CR_P P_t').
      induction 1 as [t']; intros t'' r.
      inversion r; subst.
      + eapply Hyp...
      + eapply cr_nt... eapply H0... eapply cr_cl...
      + destruct nt_t.
  Qed.

  Lemma cr_PI {F} (cr_F: (∀ P, CR P → CR (F P))) : CR (PI F).
  Proof.
    constructor; cbn.
    - intros t PI_t; refine (cr_sn (cr_F _ cr_SN) (PI_t _ cr_SN)).
    - intros t PI_t t' r P CR_P; refine (cr_cl (cr_F _ CR_P) (PI_t _ CR_P) r).
    - intros t NT_t PI_t' P CR_P; refine (cr_nt (cr_F _ CR_P) NT_t _).
      intros; apply PI_t'; eauto using cr_SN.
  Qed.

  Lemma arr_beta_expand {P R} (crP: CR P) (crR: CR R) :
    ∀ T M, (∀ N, P N → R (M[beta₁ _ _ N])) →
      ARR P R (abs T M).
  Proof.
    intros T M H.
    assert (SN_M : SN M) by eauto using (sn_beta_var 0), (cr_sn crR), (cr_var crP).
    revert H.
    induction SN_M; intros Hyp L1 ?.
    assert (SN_L1: SN L1) by eauto using (cr_sn crP).
    induction SN_L1.
    apply (cr_nt crR); simpl; auto.
    intros ? r.
    depind r; eauto.
    * dependent destruction r; eauto.
      unfold ARR in *; eauto using (cr_cl crR), red_ap.
    * eauto using (cr_cl crP).
  Qed.

  Fixpoint Int (T: Ty) : Cand :=
    match T with
      | top       => SN
      | arr T1 T2 => ARR (Int T1) (Int T2)
    end.

  Lemma cr_Int (T: Ty) : CR (Int T).
  Proof. induction T; eauto using cr_SN, cr_ARR. Qed.

  Definition IntEnv Γ (ξ: Reg Tm) : Prop :=
    ∀ x T, getvar Γ x = Some T → Int T (lk _ _ ξ x).

  Lemma fundamental_theorem {Γ M T} (wt: Typing Γ M T) :
    ∀ ξ, IntEnv Γ ξ → Int T (M[ξ]).
  Proof.
    induction wt; intros ξ IntEnv_Γ; cbn.
    - now apply IntEnv_Γ.
    - apply sn_ttt.
    - apply arr_beta_expand; cbn; intros; eauto using cr_Int.
      repeat change (trTm ?t ?ξ) with (t[ξ]).
      change (reg_up₁ ?ξ) with (ξ↑₁).
      rewrite <- tr_comp.
      apply IHwt; simpl.
      unfold IntEnv; intros.
      destruct x; inversion H0; subst.
      + cbn; trivial.
      + rewrite lk_comp_tr.
        rewrite lk_up₁_suc.
        rewrite <- (tr_wkm₁_wk₁ (Ξ := Reg Tm)).
        usimpl.
        now apply IntEnv_Γ.
    - cbn in *; unfold ARR in *; auto.
  Qed.

  Lemma fundamental_theorem_idm {Γ M T} (wt: Typing Γ M T) : Int T M.
  Proof.
    rewrite <- (tr_idm (Ξ := Reg Tm)); apply (fundamental_theorem wt).
    unfold IntEnv; intros; apply cr_var; eauto using cr_Int.
  Qed.

  Theorem strong_normalization {Γ t T} (wt: Typing Γ t T) : SN t.
  Proof.
    eauto using (cr_sn (cr_Int T)), fundamental_theorem_idm.
  Qed.

End StrongNormalization.

(* Section WsTm. *)

(*   Inductive WsTm (γ : Dom) : Tm → Prop := *)
(*     | ws_var {i} (ws_i : γ ∋ i): ⟨ γ ⊢ var i ⟩ *)
(*     | ws_abs {σ t} (ws_t : ⟨ S γ ⊢ t ⟩): ⟨ γ ⊢ abs σ t ⟩ *)
(*     | ws_app {t1 t2} (ws_t1 : ⟨ γ ⊢ t1 ⟩) (ws_t2 : ⟨ γ ⊢ t2 ⟩): *)
(*         ⟨ γ ⊢ app t1 t2 ⟩ *)
(*     | ws_ttt : ⟨ γ ⊢ ttt ⟩ *)
(*   where "⟨ γ ⊢ t ⟩" := (WsTm γ t). *)

(*   Global Instance iWsTm : Ws Tm := WsTm. *)

(* End WsTm. *)

Section TypeSafety.

  (* Well-typed substitution for the substitution lemma of the Typing relation.
     Funny that this is not needed for strong normalization. *)
  Definition WtSub {Ξ} `{Lk Tm Ξ} (Γ Δ: list Ty) (ξ: Ξ) : Prop :=
    ∀ (i: Ix) (τ : Ty), getvar Γ i = Some τ → Typing Δ (lk Tm Ξ ξ i) τ.

  Class WtSubUp (Ξ : Type) `{Lk Tm Ξ, Up Ξ} :=
    wtsub_up₁ : ∀ {ξ : Ξ} {Γ Δ : list Ty} (wξ : WtSub Γ Δ ξ) (σ : Ty), WtSub (σ :: Γ) (σ :: Δ) (ξ↑₁).

  Lemma typing_tr {Ξ} `{Lk Tm Ξ, Up Ξ, !WtSubUp Ξ} {Γ t τ} (wt : Typing Γ t τ) :
    ∀ (ξ : Ξ) (Δ : list Ty) (wξ : WtSub Γ Δ ξ), Typing Δ (tr Tm Tm Ξ t ξ) τ.
  Proof.
    induction wt; cbn; intros.
    - auto.
    - constructor.
    - constructor.
      now apply IHwt, wtsub_up₁.
    - econstructor; auto.
  Qed.

  Lemma iWtSubUpRen {Ξ : Type} `{Lk Ix Ξ, Lk Tm Ξ, Up Ξ, !LkRen Tm Ξ, !LkUp Tm Ξ} : WtSubUp Ξ.
  Proof.
    intros ξ Γ Δ wξ σ i τ wi.
    unfold WtSub in wξ.
    destruct i; cbn in wi.
    - inversion wi; subst.
      rewrite lk_up₁_zero.
      repeat constructor.
    - rewrite lk_up₁_suc.
      rewrite (lk_ren Tm).
      constructor; cbn.
      specialize (wξ _ _ wi).
      rewrite (lk_ren Tm) in wξ.
      now inversion wξ.
  Qed.

  Lemma typing_wk₁ {Γ t τ} (wt : Typing Γ t τ) (σ : Ty) :
    Typing (σ :: Γ) (wk₁ Tm t) τ.
  Proof.
    pose proof (iWtSubUpRen (Ξ := Shift)).
    apply (typing_tr wt).
    repeat intro.
    rewrite lk_wkm.
    now repeat constructor.
  Qed.

  Instance iWtSubUp {Ξ} `{Lk Tm Ξ, Up Ξ, !LkUp Tm Ξ} : WtSubUp Ξ := {}.
  Proof.
    intros ξ Γ Δ wξ σ i τ wi.
    destruct i; cbn in wi.
    - inversion wi; subst.
      rewrite lk_up₁_zero.
      repeat constructor.
    - rewrite lk_up₁_suc.
      apply typing_wk₁.
      now apply wξ.
  Qed.

  Lemma wtsub_beta₁ {Ξ} `{Lk Tm Ξ, Beta Tm Ξ, !LkBeta Tm Ξ} :
    ∀ {Γ t σ} (wt : Typing Γ t σ),
      WtSub (σ :: Γ) Γ (beta₁ Tm Ξ t).
  Proof.
    intros ? ? ? ? i ? wi.
    destruct i; cbn in wi.
    - inversion wi; subst.

      now rewrite lk_beta₁_zero.
    - rewrite lk_beta₁_suc.
      now constructor.
  Qed.

  Fixpoint Value (t : Tm) : Prop :=
    match t with
      | ttt      => True
      | abs _ _  => True
      | _        => False
    end.

  Lemma can_form_tarr {Γ t σ τ} (v: Value t) (wt: Typing Γ t (arr σ τ)) :
    ∃ t2, t = abs σ t2.
  Proof. depind wt; try contradiction; exists t; reflexivity. Qed.

  Lemma progress (t : Tm) (τ : Ty) (wt: Typing ([]) t τ) :
    Value t ∨ ∃ t', red t t'.
  Proof with try (subst; eauto using red).
    depind wt; cbn; auto.
    - destruct IHwt1 as [v1|[t1' r1]]...
      destruct IHwt2 as [v2|[t2' r2]]...
      destruct (can_form_tarr v1 wt1)...
  Qed.

  Lemma preservation {Γ t U} (wt: Typing Γ t U) :
    ∀ {t'}, red t t' → Typing Γ t' U.
  Proof.
    induction wt; intros t' e; inversion e; subst; eauto using Typing.
    - inversion wt1; subst.
      apply (typing_tr H0).
      eapply (wtsub_beta₁ wt2).
  Qed.

End TypeSafety.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** Memoisation function for matrices: we define an identity function
   that enforces evaluation *)

Require Import List.
Require Import Arith.
Set Implicit Arguments.

Section force.
  Variable T: Type.
  Variable f: nat -> T.

  Fixpoint force_rec acc i :=
    match i with
      | O => acc
      | S i => force_rec (f i :: acc) i
      end.

  Fixpoint nth i l :=
    match l,i with
      | nil, _ => f O           	(* absurd *)
      | a::_, O => a
      |_::q, S i => nth i q
    end.
End force.

Definition print T n f := @force_rec T f nil n.

Definition id T n f :=
    let l := @print T n f in
      fun i => nth f i l.

Section correction.
  Variable T: Type.

  Lemma force_rec_rec: forall (f: nat -> T) i a, force_rec f a (S i) = f 0 :: force_rec (fun k => f (S k)) a i.
  Proof.
    induction i; intros a; simpl.
    reflexivity.
    apply IHi.
  Qed.

  Lemma nth_force_rec: forall n (f g: nat -> T) i a, i<n -> nth g i (force_rec f a n) = f i.
  Proof.
    induction n; intros f g i a H.
     inversion H.
     rewrite force_rec_rec. destruct i.
      reflexivity.
      refine (IHn _ _ _ _ _). auto with arith.
  Qed.

  Lemma nth_force_rec': forall n (f g: nat -> T) i, n<=i -> nth g i (force_rec f nil n) = g O.
  Proof.
    induction n; intros f g i H. case i; reflexivity.
     rewrite force_rec_rec. destruct i. inversion H.
     simpl. apply IHn. auto with arith.
  Qed.

  Lemma id_id: forall n (f: nat -> T) i, i<n -> id n f i = f i.
  Proof.
    intros. apply nth_force_rec. assumption.
  Qed.

  Lemma id_notid: forall n (f: nat -> T) i, n<=i -> id n f i = f O.
  Proof.
    intros. apply nth_force_rec'. assumption.
  Qed.

End correction.

Section force2.
  Variable T: Type.
  Variables n m: nat.
  Variable f: nat -> nat -> T.

  Definition id2 := id n (fun i => id m (f i)).
  Definition print2 := print n (fun i => print m (f i)).

  Lemma id2_id: forall i j, i<n -> j<m -> id2 i j = f i j.
  Proof.
    intros; unfold id2.
    rewrite id_id by assumption.
    apply id_id; assumption.
  Qed.
End force2.

(*begintests

   Let m i := mult i i - i.
   Eval compute in print 5 m.
   Time   Eval vm_compute in let _ := print 100 (id 100 m) in true.

   Let n i j := mult i (j+1).
   Eval compute in print2 3 5 n.
   Eval compute in print2 3 5 (id2 3 5 n).

endtests*)


From Hammer Require Import Hammer.

Section Ensembles.
Variable U : Type.

Definition Ensemble := U -> Prop.

Definition In (A:Ensemble) (x:U) : Prop := A x.

Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x.

Inductive Empty_set : Ensemble :=.

Inductive Full_set : Ensemble :=
Full_intro : forall x:U, In Full_set x.

Inductive Singleton (x:U) : Ensemble :=
In_singleton : In (Singleton x) x.

Inductive Union (B C:Ensemble) : Ensemble :=
| Union_introl : forall x:U, In B x -> In (Union B C) x
| Union_intror : forall x:U, In C x -> In (Union B C) x.

Definition Add (B:Ensemble) (x:U) : Ensemble := Union B (Singleton x).

Inductive Intersection (B C:Ensemble) : Ensemble :=
Intersection_intro :
forall x:U, In B x -> In C x -> In (Intersection B C) x.

Inductive Couple (x y:U) : Ensemble :=
| Couple_l : In (Couple x y) x
| Couple_r : In (Couple x y) y.

Inductive Triple (x y z:U) : Ensemble :=
| Triple_l : In (Triple x y z) x
| Triple_m : In (Triple x y z) y
| Triple_r : In (Triple x y z) z.

Definition Complement (A:Ensemble) : Ensemble := fun x:U => ~ In A x.

Definition Setminus (B C:Ensemble) : Ensemble :=
fun x:U => In B x /\ ~ In C x.

Definition Subtract (B:Ensemble) (x:U) : Ensemble := Setminus B (Singleton x).

Inductive Disjoint (B C:Ensemble) : Prop :=
Disjoint_intro : (forall x:U, ~ In (Intersection B C) x) -> Disjoint B C.

Inductive Inhabited (B:Ensemble) : Prop :=
Inhabited_intro : forall x:U, In B x -> Inhabited B.

Definition Strict_Included (B C:Ensemble) : Prop := Included B C /\ B <> C.

Definition Same_set (B C:Ensemble) : Prop := Included B C /\ Included C B.

Axiom Extensionality_Ensembles : forall A B:Ensemble, Same_set A B -> A = B.

End Ensembles.

Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets.

Hint Resolve Union_introl Union_intror Intersection_intro In_singleton
Couple_l Couple_r Triple_l Triple_m Triple_r Disjoint_intro
Extensionality_Ensembles: sets.


Require Import List.

Require Import Logic.Class.Eq.

Require Import Logic.Func.Identity.
Require Import Logic.Func.Injective.
Require Import Logic.Func.Composition.

Require Import Logic.Axiom.Extensionality.

Declare Scope Permute_scope.

(* permutes x and y                                                             *)
Definition permute (v:Type) (e:Eq v) (x y:v) (u:v) : v :=
    match eqDec u x with
    | left  _       => y        (* if u = x return y    *)
    | right _       =>
        match eqDec u y with
        | left  _   => x        (* if u = y return x    *)
        | right _   => u        (* otherwise return u   *)
        end
     end.

Arguments permute {v} {e} _ _ _.

Notation "x <:> y" := (permute y x)
    (at level 70, no associativity) : Permute_scope.

Open Scope Permute_scope.

Lemma permute_app_left : forall (v:Type) (e:Eq v) (x y:v),
  (x <:> y) x = y.
Proof.
  intros v e x y. unfold permute.
  destruct (eqDec x y) as [H1|H1].
  - assumption.
  - destruct (eqDec x x) as [H2|H2].
    + reflexivity.
    + contradiction.
Qed.

Lemma permute_app_right : forall (v:Type) (e:Eq v) (x y:v),
  (x <:> y) y = x.
Proof.
  intros v e x y. unfold permute.
  destruct (eqDec y y) as [H1|H1].
  - reflexivity.
  - destruct (eqDec y x) as [H2|H2].
    + assumption.
    + contradiction.
Qed.

Lemma permute_app_diff : forall (v:Type) (e:Eq v) (x y z:v),
  z <> x -> z <> y -> (x <:> y) z = z.
Proof.
  intros v e x y z H1 H2. unfold permute.
  destruct (eqDec z y) as [H3|H3].
  - contradiction.
  - destruct (eqDec z x) as [H4|H4].
    + contradiction.
    + reflexivity.
Qed.

Lemma permute_comp : forall (v w:Type) (e:Eq v) (e':Eq w) (x y:v) (f:v -> w),
    injective f -> f ; (y <:> x) = (f y <:> f x) ; f.
Proof.
    intros v w e e' x y f I. apply extensionality.
    intros u. unfold permute, comp.
    destruct    (eqDec u x) as [Hux|Hux],
                (eqDec u y) as [Huy|Huy]; subst.
    - destruct (eqDec (f y) (f y)) as [Fyy|Fyy]; reflexivity.
    - destruct (eqDec (f x) (f x)) as [Fxx|Fxx].
        + reflexivity.
        + destruct (eqDec (f x) (f y)) as [Fxy|Fxy].
            { rewrite Fxy. reflexivity. }
            { exfalso. apply Fxx. reflexivity. }
    - destruct (eqDec (f y) (f x)) as [Fyx|Fyx].
        + rewrite Fyx. reflexivity.
        + destruct (eqDec (f y) (f y)) as [Fyy|Fyy].
            { reflexivity. }
            { exfalso. apply Fyy. reflexivity. }
    - destruct (eqDec (f u) (f x)) as [Fux|Fux].
        + exfalso. apply Hux. apply I. assumption.
        + destruct (eqDec (f u) (f y)) as [Fuy|Fuy].
            { exfalso. apply Huy. apply I. assumption. }
            { reflexivity. }
Qed.

Lemma permute_injective : forall (v:Type) (e:Eq v) (x y:v), injective (y <:> x).
Proof.
    intros v e x y u u'. unfold permute. intros H1.
    destruct (eqDec u x) as [H2|H2].
    - destruct (eqDec u' x) as [H3|H3].
        + subst. reflexivity.
        + destruct (eqDec u' y) as [H4|H4].
            { subst. reflexivity. }
            { rewrite H1 in H4. exfalso. apply H4. reflexivity. }
    - destruct (eqDec u y) as [H3|H3].
        + subst. destruct (eqDec u' x) as [H4|H4].
            { subst. reflexivity. }
            { destruct (eqDec u' y) as [H5|H5].
                { subst. reflexivity. }
                { rewrite H1 in H4. exfalso. apply H4. reflexivity. }}
        + destruct (eqDec u' x) as [H4|H4].
            { subst. exfalso. apply H3. reflexivity. }
            { destruct (eqDec u' y) as [H5|H5].
                { subst. exfalso. apply H2. reflexivity. }
                { assumption. }}
Qed.

Lemma permute_comm : forall (v:Type) (e:Eq v) (x y:v), (y <:> x) = (x <:> y).
Proof.
    intros v e x y. apply extensionality. intros u. unfold permute.
    destruct (eqDec u x) as [H1|H1].
    - subst. destruct (eqDec x y) as [H2|H2].
        + subst. reflexivity.
        + reflexivity.
    - reflexivity.
Qed.

Lemma permute_involution : forall (v:Type) (e:Eq v) (x y:v),
    (y <:> x) ; (y <:> x) = @id v.
Proof.
    intros v e x y. apply extensionality. intros u. unfold permute, comp.
    destruct (eqDec u x) as [H1|H1].
    - subst. destruct (eqDec y x) as [H2|H2].
        + subst. reflexivity.
        + destruct (eqDec y y) as [H3|H3].
            { reflexivity. }
            { exfalso. apply H3. reflexivity. }
    - destruct (eqDec u y) as [H2|H2] eqn:E.
        + subst. destruct (eqDec x x) as [H3|H3].
            { reflexivity. }
            { exfalso. apply H3. reflexivity. }
        + destruct (eqDec u x) as [H3|H3].
            { subst. exfalso. apply H1. reflexivity. }
            { rewrite E. reflexivity. }
Qed.


Set Implicit Arguments.
Require Import Setoid.
Require Import Bool.

(* 1 a *)

Goal forall x y,
  negb (x && y) || (negb x && y) || (negb x && negb y) = (negb x || negb y).
Proof.
  intros x y.
  destruct x, y;
  simpl;
  reflexivity.

Qed.

(* 1 b *)
Goal forall(x y z : bool),
  andb (andb (negb( andb (andb (negb x) (y)) (negb z)))
  (negb(andb (andb(x) (y)) (z))) ) ( andb (andb (x) (negb y)) (negb z) ) = andb (andb (x) (negb y)) (negb z).
Proof.
  intros x  y z.
  destruct x, y, z ;
  simpl;
  reflexivity.

Qed.


Require Import Sorting.Permutation.

Notation permutes := Permutation.
Notation perm_sym := Permutation_sym.
Notation perm_app := Permutation_app.
Notation perm_app_comm := Permutation_app_comm.
Notation perm_cons_app := Permutation_cons_app.

Lemma add_Sn_m (n m : nat) : S n + m = S (n + m).
Proof. reflexivity. Defined.

Lemma add_n_Sm (n m : nat) : n + S m = S (n + m).
Proof.
  revert m. induction n; intro m; try reflexivity.
  rewrite add_Sn_m, add_Sn_m, IHn. reflexivity.
Defined.

Lemma add_n_O (n : nat) : n + O = n.
Proof.
  induction n; try reflexivity. rewrite add_Sn_m, IHn. reflexivity.
Defined.

Lemma add_comm (n m : nat) : n + m = m + n.
Proof.
  revert m. induction n; intro m.
  - rewrite add_n_O. reflexivity.
  - rewrite add_Sn_m, add_n_Sm, IHn. reflexivity.
Defined.

Lemma max_comm (n m : nat) : Nat.max n m = Nat.max m n.
Proof.
  revert m. induction n; destruct m; try reflexivity.
  simpl. f_equal. apply IHn.
Defined.


Require Import Data.Graph.Inductive.Internal.Heap.
Require Import Coq.Lists.List.
Require Import Coq.Wellfounded.Inverse_Image.
Require Import Omega.
Require Import HeapEquiv.
Require Import Helper.

Require Import Equations.Equations.
Require Import OrdTactic.

Section Heap.

Context {A B : Type} `{Hord: Base.Ord A} {Hdefault : Err.Default A} {Hdefault' : Err.Default B} `{HOrdLaws: OrdLaws A}.

(*An equivalent version that uses Equations*)

Equations toList' {a} {b} `{GHC.Base.Ord a} `{Err.Default (a * b)} (h: Heap a b) : list (a * b) by wf (size h) lt :=
toList' h => match h with
              | Heap.Empty => nil
              | h' => let 'pair x r := pair (findMin h') (deleteMin h') in cons x (toList r)
              end.

(*Better induction for heaps (from CPDT)*)

Section All.
  Variable T : Type.
  Variable P : T -> Prop.

  Fixpoint All (ls : list T) : Prop :=
    match ls with
      | nil => True
      | cons h t => P h /\ All t
    end.
End All.

Section Heap_ind'.
  Variable P : (Heap A B) -> Prop.

  Hypothesis Node_case : forall a b (ls : list (Heap A B)),
    All (Heap A B) P ls -> P (Node a b ls).

  Hypothesis Empty_case :  P Heap.Empty.

  Fixpoint Heap_ind' (tr : (Heap A B)) : P tr :=
    match tr with
      | Node a b ls => Node_case a b ls
        ((fix list_nat_tree_ind (ls : list (Heap A B)) : All (Heap A B) P ls :=
          match ls  with
            | nil => I
            | cons tr' rest => conj (Heap_ind' tr') (list_nat_tree_ind rest)
          end) ls)
      | Empty => Empty_case
    end.

End Heap_ind'.

(*Now we can work with Equations version instead, which might be easier*)
Lemma toList_equiv: forall h,
  toList h = toList' h.
Proof.
  intros. rewrite <- unfold_toList. eapply toList'_elim. intros. destruct h0. simpl.
  reflexivity. simpl. reflexivity.
Qed.

(*In the heap*)
Fixpoint In_Heap  (p : A * B) (h: Heap A B) :=
  match h with
  | Heap.Empty => False
  | Node x y l => (x,y) = p \/ List.fold_right (fun y acc => y \/ acc) False (List.map (fun y => In_Heap p y) l)
  end.

(*Specifications for different functions*)
Lemma in_heap_merge: forall p h1 h2,
  In_Heap p (merge h1 h2) <-> In_Heap p h1 \/ In_Heap p h2.
Proof.
  intros. unfold merge. generalize dependent h2.
  induction h1 using Heap_ind'.
  - intros. destruct h2. simpl. split; intros. left. assumption. destruct H1; try assumption. destruct H1.
    destruct (Base.op_zl__ a a0) eqn : ?.
    + simpl. split; intros. destruct H1. left. left. assumption. destruct H1. destruct H1.
      right. left. assumption. right. right. assumption. left. right. assumption.
      destruct H1. destruct H1. left. assumption. right. right. assumption.
      destruct H1. right. left. left. assumption. right. left. right. assumption.
    + simpl. split; intros. destruct H1. right. left. assumption. destruct H1. destruct H1.
      left. left. assumption. left. right. assumption. right. right. assumption.
      destruct H1. destruct H1. right. left. left. assumption. right. left. right. assumption.
      destruct H1. left. assumption. right. right. assumption.
  - intros. simpl. destruct h2. split; intros; simpl in *. auto. destruct H0; auto. split; intros.
    right. assumption. destruct H0. destruct H0. assumption.
Qed.

Lemma in_heap_mergeAll: forall p hs,
  In_Heap p (mergeAll hs) <-> fold_right (fun x acc => In_Heap p x \/ acc) False hs.
Proof.
  intros. induction hs using (well_founded_induction
                     (wf_inverse_image _ nat _ (@length _)
                        PeanoNat.Nat.lt_wf_0)).
  destruct hs. simpl. reflexivity. simpl. destruct hs.
  simpl. split; intros. left. assumption. destruct H1. assumption. destruct H1.
  split; intros. apply in_heap_merge in H1. destruct H1. apply in_heap_merge in H1.
  destruct H1. left. assumption. simpl. right. left. assumption.
  right. apply H0 in H1. simpl. right. apply H1. simpl. omega.
  rewrite in_heap_merge. rewrite in_heap_merge. simpl in H1. destruct H1.
  left. left. assumption. destruct H1. left. right. assumption.
  right. apply H0. simpl. omega. assumption.
Qed.

Program Instance triple : Err.Default (A * B * Heap A B).
Next Obligation.
inversion Hdefault. inversion Hdefault'. apply (default, default0, Heap.Empty).
Defined.

Lemma in_heap_splitMin: forall (p: A * B) (h h': Heap A B) k v,
  h <> Heap.Empty ->
  splitMin h = (k, v, h') ->
  In_Heap p h <-> p = (k,v) \/ In_Heap p h'.
Proof.
  intros. unfold splitMin in H1. destruct h. contradiction. inversion H1; subst.
  rewrite in_heap_mergeAll. simpl.
  assert (forall l' p,
  fold_right (fun y acc : Prop => y \/ acc) False (map (fun y : Heap A B => In_Heap p y) l') <->
  fold_right (fun (x : Heap A B) (acc : Prop) => In_Heap p x \/ acc) False l'). { intros; induction l'.
  simpl. reflexivity. simpl. split; intros. destruct H2. left. assumption. right. apply IHl'. apply H2.
  destruct H2. left. assumption. right. apply IHl'. apply H2. } rewrite H2. split; intros.
  destruct H3. left. subst. reflexivity. right. assumption. destruct H3. left. subst. reflexivity. right.
  assumption.
Qed.

(*Empty does not appear in the heap*)
Inductive nEmpty : Heap A B -> Prop  :=
  | h_unit : forall x y, nEmpty (unit x y)
  | h_merge: forall h h', nEmpty h -> nEmpty h' -> nEmpty (merge h h')
  | h_mergeAll: forall hs, (forall h, In h hs -> nEmpty h) -> nEmpty (mergeAll hs).
(*
Inductive WF_Heap : Heap A B -> Prop :=
  | h_empty : WF_Heap Heap.Empty
  | h_merge : forall h h', WF_Heap h -> WF_Heap h' -> nEmpty h -> nEmpty h' -> WF_Heap
*)

(*Total versions of the partial functions in [Heap.v]*)

Definition splitMinT (h: Heap A B) :=
match h with
| Heap.Empty => None
| Node key val hs => Some (key, val, mergeAll hs)
end.

(*Equivalence of [splitMin] and [splitMinT]*)
Lemma splitMin_equiv: forall (h : Heap A B),
  h <> Heap.Empty ->
  Some (splitMin h) = splitMinT h.
Proof.
  intros. destruct h. contradiction. simpl. reflexivity.
Qed.

Definition findMinT (h: Heap A B) :=
  match h with
  | Heap.Empty => None
  | Node key val _ => Some (key, val)
  end.

(*Equivalence of [findMin] and [findMinT]*)
Lemma findMin_equiv: forall (h: Heap A B),
  h <> Heap.Empty ->
  Some (findMin h) = findMinT h.
Proof.
  intros. destruct h; [contradiction | reflexivity].
Qed.

(*Two equivalent functions used in In_Heap*)
Lemma in_heap_equiv: forall l k v,
fold_right (fun (x : Heap A B) (acc : Prop) => In_Heap (k, v) x \/ acc) False l <->
fold_right (fun y acc : Prop => y \/ acc) False (map (fun y : Heap A B => In_Heap (k, v) y) l).
Proof.
  intros. induction l; simpl. reflexivity. rewrite IHl. reflexivity.
Qed.

(*Another property used for In_Heap*)
Lemma in_heap_exists: forall l k v,
  fold_right (fun (x : Heap A B) (acc : Prop) => In_Heap (k, v) x \/ acc) False l <->
  exists h, In h l /\ In_Heap (k, v) h.
Proof.
  intros. induction l; intros; simpl.
  - split; intros. destruct H0. destruct_all. destruct H0.
  - rewrite IHl. split; intros.
    + destruct H0. exists a. simplify'. destruct_all. exists x. split. right. all: assumption.
    + destruct_all. destruct H0. subst. left. assumption. right. exists x. simplify'.
Qed.

(*A rewrite rule to avoid using [simpl] and unfolding lots of things*)
Lemma in_heap_unfold: forall h t k v,
  fold_right (fun (x : Heap A B) (acc : Prop) => In_Heap (k, v) x \/ acc) False (h :: t) <->
  In_Heap (k, v) h \/ fold_right (fun (x : Heap A B) (acc : Prop) => In_Heap (k, v) x \/ acc) False t.
Proof.
  intros. simpl. reflexivity.
Qed.

(*Proving that findMin actually works: we need a well-founded heap, ie, a heap that can actually be
  created by the exported functions*)

Inductive WF : Heap A B -> Prop :=
  | WF_empty: WF (Heap.Empty)
  | WF_unit: forall x y, WF (unit x y)
  | WF_merge: forall h1 h2, WF h1 -> WF h2 -> WF (merge h1 h2)
  | WF_mergeAll: forall l, (forall h, In h l -> WF h) -> WF (mergeAll l).

Require Import GHC.Base.

(*The [mergeAll] case needs additional results, since the IH is not strong enough on its own to prove
  the claim. We need to know that for any heap in the list that is merged, the root is larger than
  the minimum of the merged heap. To do this, we need a few helper lemmas *)

Lemma merge_min': forall h1 h2 x y h',
  splitMinT (merge h1 h2) = Some (x,y,h') ->
  (exists h'', h1 = Node x y h'' /\ (forall x' y' z', h2 = Node x' y' z' -> x <= x' = true))
 \/ (exists h'', h2 = Node x y h'' /\ (forall x' y' z', h1 = Node x' y' z' -> x <= x' = true )).
Proof.
  intros. destruct h1; destruct h2. inversion H0. simpl in H0. inversion H0; subst. right.
  exists l. split. reflexivity. intros. inversion H1. inversion H0; subst. left. exists l. split. reflexivity.
  intros. inversion H1.
  simpl in H0. destruct (a < a0) eqn : L. remember (Node a0 b0 l0 :: l) as h. inversion H0; subst.
  left. exists l. split. reflexivity. intros. inversion H1; subst. order A.
  remember ((Node a b l :: l0)) as h. inversion H0; subst.
  right. exists l0. split. reflexivity. intros. inversion H1; subst. order A.
Qed.

Lemma merge_empty: forall (h1 h2 : Heap A B),
  merge h1 h2 = Heap.Empty <-> h1 = Heap.Empty /\ h2 = Heap.Empty.
Proof.
  intros. split; intros. destruct h1; destruct h2; simpl in H0; try(split; reflexivity); try(inversion H0).
  destruct (a < a0); inversion H0. destruct_all; subst. simpl. reflexivity.
Qed.

Lemma mergeAll_empty: forall (l: list (Heap A B)),
  mergeAll l = Heap.Empty <-> l = nil \/ (forall h, In h l -> h = Heap.Empty).
Proof.
  intros. induction l using (well_founded_induction
                     (wf_inverse_image _ nat _ (@length _)
                        PeanoNat.Nat.lt_wf_0)). split; intros.
  - destruct l. left. reflexivity. destruct l. simpl in H1.
    subst. right. intros. simpl in H1. destruct H1. subst. reflexivity. destruct H1.
    simpl in H1. rewrite merge_empty in H1. destruct H1. rewrite merge_empty in H1.
    destruct_all. subst. right. intros. simpl in H1. destruct H1. subst. reflexivity.
    destruct H1. subst. reflexivity. apply H0 in H2. destruct H2. subst. inversion H1.
    apply H2. assumption. simpl. omega.
  - destruct l. reflexivity. destruct l. simpl. destruct H1. inversion H1.
    apply H1. left. reflexivity. simpl. destruct H1. inversion H1.
    rewrite merge_empty. split. rewrite merge_empty. split; apply H1; try(solve_in).
    right. left. reflexivity. apply H0. simpl. omega. right. intros. apply H1. right. right. assumption.
Qed.

(*The key lemma for proving mergeAll finds the minimum. The proof boils down to checking a lot of cases
  and using [merge_min']*)
Lemma mergeAll_min'': forall l x y h',
  splitMinT (mergeAll l) = Some (x,y,h') ->
  forall x' y' z', In (Node x' y' z') l -> x <= x' = true.
Proof.
  intros. generalize dependent h'. revert x y. induction l using (well_founded_induction
                     (wf_inverse_image _ nat _ (@length _)
                        PeanoNat.Nat.lt_wf_0)); intros.
  destruct l. simpl in H1. inversion H1. destruct l. simpl in H2. simpl in H1. destruct H1. subst.
  inversion H2; subst. order A. destruct H1. simpl in H2.
  apply merge_min' in H2.
 destruct H2; simpl in H1; destruct_all.
  assert (splitMinT (merge h h0) = Some(x,y,(mergeAll x0))) by (rewrite H2; reflexivity).
  apply merge_min' in H4. destruct H4; destruct_all. destruct H1.
  subst. inversion H4; subst. order A. destruct H1. subst. eapply H5. reflexivity.
  destruct (mergeAll l) eqn : M.
  - rewrite mergeAll_empty in M. destruct M. subst. inversion H1. apply H6 in H1. inversion H1.
  - assert (x <= a = true). eapply H3. reflexivity.
    assert (a <= x' = true). eapply H0. 2 : { apply H1. } simpl. omega. rewrite M. simpl. reflexivity.
    order A.
  - subst. destruct H1; subst. eapply H5. reflexivity. destruct H1. inversion H1; subst. order A.
    destruct (mergeAll l) eqn : M.
    + rewrite mergeAll_empty in M. destruct M; subst. inversion H1. apply H4 in H1. inversion H1.
    + assert (x <= a = true). eapply H3. reflexivity. assert (a <= x' = true). eapply H0.
      2 : { apply H1. } simpl. omega. rewrite M. reflexivity. order A.
  - destruct (merge h h0) eqn : M.
    + rewrite merge_empty in M. destruct_all. subst. destruct H1. inversion H1. destruct H1. inversion H1.
      eapply H0. 2 : { apply H1. } simpl. omega. rewrite H2. simpl. reflexivity.
    + assert (splitMinT (merge h h0) = Some (a, b, mergeAll l0)) by (rewrite M; reflexivity).
      apply merge_min' in H4. destruct H4; destruct_all; subst.
      * destruct H1; subst. inversion H1; subst. eapply H3. reflexivity.
        destruct H1; subst. simpl in M. destruct (a < x') eqn : L.
        assert (x <= a = true). eapply H3. reflexivity. order A. inversion M; subst.
        eapply H3. reflexivity. eapply H0. 2 : { apply H1. } simpl. omega. rewrite H2. reflexivity.
      * destruct H1; subst. simpl in M. destruct (x' < a) eqn : L.
        inversion M; subst. order A. assert (x <= a = true). eapply H3. reflexivity. order A.
        destruct H1. inversion H1; subst. eapply H3. reflexivity.
        eapply H0. 2 : { apply H1. } simpl. omega. rewrite H2. reflexivity.
Qed.

(*If the heap is well_formed, then findMin actually finds the min.*)
Lemma WF_min: forall h x y h',
  WF h ->
  splitMinT h = Some (x,y, h') ->
  forall a b, In_Heap (a,b) h -> x <= a = true.
Proof.
  intros. generalize dependent x. revert y. generalize dependent a. revert h'. revert b. induction H0; intros.
  - simpl in H1. inversion H1; subst.
  - simpl in H1. inversion H1; subst. simpl in H2. destruct H2. inversion H0; subst. order A. destruct H0.
  - destruct h1; simpl in H1.
    + destruct h2; inversion H1. subst. unfold merge in H2. eapply IHWF2. apply H2. reflexivity.
    + destruct h2.
      * simpl in H1. unfold merge in H2. inversion H1; subst. eapply IHWF1. apply H2. reflexivity.
      * destruct (a0 < a1) eqn : L.
        -- rewrite in_heap_merge in H2. remember (Node a1 b1 l0 :: l) as h. simpl in H1. inversion H1.
           subst. destruct H2.
           ++ eapply IHWF1. apply H0. reflexivity.
           ++ assert (a1 <= a = true). eapply IHWF2. apply H0. reflexivity.
              order A.
       -- assert (a1 <= a0 = true) by (order A). clear L. rewrite in_heap_merge in H2.
          remember (Node a0 b0 l :: l0) as h. simpl in H1. inversion H1. subst. destruct H2.
          ++ assert (a0 <= a = true). eapply IHWF1. apply H2. reflexivity. order A.
          ++ eapply IHWF2. apply H2. reflexivity.
  - rewrite in_heap_mergeAll in H2. rewrite in_heap_exists in H2. destruct H2 as [h'']. destruct_all.
    destruct h''. simpl in H4. destruct H4.
    assert (splitMinT  (Node a0 b0 l0) = Some (a0, b0, mergeAll l0)). reflexivity.
    assert (a0 <= a = true). eapply H1. apply H2. apply H4. apply H5.
    assert (x <= a0 = true).
    eapply mergeAll_min'' in H3. apply H3. apply H2. order A.
Qed.

(*Now we need to show that subheaps of well formed heaps are well formed (to show that the heap
  at each iteration is still well formed). This requires a few helper lemmas*)

Definition subheap (h1 h2 : Heap A B) : Prop :=
  match h2 with
  | Heap.Empty => False
  | Heap.Node x y l => In h1 l
  end.

Lemma subheap_merge: forall h1 h2 h3,
  subheap h1 (merge h2 h3) ->
  h1 = h2 \/ h1 = h3 \/ subheap h1 h2 \/ subheap h1 h3.
Proof.
  intros. destruct h2. destruct h3. inversion H0.
  simpl in H0. simpl. right. right. right. assumption.
  destruct h3. simpl in *. right. right. left. assumption.
  simpl in H0. destruct (a < a0). simpl in H0.
  destruct H0. subst. right. left. reflexivity. simpl. right. right. left. assumption.
  simpl in H0. destruct H0; subst; simpl in *. left. reflexivity.
  right. right. right. assumption.
Qed.

(*We characterize all the possibilities for a subheap of mergeAll l*)
Lemma subheap_mergeAll: forall h l,
  subheap h (mergeAll l) ->
  (exists h' h'', In h' l /\ In h'' l /\ h = merge h' h'') \/ (exists h', In h' l /\ subheap h h') \/
  (exists h', In h' l /\ h = h') \/ (exists y, (forall x, In x y -> In x l) /\ h = mergeAll y) \/
  (exists h' h'', In h' l /\ In h'' l /\ subheap h (merge h' h'')).
Proof.
  intros. induction l using (well_founded_induction
                     (wf_inverse_image _ nat _ (@length _)
                        PeanoNat.Nat.lt_wf_0)); intros.
  destruct l. simpl in H0. destruct H0.
  destruct l. simpl in H0. right. left. exists h0. split. left. reflexivity. assumption.
  simpl in H0. apply subheap_merge in H0. destruct H0.
  subst. left.  exists h0. exists h1. split. solve_in. split. right. left. reflexivity. reflexivity.
  destruct H0. right. right. right. left. exists l. split. intros. right. right. assumption. assumption.
  destruct H0. right. right. right. right. exists h0. exists h1. split. solve_in. split. right. left.
  reflexivity. assumption.
  apply H1 in H0. destruct H0.
  - destruct_all. left. exists x. exists x0. split. right. right. assumption. split.
    right. right. assumption. assumption.
  - destruct H0; destruct_all.
    + right. left. exists x. split. right. right. assumption. assumption.
    + destruct H0; destruct_all.
      * subst. right. right. left. exists x. split. right. right. assumption. reflexivity.
      * destruct H0; destruct_all.
        -- right. right. right. left. exists x. split. intros. right. right. apply H0. assumption.
            assumption.
        -- right. right. right. right. exists x. exists x0. split. right. right. assumption.
           split. right. right. assumption. assumption.
  - simpl. omega.
Qed.

(*The result we want*)
Lemma subheap_wf: forall h1 h2,
  WF h2 ->
  subheap h1 h2 ->
  WF h1.
Proof.
intros; induction H0.
  - simpl in H1. destruct H1.
  - simpl in H1. destruct H1.
  - apply subheap_merge in H1. destruct H1. subst. assumption.
    destruct H0. subst. assumption. destruct H0. apply IHWF1. assumption.
    apply IHWF2. assumption.
  - apply subheap_mergeAll in H1. destruct H1. destruct_all.
    subst. constructor. apply H0. assumption. apply H0. assumption.
    destruct H1. destruct_all. eapply H2. apply H1. assumption. destruct H1.
    destruct_all. subst. apply H0. assumption. destruct H1.
    destruct_all. subst. constructor. intros. apply H0. apply H1. assumption.
    destruct_all. apply subheap_merge in H4. destruct H4; subst.
    apply H0. assumption. destruct H4; subst. apply H0. assumption.
    destruct H4. eapply H2. apply H1. assumption. eapply H2. apply H3. assumption.
Qed.

(*Now, the result we need to disjkstra's*)
Lemma node_WF: forall x y l,
  WF (Node x y l) ->
  (forall h, In h l -> WF h).
Proof.
  intros. eapply subheap_wf. apply H0. simpl.  assumption.
Qed.

Lemma splitMInT_WF: forall h x y h',
  WF h ->
  splitMinT h = Some(x,y,h') ->
  WF h'.
Proof.
  intros. destruct h. inversion H1; subst. simpl in H1. inversion H1; subst.
  constructor. intros. eapply node_WF. apply H0. assumption.
Qed.

End Heap.
(*TODO: Move to helper*)
Lemma all_in: forall {A : Type} (P : A -> Prop) l,
  All A P l <-> (forall x, In x l -> P x).
Proof.
  intros. induction l; simpl; split; intros.
  - destruct H0.
  - apply I.
  - destruct_all. destruct H0. subst. assumption. apply IHl. assumption. assumption.
  - split. apply H. left. reflexivity. apply IHl. intros. apply H. right. assumption.
Qed.

(*New section because map deals with different types of heaps*)
Section Map.
Context {A B C : Type} `{Hord: Base.Ord A}  `{HOrdLaws: OrdLaws A}.

(*HMap function with key*)
Fixpoint map_heap {C} (f: A -> B -> C) (h: Heap A B) : Heap A C :=
  match h with
  | Heap.Empty => Heap.Empty
  | Node x y l => Node x (f x y) (map (map_heap f) l)
  end.

Lemma map_merge: forall {C} (f: A -> B -> C) (h1 h2: Heap A B),
  map_heap f (merge h1 h2) = merge (map_heap f h1) (map_heap f h2).
Proof.
  intros. destruct h1; destruct h2; try(reflexivity).
  simpl. destruct (Base.op_zl__ a a0); reflexivity.
Qed.

Lemma map_mergeAll: forall {C} (f : A -> B -> C) (l: list (Heap A B)),
  map_heap f (mergeAll l) = mergeAll (map (map_heap f) l).
Proof.
  intros. induction l using (well_founded_induction
                     (wf_inverse_image _ nat _ (@length _)
                        PeanoNat.Nat.lt_wf_0)).
  - destruct l. simpl. reflexivity. simpl. destruct l. simpl. reflexivity.
    rewrite map_merge. rewrite H0. simpl. rewrite map_merge. reflexivity. simpl. omega.
Qed.

Lemma map_splitMinT: forall (f: A -> B -> C) x y (h h' : Heap A B),
  h <> Heap.Empty ->
  splitMinT h = Some ((x,y), h') ->
  splitMinT (map_heap f h) = Some ((x, f x y), (map_heap f h')).
Proof.
  intros. destruct h. contradiction.
  simpl. simpl in H1. inversion H1; subst. rewrite map_mergeAll. reflexivity.
Qed.

End Map.

Lemma map_in_heap: forall {A B C} (f: A -> B -> C) (h: Heap A B) x y,
  In_Heap (x,y) (map_heap f h) <-> exists z, f x z = y /\ In_Heap (x,z) h.
Proof.
  intros. induction h using Heap_ind'.
  - simpl. split; intros.
    + destruct H0.
      * inversion H0; subst. exists b. split. reflexivity. left. reflexivity.
      * rewrite <- in_heap_equiv in H0. rewrite all_in in H.
        rewrite in_heap_exists in H0.
        destruct H0 as [h]. assert (D:= H0). destruct H0. rewrite in_map_iff in H0. destruct H0.
        assert (E:= H0). destruct_all.
        subst. apply H in H3. apply H3 in H1. destruct_all. exists x1. split. assumption.
        right.  rewrite <- in_heap_equiv. rewrite in_heap_exists. exists x0. split; assumption.
    + destruct H0 as [z]. destruct_all. subst. destruct H1. inversion H0; subst. left. reflexivity.
      right. rewrite <- in_heap_equiv in H0. rewrite <- in_heap_equiv. rewrite in_heap_exists in H0.
      rewrite in_heap_exists. rewrite all_in in H.
       destruct_all. assert (D := H0). apply H in H0.
      destruct H0. assert ( In_Heap (x, f x z) (map_heap f x0)). apply H2.
      exists z. split. reflexivity. assumption. exists (map_heap f x0). rewrite in_map_iff.
      split. exists x0. split. reflexivity. assumption. assumption.
  - simpl. split; intros. destruct H. destruct_all. destruct H0.
Qed.


Require Import FOL.
Require Import Deduction.
Require Import Tarski.
Require Import ProofMode.
Require Import Theories.
Require Import PA.
Require Import Equations.Equations Equations.Prop.DepElim.
Require Import String.
Require Import List.
Import ListNotations.

Open Scope string_scope.

Section FullLogic.
Variable p : peirce.

(** Setup *)

Instance eqdec_funcs : EqDec PA_funcs_signature.
Proof. intros x y; decide equality. Qed.

Instance eqdec_preds : EqDec PA_preds_signature.
Proof. intros x y. destruct x, y. now left. Qed.

Ltac custom_fold ::= fold zero in *.
Ltac custom_unfold ::= unfold zero in *.
Ltac custom_simpl ::= try rewrite !numeral_subst_invariance.

(** Proof mode and tactics demo *)

Goal forall a b c, nil ⊢ (a --> (a --> b) --> (b --> c) --> c).
Proof.
  intros. fstart. fintros. fapply "H1". fapply "H0". fapply "H".
Qed.

Lemma num_add_homomorphism x y :
  FA ⊢ (num x ⊕ num y == num (x + y)).
Proof.
  induction x; cbn.
  - fapply ax_add_zero. (* Arguments are infered! *)
  - feapply ax_trans.
    + fapply ax_add_rec.
    + feapply ax_eq_succ. exact IHx.
Qed.

Lemma num_mult_homomorphism x y : FA ⊢ ( num x ⊗ num y == num (x * y) ).
Proof.
  induction x; cbn.
  - fapply ax_mult_zero.
  - feapply ax_trans.
    + feapply ax_trans.
      * fapply ax_mult_rec.
      * feapply ax_eq_add. fapply ax_refl. exact IHx.
    + apply num_add_homomorphism.
Qed.

(** Setup rewriting *)

Program Instance PA_Leibniz : Leibniz PA_funcs_signature PA_preds_signature.
Next Obligation. exact Eq. Defined.
Next Obligation. exact FA. Defined.
Next Obligation. exact (fun phi => phi el FA). Defined.
Next Obligation. apply Ctx. firstorder. Admitted.
Next Obligation. Admitted.
Next Obligation. Admitted.

(* Rewriting allows for more elegant proofs *)

Lemma num_add_homomorphism' x y :
  FA ⊢ (num x ⊕ num y == num (x + y)).
Proof.
  induction x; cbn.
  - fapply ax_add_zero.
  - frewrite <- IHx. fapply ax_add_rec.
Qed.

Lemma num_mult_homomorphism' x y : FA ⊢ ( num x ⊗ num y == num (x * y) ).
Proof.
  induction x; cbn.
  - fapply ax_mult_zero.
  - frewrite (ax_mult_rec (num x) (num y)). (* We need to give the instantiations for rewrite *)
    frewrite IHx. apply num_add_homomorphism'.
Qed.

(* Rewrite under quantifiers: *)

Goal forall t t', FA ⊢ (t == t') -> FA ⊢ ∀ $0 ⊕ σ t`[↑] == t' ⊕ σ $0.
Proof.
  intros. frewrite H.
Abort.

Goal forall t t', FA ⊢ (t == t') -> FA ⊢ ∀∃ $0 ⊕ σ t == t'`[↑]`[↑] ⊕ σ $0.
Proof.
  intros. frewrite <- H.
Abort.

(** Classical logic *)

Goal forall phi, [] ⊢C (phi ∨ (phi --> ⊥)).
Proof.
  intro. fstart. fclassical phi.
  - fleft. fapply "H".
  - fright. fapply "H".
Qed.

Goal forall phi, [] ⊢C (((phi --> ⊥) --> ⊥) --> phi).
Proof.
  intro. fstart. fintros. fcontradict as "X". fapply "H". fapply "X".
Qed.

(** Theories *)

Definition TFA phi := phi el FA.

Lemma num_add_homomorphism_T x y :
  TFA ⊩ (num x ⊕ num y == num (x + y)).
Proof.
  induction x; cbn.
  - fapply ax_add_zero.
  - fstart. frewrite <- IHx. fapply ax_add_rec.
Qed.

Definition TFA_ind : theory := fun phi => phi el FA \/ exists psi, phi = PA_induction psi.

(* Context management for theories is still work in progress.
 * Lemmas that are used need to be assert before the first fintro
 * is done. *)
Lemma add_zero_right :
  TFA_ind ⊩ ∀ $0 ⊕ zero == $0.
Proof.
  fstart. assert (TFA_ind ⊩ PA_induction ($0 ⊕ zero == $0)) as H.
  { apply Ctx. right. now eexists. }
  unfold PA_induction in H. fapply H; clear H.
  - fapply ax_add_zero.
  - fassert ax_trans as "trans". ctx.
    fassert ax_add_rec as "add_rec". ctx.
    fassert ax_eq_succ as "eq_succ". ctx.
    fintros "x" "IH". feapply "trans".
    + fapply "add_rec".
    + fapply "eq_succ". fapply "IH".
Qed.

(** XM for closed, quantor free formulas: *)

(* This lemma doesn't really use the proof mode but is required below. *)
Lemma eq_num t :
  bound_term 0 t = true -> exists n, FA ⊢ (t == num n).
Proof.
  intros H0. induction t.
  - now exfalso.
  - destruct F; repeat depelim v; cbn in H0.
    + exists 0. fapply ax_refl.
    + destruct (IH h) as [n H]. left. now destruct (bound_term 0 h).
      exists (S n). cbn. now fapply ax_eq_succ.
    + destruct (IH h) as [n1 H1]. left. now destruct (bound_term 0 h).
      destruct (IH h0) as [n2 H2]. right. left. now do 2 destruct bound_term.
      exists (n1 + n2). assert (H := num_add_homomorphism n1 n2). frewrite <- H.
      now fapply ax_eq_add.
    + destruct (IH h) as [n1 H1]. left. now destruct (bound_term 0 h).
      destruct (IH h0) as [n2 H2]. right. left. now do 2 destruct bound_term.
      exists (n1 * n2). assert (H := num_mult_homomorphism n1 n2). frewrite <- H.
      now fapply ax_eq_mult.
Qed.

Fixpoint quantor_free (phi : form) := match phi with
| fal => True
| atom _ _ => True
| bin _ phi1 phi2 => quantor_free phi1 /\ quantor_free phi2
| quant _ _ => False
end.

Lemma xm_quantor_free phi :
  closed phi = true -> quantor_free phi -> (ax_zero_succ::ax_succ_inj::FA) ⊢ (phi ∨ (phi --> ⊥)).
Proof.
  intros H0 H1. induction phi; fstart.
  - fright. fintros "F". fapply "F".
  - destruct P. repeat depelim v. cbn in H0, H1. clear H1.
    destruct (eq_num h) as [n1 H1]. now destruct bound_term.
    destruct (eq_num h0) as [n2 H2]. now do 2 destruct bound_term.
    frewrite H1. frewrite H2. clear H1 H2.
    fstop; revert n2; induction n1 as [|n1 IH]; intros; fstart; cbn.
    + destruct n2; cbn.
      * fleft. fapply ax_refl.
      * fright. fapply ax_zero_succ.
    + destruct n2; cbn.
      * fright. fintros. feapply ax_zero_succ. feapply ax_sym. ctx.
      * specialize (IH n2). fdestruct IH as "[IH|IH]".
        -- fleft. frewrite "IH". fapply ax_refl.
        -- fright. fintro. fapply "IH". fapply ax_succ_inj. ctx.
  - cbn in H0, H1. destruct (bound 0 phi1) eqn:H2. 2: now exfalso.
    fassert (phi1 ∨ (phi1 --> ⊥)) as "IH1" by now fapply IHphi1.
    fassert (phi2 ∨ (phi2 --> ⊥)) as "IH2" by now fapply IHphi2.
    destruct b.
    + fdestruct "IH1" as "[IH1|IH1]". fdestruct "IH2" as "[IH2|IH2]".
      * fleft. fsplit; ctx.
      * fright. fintros "[ ]". fapply "IH2". ctx.
      * fright. fintros "[ ]". fapply "IH1". ctx.
    + fdestruct "IH1" as "[IH1|IH1]". 2: fdestruct "IH2" as "[IH2|IH2]".
      * fleft. fleft. ctx.
      * fleft. fright. ctx.
      * fright. fintros "[|]". fapply "IH1"; ctx. fapply "IH2"; ctx.
    + fdestruct "IH1" as "[IH1|IH1]". fdestruct "IH2" as "[IH2|IH2]".
      * fleft. fintro. ctx.
      * fright. fintro "H1". fapply "IH2". fapply "H1". ctx.
      * fleft. fintro. fexfalso. fapply "IH1". ctx.
  - now exfalso.
Qed.

(** Division Theorem with Hoas *)

Ltac custom_fold ::= fold zero in *; fold PA_induction in *.
Ltac custom_unfold ::= unfold zero in *; unfold PA_induction in *.

Require Import Hoas.

Notation "'σ' x" := (bFunc Succ (Vector.cons bterm x 0 (Vector.nil bterm))) (at level 37) : hoas_scope.
Notation "x '⊕' y" := (bFunc Plus (Vector.cons bterm x 1 (Vector.cons bterm y 0 (Vector.nil bterm))) ) (at level 39) : hoas_scope.
Notation "x '⊗' y" := (bFunc Mult (Vector.cons x (Vector.cons y (Vector.nil bterm))) ) (at level 38) : hoas_scope.
Notation "x '==' y" := (bAtom Eq (Vector.cons bterm x 1 (Vector.cons bterm y 0 (Vector.nil bterm))) ) (at level 40) : hoas_scope.

(* FA enriched with the neccessary induction rules to prove the division theorem *)
Definition FAI :=
  PA_induction (∀ (∃ (∃ $3 == $0 ⊕ $1 ⊗ σ $2 ∧ (∃ $1 ⊕ $0 == $3)))) ::
  PA_induction (∀ $1 == $0 ∨ ($1 == $0 --> ⊥)) ::
  PA_induction (zero == $0 ∨ (zero == $0 --> ⊥)) ::
  ∀ PA_induction (σ $1 == $0 ∨ (σ $1 == $0 --> ⊥)) ::
  PA_induction (∀ (∃ (∃ $3 == $0 ⊕ $1 ⊗ σ $2 ∧ (∃ $1 ⊕ $0 == $3)))) ::
  PA_induction (∀ (∀ ($1 == $0 --> ⊥) --> $1 ⊕ $2 == $0 --> (∃ σ $2 ⊕ $0 == $1))) ::
  PA_induction (∀ $1 ⊕ σ $0 == σ ($1 ⊕ $0)) ::
  PA_induction (∀ $1 ⊕ $0 == $0 ⊕ $1) ::
  PA_induction ($0 ⊕ zero == $0) ::
  ax_zero_succ ::
  ax_succ_inj ::
  FA.

Definition leq a b := (∃' k, a ⊕ k == b)%hoas.
Infix "≤" := leq (at level 45).

(* Rewriting in the proofs below is very slow. The reason is
 * that [firstorder] is used to show `PAI <<= PA` for the Leibniz
 * rule. This can be improved by writing better automation tactics
 * (or hint databases) for list inclusion in the future. *)
Lemma add_zero_r :
  FAI ⊢ <<(∀' x, x ⊕ zero == x)%hoas.
Proof.
  fstart. fapply ((PA_induction ($0 ⊕ zero == $0))).
  - frewrite (ax_add_zero zero). fapply ax_refl.
  - fintros "x" "IH". frewrite (ax_add_rec zero x). frewrite "IH". fapply ax_refl.
Qed.

Lemma add_succ_r :
  FAI ⊢ <<(∀' x y, x ⊕ σ y == σ (x ⊕ y))%hoas.
Proof.
  fstart. fapply ((PA_induction (∀ $1 ⊕ σ $0 == σ ($1 ⊕ $0)))).
  - fintros "y". frewrite (ax_add_zero (σ y)). frewrite (ax_add_zero y). fapply ax_refl.
  - fintros "x" "IH" "y". frewrite (ax_add_rec (σ y) x). frewrite ("IH" y).
    frewrite (ax_add_rec y x). fapply ax_refl.
Qed.

Lemma add_comm :
  FAI ⊢ <<(∀' x y, x ⊕ y == y ⊕ x)%hoas.
Proof.
  fstart. fapply ((PA_induction (∀ $1 ⊕ $0 == $0 ⊕ $1))).
  - fintros. frewrite (ax_add_zero x). frewrite (add_zero_r x). fapply ax_refl.
  - fintros "x" "IH" "y". frewrite (add_succ_r y x). frewrite <- ("IH" y).
    frewrite (ax_add_rec y x). fapply ax_refl.
Qed.

Lemma term_eq_dec :
  FAI ⊢ <<(∀' x y, (x == y) ∨ (x == y --> ⊥))%hoas.
Proof.
  fstart. fapply ((PA_induction (∀ $1 == $0 ∨ ($1 == $0 --> ⊥)))).
  - fapply ((PA_induction (zero == $0 ∨ (zero == $0 --> ⊥)))).
    + fleft. fapply ax_refl.
    + fintros "x" "IH". fright. fapply ax_zero_succ.
  - fintros "x" "IH". fapply ((∀ PA_induction (σ $1 == $0 ∨ (σ $1 == $0 --> ⊥)))).
    + fright. fintros "H". feapply ax_zero_succ. feapply ax_sym. fapply "H".
    + fintros "y" "IHy". fspecialize ("IH" y). fdestruct "IH" as "[IH|IH]".
      * fleft. frewrite "IH". fapply ax_refl.
      * fright. fintros "H". fapply "IH". fapply ax_succ_inj. fapply "H".
Qed.

Lemma neq_le :
  FAI ⊢ <<(∀' k r y, (r == y --> ⊥) --> (r ⊕ k == y) --> ∃' k', σ r ⊕ k' == y)%hoas.
Proof.
  fstart. fapply ((PA_induction (∀ (∀ ($1 == $0 --> ⊥) --> $1 ⊕ $2 == $0 --> (∃ σ $2 ⊕ $0 == $1))))).
  - fintros "r" "y" "H1" "H2". fexfalso. fapply "H1". frewrite <- (ax_add_zero r).
    frewrite (add_comm zero r). ctx.
  - fintros "k" "IH" "r" "y". fintros "H1" "H2". fexists k.
    frewrite <- "H2". frewrite (ax_add_rec k r). frewrite (add_comm r (σ k)).
    frewrite (ax_add_rec r k). frewrite (add_comm k r). fapply ax_refl.
Qed.

Lemma division_theorem :
  FAI ⊢ <<(∀' x y, ∃' q r, (x == r ⊕ q ⊗ σ y) ∧ (r ≤ y))%hoas.
Proof.
  fstart. fapply ((PA_induction (∀ (∃ (∃ $3 == $0 ⊕ $1 ⊗ σ $2 ∧ (∃ $1 ⊕ $0 == $3)))))).
  - fintros "y". fexists zero. fexists zero. fsplit.
    + frewrite (ax_mult_zero (σ y)). frewrite (ax_add_zero zero). fapply ax_refl.
    + fexists y. fapply ax_add_zero.
  - fintros "x" "IH" "y". fspecialize ("IH" y). fdestruct "IH" as "[q [r [IH1 [k IH2]]]]".
    fassert (r == y ∨ (r == y --> ⊥)) as "[H|H]" by fapply term_eq_dec.
    + fexists (σ q). fexists zero. fsplit.
      * frewrite (ax_add_zero (σ q ⊗ σ y)). frewrite (ax_mult_rec q (σ y)).
        frewrite (ax_add_rec (q ⊗ σ y) y). fapply ax_eq_succ.
        frewrite "IH1". frewrite "H". fapply ax_refl.
      * fexists y. fapply ax_add_zero.
    + fexists q. fexists (σ r). fsplit.
      * frewrite (ax_add_rec (q ⊗ σ y) r). fapply ax_eq_succ. ctx.
      * fapply (neq_le k r y). ctx. ctx.
Qed.


(** * Various utilities for benchmarking *)
Require Import Coq.NArith.NArith. (* for Pos.iter_op and Z.of_nat *)
Require Import Reify.Common.
Require Reify.PHOAS.
Require Import Reify.PHOASUtil.

(** ** Definition of the terms with which we build our benchmarking suite *)
Inductive count := none | one_more (how_many : count).
Fixpoint count_of_nat (v : nat) : count
  := match v with
     | O => none
     | S x => one_more (count_of_nat x)
     end.
Fixpoint nat_of_count (v : count) : nat
  := match v with
     | none => O
     | one_more x => S (nat_of_count x)
     end.

Fixpoint pos_of_succ_count (v : count) : positive
  := match v with
     | none => 1%positive
     | one_more x => Pos.succ (pos_of_succ_count x)
     end.
Definition N_of_count (v : count) : N
  := match v with
     | none => 0%N
     | one_more x => N.pos (pos_of_succ_count x)
     end.
Definition count_of_N (v : N) : count
  := count_of_nat (N.to_nat v).

Fixpoint big (x:nat) (n:count)
  : nat
  := match n with
     | none => x
     | one_more n'
       => dlet x' := x * x in
          big x' n'
     end.

Definition big_flat_op {T} (op : T -> T -> T) (a : T) (sz : count) : T
  := Eval cbv [N_of_count pos_of_succ_count Pos.iter_op Pos.succ] in
      match N_of_count sz with
      | N0 => a
      | Npos p => Pos.iter_op op p a
      end.
Definition big_flat (a : nat) (sz : count) : nat
  := big_flat_op Nat.mul a sz.

Ltac check_sane ref_PHOAS :=
  lazymatch goal with
  | [ |- _ = PHOAS.Denote ?e ]
    => let val := (eval vm_compute in (PHOAS.Beq e ref_PHOAS)) in
       lazymatch val with
       | true => idtac
       | false => idtac "Error: Got" e "Expected:" ref_PHOAS; unify e ref_PHOAS
       end
  | [ |- _ = PHOAS.denote ?e ]
    => let ref_HOAS := (eval lazy in (ref_PHOAS nat)) in
       let val := (eval vm_compute in (PHOAS.beq e ref_HOAS)) in
       lazymatch val with
       | true => idtac
       | false => idtac "Error: Got" e "Expected:" ref_HOAS; unify e ref_HOAS
       end
  | [ |- ?LHS = ?Denote ?e ]
    => let G := match goal with |- ?G => G end in
       fail 0 "Unrecognized denotation function" Denote "in goal" G
  | [ |- _ = ?v ]
    => let G := match goal with |- ?G => G end in
       fail 0 "Not an application of a denotation function to one argument:" v "in goal" G
  | [ |- ?G ]
    => fail 0 "Not an equality:" G
  end.


Require Import A1_Plan A2_Orientation .
Require Import C1_Distance .
Require Import F2_MarkSegment F5_Tactics .
Require Import H1_Triangles .
Require Import I3_OpposedAngles .
Require Import J2_MidPoint .
Require Import K3_Tactics.

Unset Standard Proposition Elimination Names.

Section PARALLELOGRAMM.

Inductive Parallelogramm (A B C D : Point) : Prop :=
	| Pllgm : forall  (Hac: A <> C) (Hbd : B <> D), MidPoint A C Hac = MidPoint B D Hbd -> Parallelogramm A B C D.

Lemma ParallelogrammRev  : forall A B C D : Point,
	Parallelogramm A B C D -> Parallelogramm A D C B.
Proof.
	intros; inversion H.
	apply (Pllgm A D C B Hac (sym_not_eq Hbd)).
	step10 H0.
	immediate10.
Qed.

Lemma ParallelogrammPerm  : forall A B C D : Point,
	Parallelogramm A B C D -> Parallelogramm B C D A.
Proof.
	intros; inversion H.
	apply (Pllgm B C D A Hbd (sym_not_eq Hac)).
	step10 H0.
	immediate10.
Qed.

Definition PCenter  :forall A B C D : Point, Parallelogramm A B C D -> Point.
Proof.
	intros A B C D H; destruct H.
	exact (MidPoint A C Hac).
Defined.

Lemma PCenterHyp : forall A B C D : Point, forall H1 H2 : Parallelogramm A B C D,
	PCenter A B C D H1 = PCenter A B C D H2.
Proof.
	intros; unfold PCenter in |- *; dependent inversion H1; dependent inversion H2; simpl in |- *.
	immediate10.
Qed.

Lemma PCenterBetweenAC : forall A B C D : Point, forall H : Parallelogramm A B C D,
	Between A (PCenter A B C D H) C.
Proof.
	intros A B C D H; unfold PCenter in |- *.
	dependent inversion H.
	immediate10.
Qed.

Lemma PCenterBetweenBD : forall A B C D : Point, forall H : Parallelogramm A B C D,
	Between B (PCenter A B C D H) D.
Proof.
	intros A B C D H; unfold PCenter in |- *.
	dependent inversion H.
	step10 e.
	immediate10.
Qed.

Lemma PCenterEqDistanceAC  : forall A B C D : Point, forall H : Parallelogramm A B C D,
	Distance (PCenter A B C D H) A = Distance (PCenter A B C D H) C.
Proof.
	intros; unfold PCenter in |- *.
	dependent inversion H.
	immediate10.
Qed.

Lemma PCenterEqDistanceBD  : forall A B C D : Point, forall H : Parallelogramm A B C D,
	Distance (PCenter A B C D H) B = Distance (PCenter A B C D H) D.
Proof.
	intros; unfold PCenter in |- *.
	dependent inversion H.
	rewrite e; immediate10.
Qed.

Lemma ParallelogrammTCongruentAKBCKD : forall A B C D : Point, forall H : Parallelogramm A B C D,
	TCongruent (Tr A (PCenter A B C D H) B) (Tr C (PCenter A B C D H) D).
Proof.
	intros A B C D H; unfold PCenter in |- *.
	dependent inversion H.
	step10 3.
	 immediate10.
	 step10 e; immediate10.
	 from10 e (Between B (MidPoint A C Hac) D).
	  since10 (Between A (MidPoint A C Hac) C).
	   since10 (OpposedAngles (MidPoint A C Hac) A B C D).
Qed.

Lemma ParallelogrammTCongruentBKCDKA : forall A B C D : Point, forall H : Parallelogramm A B C D,
	TCongruent (Tr B (PCenter A B C D H) C) (Tr D (PCenter A B C D H) A).
Proof.
	intros A B C D H; unfold PCenter in |- *.
	dependent inversion H.
	step10 3.
	 step10 e; immediate10.
	 immediate10.
	 from10 e (Between B (MidPoint A C Hac) D).
	  since10 (Between A (MidPoint A C Hac) C).
	   since10 (OpposedAngles (MidPoint A C Hac) B C D A).
Qed.

Lemma ParallelogrammABeqCD  : forall A B C D : Point, forall H : Parallelogramm A B C D,
	Distance A B = Distance C D.
Proof.
	intros.
	assert (H0 := ParallelogrammTCongruentAKBCKD A B C D H).
	immediate10.
Qed.

Lemma ParallelogrammBCeqDA  : forall A B C D : Point, forall H : Parallelogramm A B C D,
	Distance B C = Distance D A.
Proof.
	intros.
	assert (H0 := ParallelogrammTCongruentBKCDKA A B C D H).
	immediate10.
Qed.

Lemma UniquePCenter : forall A B C D K : Point, forall H : Parallelogramm A B C D,
	(Between A K C /\ Distance A K = Distance K C) \/ (Between B K D /\ Distance B K = Distance K D) ->
	K = PCenter A B C D H.
Proof.
	intros; unfold PCenter in |- *; dependent inversion H.
	decompose [and or] H0.
	 step10 (MidPoint A C Hac).
	 rewrite e; step10 (MidPoint B D Hbd).
Qed.

Lemma ParallelogrammTCongruentABCCDA : forall A B C D : Point, forall H : Parallelogramm A B C D,
	TCongruent (Tr A B C) (Tr C D A).
Proof.
	intros.
	step10 1.
	 apply ParallelogrammABeqCD; immediate10.
	 apply ParallelogrammBCeqDA; immediate10.
Qed.

Lemma ParallelogrammTCongruentBCDDAB : forall A B C D : Point, forall H : Parallelogramm A B C D,
	TCongruent (Tr B C D) (Tr D A B).
Proof.
	intros.
	step10 1.
	 apply ParallelogrammBCeqDA; immediate10.
	 apply sym_eq; apply ParallelogrammABeqCD; immediate10.
Qed.

Lemma  ParallelogrammVertex4 : forall A B C : Point, forall  (Hac: A <> C) (Hbk : B <> MidPoint A C Hac),
	Parallelogramm A B C (SymmetricPoint B (MidPoint A C Hac) Hbk).
Proof.
	intros.
	setSymmetricPoint5 B (MidPoint A C Hac) ipattern:(D); fold D in |- *.
	assert (Hbd : B <> D).
	 immediate10.
	 apply (Pllgm A B C D Hac Hbd).
	   byDefEqPoint10.
	   step10 H.
Qed.

Lemma ParallelogrammDistinctABDistinctCD : forall A B C D : Point,
	Parallelogramm A B C D ->
	A <> B ->
	C <> D.
Proof.
	intros; step10 (ParallelogrammABeqCD A B C D H).
Qed.

Lemma ParallelogrammDistinctBCDistinctDA: forall A B C D : Point,
	Parallelogramm A B C D ->
	B <> C ->
	D <> A.
Proof.
	intros; step10 (ParallelogrammBCeqDA A B C D H).
Qed.

Lemma ParallelogrammDistinctCDDistinctAB : forall A B C D : Point,
	Parallelogramm A B C D ->
	C <> D ->
	A <> B.
Proof.
	intros; assert (H1 := ParallelogrammABeqCD A B C D H).
	step10 H1.
Qed.

Lemma ParallelogrammDistinctDADistinctBC : forall A B C D : Point,
	Parallelogramm A B C D ->
	D <> A ->
	B <> C.
Proof.
	intros; assert (H1 := ParallelogrammBCeqDA A B C D H).
	step10 H1.
Qed.

End PARALLELOGRAMM.