Require Import ssreflect ssrfun ssrbool eqtype.
Require Import ssrnat seq choice.
Require Import order.

Section Def.
  Variable TK : totalOrderType.
  Variable TV : eqType.
  Inductive tree : Type :=
    | empty : tree
    | node2 of tree & TK * TV & tree
    | node3 of tree & TK * TV & tree & TK * TV & tree.

  Fixpoint eqn t0 t1 { struct t0 } :=
    match t0,t1 with
    | empty, empty => true
    | node2 t0s0 t0e0 t0s1, node2 t1s0 t1e0 t1s1 =>
      [&& eqn t0s0 t1s0, (t0e0 == t1e0) & eqn t0s1 t1s1]
    | node3 t0s0 t0e0 t0s1 t0e1 t0s2,
      node3 t1s0 t1e0 t1s1 t1e1 t1s2 =>
      [&& eqn t0s0 t1s0, (t0e0 == t1e0),
          eqn t0s1 t1s1, (t0e1 == t1e1) & eqn t0s2 t1s2]
    | _,_ => false
    end.

  Lemma eqnP : Equality.axiom eqn.
  Proof.
    move=> t0 t1; apply: (iffP idP)=> [|<- {t1}].
    - elim: t0 t1 => [|t0s0 Hs0 t0e0 t0s1 Hs1
                      |t0s0 Hs0 t0e0 t0s1 Hs1 t0e1 t0s2 Hs2].
      - by case.
      - by case=> // t1s0 t1e0 t1s1 /=
                  /and3P [/Hs0<- /eqP<- /Hs1<-].
      - by case=> // t1s0 t1e0 t1s1 t1e1 t1s2 /=
                  /and5P [/Hs0<- /eqP<- /Hs1<- /eqP<- /Hs2<-].
    - elim: t0 => /= [|t0s0 -> t0e0 t0s1 ->
                      |t0s0 -> t0e0 t0s1 -> t0e1 t0s2 ->].
      - done.
      - by rewrite eq_refl.
      - by rewrite eq_refl eq_refl.
  Qed.

  Canonical tree_eqMixin := EqMixin eqnP.
  Canonical tree_eqType := Eval hnf in EqType tree tree_eqMixin.

  Fixpoint tree_check_ordered(t:tree) (lb ub:option TK) : bool :=
    match t with
    | empty =>
      match lb,ub with
      | Some lbs, Some ubs => lbs < ubs
      | _, _ => true
      end
    | node2 t0 (k0,v0) t1 =>
      tree_check_ordered t0 lb (Some k0) &&
      tree_check_ordered t1 (Some k0) ub
    | node3 t0 (k0,v0) t1 (k1,v1) t2 =>
      [&& tree_check_ordered t0 lb (Some k0),
          tree_check_ordered t1 (Some k0) (Some k1) &
          tree_check_ordered t2 (Some k1) ub]
    end.

  Fixpoint tree_depth(t:tree) : nat :=
    match t with
    | empty => 0
    | node2 t0 _ t1 => (maxn (tree_depth t0) (tree_depth t1)) .+1
    | node3 t0 _ t1 _ t2 =>
      (maxn (tree_depth t0) (maxn (tree_depth t1) (tree_depth t2))) .+1
    end.

  Fixpoint tree_check_depth(t:tree) : bool :=
    match t with
    | empty => true
    | node2 t0 _ t1 =>
      [&& (tree_depth t0 == tree_depth t1),
          tree_check_depth t0 & nosimpl tree_check_depth t1]
    | node3 t0 _ t1 _ t2 =>
      [&& (tree_depth t0 == tree_depth t1), (tree_depth t1 == tree_depth t2),
          tree_check_depth t0, tree_check_depth t1 & tree_check_depth t2]
    end.

  Definition tree_valid(t:tree) : bool :=
    tree_check_ordered t None None && tree_check_depth t.

  Definition T23 := sig tree_valid.

  Definition tree_append(k:TK) (v:TV):tree -> bool*tree :=
    fix recur(t:tree) :=
    match t with
    | empty => (true, node2 empty (k,v) empty)
    | node2 t0 ((k0,_) as e0) t1 =>
      if k < k0 then
        match recur t0 with
        | (true, node2 s0 se0 s1) =>
          (false, node3 s0 se0 s1 e0 t1)
        | (_, s) => (false, node2 s e0 t1)
        end
      else if k == k0 then
        (false, node2 t0 (k,v) t1)
      else
        match recur t1 with
        | (true, node2 s0 se0 s1) =>
          (false, node3 t0 e0 s0 se0 s1)
        | (_, s) => (false, node2 t0 e0 s)
        end
    | node3 t0 ((k0,_) as e0) t1 ((k1,_) as e1) t2 =>
      if k < k0 then
        match recur t0 with
        | (true, s) =>
          (true, node2 s e0 (node2 t1 e1 t2))
        | (_, s) => (false, node3 s e0 t1 e1 t2)
        end
      else if k == k0 then
        (false, node3 t0 (k,v) t1 e1 t2)
      else if k < k1 then
        match recur t1 with
        | (true, node2 s0 se0 s1) =>
          (true, node2 (node2 t0 e0 s0) se0 (node2 s1 e1 t2))
        | (_, s) => (false, node3 t0 e0 s e1 t2)
        end
      else if k == k1 then
        (false, node3 t0 e0 t1 (k,v) t2)
      else
        match recur t2 with
        | (true, s) =>
          (true, node2 (node2 t0 e0 t1) e1 s)
        | (_, s) => (false, node3 t0 e0 t1 e1 s)
        end
    end.

  Lemma tree_append_preserve_depth(t:tree) (k:TK) (v:TV):
    let (r,t') := tree_append k v t in
    (tree_depth t' =
      if r then (tree_depth t) .+1 else tree_depth t) /\
    match r,t' with
    | false,_ => true
    | _,node2 _ _ _ => true
    | _,_ => false
    end.
  Proof.
    elim: t => [|t0 Ht0 [k0 v0] t1 Ht1
                |t0 Ht0 [k0 v0] t1 Ht1 [k1 v1] t2 Ht2] /=.
    - done.
    - case: (compare3P TK k k0) => Hk.
      - case: (tree_append k v t0) Ht0 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Ht0]] // _.
          by rewrite maxnA Ht0.
        - by move=> [<- _].
      - done.
      - case: (tree_append k v t1) Ht1 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Ht1]] // _.
          by rewrite Ht1.
        - by move=> [<- _].
    - case: (compare3P TK k k0) => Hk0;
          [| |case: (compare3P TK k k1) => Hk1].
      - case: (tree_append k v t0) Ht0 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Ht0]] // _.
          by rewrite maxnSS Ht0.
        - by move=> [<- _].
      - done.
      - case: (tree_append k v t1) Ht1 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Ht1]] // _.
          by rewrite maxnSS -maxnA (maxnA (tree_depth s0)) Ht1.
        - by move=> [<- _].
      - done.
      - case: (tree_append k v t2) Ht2 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Ht2]] // _.
          by rewrite maxnSS -maxnA Ht2.
        - by move=> [<- _].
  Qed.

  Lemma maxn_eq m : maxn m m = m.
  Proof.
    by unfold maxn; case (m < m)%N.
  Qed.

  Lemma tree_append_preserves_depth_validity(t:tree) (k:TK) (v:TV):
      tree_check_depth t -> tree_check_depth (tree_append k v t).2.
  Proof.
    elim: t => [|t0 Ht0 [k0 v0] t1 Ht1
                |t0 Ht0 [k0 v0] t1 Ht1 [k1 v1] t2 Ht2] /=.
    - done.
    - case: (compare3P TK k k0) => Hk.
      - case: (tree_append k v t0)
              (tree_append_preserve_depth t0 k v) Ht0 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Hpd]] // _ Ht0A Ht0B.
          move: Ht0B Hpd => /and3P [/eqP<- /Ht0A/and3P[/eqP<- -> ->] ->] <-.
          by rewrite maxn_eq eq_refl.
        - by move=> /= [-> _] Ht0 /and3P [-> /Ht0-> ->].
      - done.
      - case: (tree_append k v t1)
              (tree_append_preserve_depth t1 k v) Ht1 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Hpd]] // _ Ht1A Ht1B.
          move: Ht1B Hpd => /and3P [/eqP<- ->/Ht1A/and3P[/eqP<- -> ->]] <-.
          by rewrite maxn_eq eq_refl.
        - by move=> /= [-> _] Ht1 /and3P [-> -> /Ht1->].
    - case: (compare3P TK k k0) => Hk0;
          [| |case: (compare3P TK k k1) => Hk1].
      - case: (tree_append k v t0)
              (tree_append_preserve_depth t0 k v) Ht0 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Hpd]] // _ Ht0A Ht0B.
          move: Ht0B Hpd =>
              /and5P[/eqP-> /eqP<- /Ht0A/and3P[/eqP<- -> ->] -> ->] ->.
          by rewrite maxn_eq eq_refl eq_refl eq_refl.
        - by move=> /= [-> _] Ht0 /and5P[-> -> /Ht0-> -> ->].
      - done.
      - case: (tree_append k v t1)
              (tree_append_preserve_depth t1 k v) Ht1 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Hpd]] // _ Ht1A Ht1B.
          move: Ht1B Hpd =>
              /and5P[/eqP-> /eqP<- -> /Ht1A/and3P[/eqP<- -> ->] ->].
          rewrite maxn_eq=> <-.
          by rewrite eq_refl eq_refl.
        - by move=> /= [-> _] Ht1 /and5P[-> -> -> /Ht1-> ->].
      - done.
      - case: (tree_append k v t2)
              (tree_append_preserve_depth t2 k v) Ht2 => [[|] s].
        - case: s => [|s0 se0 s1|s se0 s1 se1 s2] /= [[Hpd]] // _ Ht2A Ht2B.
          move: Ht2B Hpd =>
              /and5P[/eqP-> /eqP<- -> -> /Ht2A/and3P[/eqP<- -> ->]] ->.
          by rewrite maxn_eq eq_refl eq_refl eq_refl.
        - by move=> /= [-> _] Ht2 /and5P[-> -> -> -> /Ht2->].
  Qed.
  Lemma tree_append_preserves_order_validity(t:tree)
      (k:TK) (v:TV) (lb ub:option TK):
      (if lb is Some lbs then lbs < k else true) ->
      (if ub is Some ubs then k < ubs else true) ->
      tree_check_ordered t lb ub -> tree_check_ordered (tree_append k v t).2 lb ub.
  Proof.
    elim: t lb ub => [|t0 Ht0 [k0 v0] t1 Ht1
                |t0 Ht0 [k0 v0] t1 Ht1 [k1 v1] t2 Ht2] /=.
    - by move=> lb ub -> -> _.
    - case: (compare3P TK k k0) => Hk.
      - case: (tree_append k v t0) Ht0
            => [[|] [|s0 [sk0 sv0] s1|s [sk0 sv0] s1 [sk1 sv1] s2]]
               /= Ht0A lb ub Hlb Hub /andP[Ht0B ->];
          try by rewrite (Ht0A lb (Some k0) Hlb Hk Ht0B).
        by rewrite Bool.andb_true_r Ht0A.
      - by move: Hk => /eqP<-.
      - by case: (tree_append k v t1) Ht1
               => [[|] [|s0 [sk0 sv0] s1|s [sk0 sv0] s1 [sk1 sv1] s2]]
                  /= Ht1A lb ub Hlb Hub /andP[-> Ht1B];
           rewrite (Ht1A _ _ _ Hub Ht1B).
    - case: (compare3P TK k k0) => Hk0;
          [| |case: (compare3P TK k k1) => Hk1].
      - by case: (tree_append k v t0) Ht0
               => [[|] [|s0 se0 s1|s se0 s1 se1 s2]]
                  /= Ht0A lb ub Hlb Hub /and3P[Ht0B -> ->];
           rewrite (Ht0A _ _ Hlb _ Ht0B).
      - by move: Hk0 => /eqP<-.
      - case: (tree_append k v t1) Ht1
            => [[|] [|s0 [sk0 sv0] s1|s [sk0 sv0] s1 [sk1 sv1] s2]]
                     /= Ht1A lb ub Hlb Hub /and3P[-> Ht1B ->];
          try by move: (Ht1A (Some k0) (Some k1) Hk0 Hk1 Ht1B)=> /andP [-> ->].
        - by rewrite (lt_trans _ _ _ _ Hk0 Hk1).
        - by rewrite (lt_trans _ _ _ _ Hk0 Hk1).
      - by move: Hk1 => /eqP<-.
      - by case: (tree_append k v t2) Ht2
               => [[|] [|s0 se0 s1|s se0 s1 se1 s2]]
                  /= Ht2A lb ub Hlb Hub /and3P[-> -> Ht2B];
           rewrite (Ht2A _ _ _ Hub Ht2B).
  Qed.

  Lemma tree_append_preserves_validity(t:tree) (k:TK) (v:TV):
      tree_valid t -> tree_valid (tree_append k v t).2.
  Proof.
    move=> /andP[valid_order valid_depth].
    by rewrite /tree_valid
        (tree_append_preserves_order_validity t k v None None isT isT valid_order)
        (tree_append_preserves_depth_validity t k v valid_depth).
  Qed.

  Definition append(t:T23) (k:TK) (v:TV):T23 :=
      exist _ (tree_append k v (proj1_sig t)).2
      (tree_append_preserves_validity (proj1_sig t) k v (proj2_sig t)).
End Def.


(* isomorphism.v *)

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

Require Import Arith.

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

(* Tao's representation: *)

Inductive int : Type :=
| Int : nat -> nat -> int.

Notation "a -- b" := (Int a b) (at level 70, no associativity).

(* Signed integer representation: *)

Inductive sint : Type :=
| P : nat -> sint
| Z : sint
| N : nat -> sint.

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

(* Tao's integer equality: *)

Definition int_eq (x y : int) : Prop :=
  match x, y with
  | (a -- b), (c -- d) =>
    a + d = c + b
  end.

Definition int_eqb (x y : int) : bool :=
  match x, y with
  | (a -- b), (c -- d) =>
    a + d =? c + b
  end.

Definition test_int_of_sint (int_of_sint : sint -> int) : bool :=
  (int_eqb (int_of_sint Z) (0 -- 0))
    && (int_eqb (int_of_sint Z) (3 -- 3))
    && (int_eqb (int_of_sint Z) (9 -- 9))
    && (int_eqb (int_of_sint (P 0)) (1 -- 0))
    && (int_eqb (int_of_sint (P 15)) (16 -- 0))
    && (int_eqb (int_of_sint (P 4)) (7 -- 2))
    && (int_eqb (int_of_sint (P 7)) (20 -- 12))
    && (int_eqb (int_of_sint (N 0)) (0 -- 1))
    && (int_eqb (int_of_sint (N 6)) (0 -- 7))
    && (int_eqb (int_of_sint (N 9)) (6 -- 16))
    && (int_eqb (int_of_sint (N 13)) (14 -- 28)).

Definition int_of_sint (x : sint) :=
  match x with
  | P px =>
    (px + 1 -- 0)
  | Z => (0 -- 0)
  | N nx =>
    (0 -- nx + 1)
  end.

Compute (test_int_of_sint int_of_sint).

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

(* Signed integer equality: *)

Definition sint_eq (i1 i2 : sint) : Prop :=
  match i1 with
  | P n1 =>
    match i2 with
    | P n2 =>
      n1 = n2
    | Z =>
      False
    | N n2 =>
      False
    end
  | Z =>
    match i2 with
    | P n2 =>
      False
    | Z =>
      True
    | N n2 =>
      False
    end
  | N n1 =>
    match i2 with
    | P n2 =>
      False
    | Z =>
      False
    | N n2 =>
      n1 = n2
    end
  end.

Definition sint_eqb (i1 i2 : sint) : bool :=
  match i1 with
  | P n1 =>
    match i2 with
    | P n2 =>
      n1 =? n2
    | Z =>
      false
    | N n2 =>
      false
    end
  | Z =>
    match i2 with
    | P n2 =>
      false
    | Z =>
      true
    | N n2 =>
      false
    end
  | N n1 =>
    match i2 with
    | P n2 =>
      false
    | Z =>
      false
    | N n2 =>
      n1 =? n2
    end
  end.

Definition test_sint_of_int (sint_of_int : int -> sint) : bool :=
  (sint_eqb (sint_of_int (0 -- 0)) Z)
    && (sint_eqb (sint_of_int (7 -- 7)) Z)
    && (sint_eqb (sint_of_int (9 -- 8)) (P 0))
    && (sint_eqb (sint_of_int (8 -- 9)) (N 0))
    && (sint_eqb (sint_of_int (13 -- 2)) (P 10))
    && (sint_eqb (sint_of_int (9 -- 15)) (N 5)).

Definition sint_of_int (x : int) :=
  match x with
  | (a -- b) =>
    if a =? b
    then Z
    else if a <? b
         then N (b - a - 1)
         else P (a - b - 1)
  end.

Compute (test_sint_of_int sint_of_int).

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

Proposition int_of_sint_and_back :
  forall x : sint,
    sint_eq x (sint_of_int (int_of_sint x)).
Proof.
  intros [px |  | nx];
    unfold int_of_sint, sint_of_int, sint_eq.
  - Search (0 < S _).
    assert (H_lt := Nat.lt_0_succ px).
    case (px + 1 =? 0) as [ | ] eqn:H_eqb.
    + assert (H_eq := beq_nat_true (px + 1) 0 H_eqb).
      rewrite -> Nat.add_1_r in H_eq.
      Search (_ < _ -> _ <> _).
      contradiction (lt_0_neq (S px) H_lt (eq_sym H_eq)).
    + case (px + 1 <? 0) as [ | ] eqn:H_ltb.
      -- Search (_ < _ -> _).
         assert (H_nlt := Nat.lt_asymm 0 (S px) H_lt).
         unfold not in H_nlt.
         destruct (Nat.ltb_lt (px + 1) 0) as [H_ltb_lt _].
         assert (H_lt_absurd := H_ltb_lt H_ltb);
           clear H_ltb_lt.
         rewrite -> Nat.add_1_r in H_lt_absurd.
         contradiction (H_nlt H_lt_absurd).
      -- Search (_ - 0).
         rewrite -> Nat.sub_0_r.
         Search (_ + _ - _).
         rewrite -> Nat.add_sub.
         reflexivity.
  - Search (Nat.eqb).
    rewrite -> (Nat.eqb_refl 0).
    exact I.
  - Search (0 < S _).
    assert (H_lt := Nat.lt_0_succ nx).
    case (0 =? nx + 1) as [ | ] eqn:H_eqb.
    + assert (H_eq := beq_nat_true 0 (nx + 1) H_eqb).
      rewrite -> Nat.add_1_r in H_eq.
      contradiction (lt_0_neq (S nx) H_lt H_eq).
    + case (0 <? nx + 1) as [ | ] eqn:H_ltb.
      -- rewrite -> Nat.sub_0_r.
         rewrite -> Nat.add_sub.
         reflexivity.
      -- Search (_ <? _).
         destruct (Nat.ltb_nlt 0 (nx + 1)) as [H_ltb_nlt _].
         assert (H_nlt := H_ltb_nlt H_ltb);
           clear H_ltb_nlt.
         rewrite -> Nat.add_1_r in H_nlt.
         unfold not in H_nlt.
         contradiction (H_nlt H_lt).
Qed.

Proposition sint_of_int_and_back :
  forall x : int,
    int_eq x (int_of_sint (sint_of_int x)).
Proof.
  intros [a b].
  unfold sint_of_int.
  case (a =? b) as [ | ] eqn:H_eqb;
    unfold int_of_sint, int_eq.
  - rewrite -> Nat.add_0_r.
    rewrite -> Nat.add_0_l.
    exact (beq_nat_true a b H_eqb).
  - case (a <? b) as [ | ] eqn:H_ltb.
    + destruct (Nat.ltb_lt a b) as [H_ltb_lt _].
      assert (H_lt := H_ltb_lt H_ltb);
        clear H_ltb_lt; clear H_ltb.
      Search (_ - _ + _).
      Check (Nat.sub_add 1 (b - a)).
      Search (_ < _ - _).
      destruct (Nat.lt_add_lt_sub_r 0 b a) as [H_lt_add_sub _].
      rewrite <- (Nat.add_0_l a) in H_lt.
      assert (H_lt_sub := H_lt_add_sub H_lt);
        clear H_lt_add_sub.
      Search (_ < _ -> _ <= _).
      assert (H_le_S := lt_le_S 0 (b - a) H_lt_sub).
      rewrite -> (Nat.sub_add 1 (b - a) H_le_S).
      Search (_ + _ - _).
      rewrite -> Nat.add_0_l in H_lt.
      rewrite -> (Nat.add_sub_assoc
                    a b a (Nat.lt_le_incl a b H_lt)).
      rewrite -> minus_plus.
      rewrite -> Nat.add_0_l.
      reflexivity.
    + destruct (Nat.ltb_ge a b) as [H_ltb_ge _].
      assert (H_ge := H_ltb_ge H_ltb);
        clear H_ltb_ge.
      assert (H_neq := beq_nat_false a b H_eqb).
      Search ( _ <= _ /\ _ <> _).
      destruct (Nat.le_neq b a) as [_ H_le_neq].
      assert (H_gt := H_le_neq (conj H_ge (Nat.neq_sym a b H_neq)));
        clear H_le_neq.
      destruct (Nat.lt_add_lt_sub_r 0 a b) as [H_lt_add_sub _].
      rewrite <- Nat.add_0_l in H_gt at 1.
      assert (H_gt_sub := H_lt_add_sub H_gt);
        clear H_lt_add_sub.
      assert (H_ge_S := lt_le_S 0 (a - b) H_gt_sub);
        clear H_gt_sub.
      rewrite -> (Nat.sub_add 1 (a - b) H_ge_S).
      rewrite -> Nat.add_0_l in H_gt.
      rewrite -> (Nat.sub_add b a H_ge).
      rewrite -> Nat.add_0_r.
      reflexivity.
Qed.

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

(* end of isomorphism.v *)


Require Import HoTT.
Require Import HoTT.Basics.PathGroupoids.

Theorem fibers_equiv : forall (X : Type) (E : X -> Type) (x y : X)
                              (f : x = y), E(x) <~> E(y).
Proof.
  intros.
  split with (equiv_fun:=(transport E f)).
  simple refine (BuildIsEquiv _ _ _ (transport E (f^)) _ _ _).
  intro. induction f. simpl. reflexivity.
  intro. induction f. simpl. reflexivity.
  intro. simpl. induction f. simpl. reflexivity.
Qed.

Theorem equiv_fibers : forall (X : Type) (E1 E2 : X -> Type),
    ((sig E1) <~> (sig E2)) -> forall x, E1(x) <~> E2(x).
Proof.
  intros X E1 E2 h. intro x.


(*|
A few things to keep in mind as you work through pset 1
=======================================================
|*)

Require Import Frap.

(*|
Coq resources
-------------

- Start by looking for examples in the course textbook, including the tactic appendix at the end of the book.

- For help on standard Coq tactics, consult Coq's reference manual (https://coq.inria.fr/distrib/current/refman/), starting from the indices at https://coq.inria.fr/distrib/current/refman/appendix/indexes/index.html.  The manual can be overwhelming, so it's best used for looking up fine details.

Useful commands
---------------

Coq comes with many predefined types, functions, and theorems (“objects”).  The most important commands to help you discover them are `Check`, `About`, `Print`, `Search`, and `Compute`.  Try the following examples:

`Check` gives the type of any term, even with holes:
|*)

Check (1 + _).
Check (fun b => match b with true => 0 | false => 1 end).

(*|
`About` gives general information about an object:
|*)

About bool.
About nat.

(*|
`Print` displays the definition of an object:
|*)

Print bool.
Print Nat.add.

(*|
`Search` finds objects.  Its syntax is very flexible:
|*)

(* Find functions of type [nat -> nat -> bool]. *)
Search (nat -> nat -> bool).
(* Find theorems about "+". *)
Search "+".
(* Find theorems whose statement mentions S and eq. *)
Search eq S.
(* Search for a lemma proving the symmetry of eq. *)
Search (?x = ?y -> ?y = ?x).

(*|
If you are puzzled by a notation, the `Locate` command can help:
|*)

Locate "*".

(*|
To evaluate an expression, use `Compute`:
|*)

Compute (2 * 3, 4 + 4, 0 - 2 + 2, pred (S (S (S 0)))).

(*|
Syntax recap
------------

To define a function inline, use `fun`:
|*)

Check (fun x => x + 1).
Check (fun x: bool => xorb x x).

(*|
To perform a case analysis on a value, use `match`:
|*)

Check (fun b (x y: nat) =>
         match b with
         | true => x
         | false => y
         end).

Check (fun (n: nat) =>
         match n with
         | 0 => 1
         | S n => n
         end).

(*|
In Coq, `if` is just short for `match`:
|*)

Check (fun (b: bool) (x y: nat) =>
         if b then x else y).

(*|
To define a global object, use `Definition` or `Lemma` (`Theorem` is an alias of `Lemma`):
|*)

Definition choose (b: bool) (x y: nat) :=
  if b then x else y.

Compute (choose true 6 822).

Lemma plus_commutes :
  forall x, x = x + 0 + 0.
Proof.
  intros.
  Search (_ + 0).
  rewrite <- plus_n_O.
  rewrite <- plus_n_O.
  equality.
Qed.

(*|
Recursive functions use the keyword `Fixpoint`:
|*)

Fixpoint do_n_times (ntimes: nat) (step: nat -> nat) (start_from: nat) :=
  match ntimes with
  | 0 => start_from
  | S ntimes' => step (do_n_times ntimes' step start_from)
  end.

Compute (6, do_n_times 12 (fun x => x + 65) 42).

(*|
You can use bullets or braces to structure your proofs:
|*)

Lemma both_zero:
  forall x y z: nat, x + y + z = 0 -> x = 0 /\ y = 0 /\ z = 0.
Proof.
  intros x.
  cases x.
  - intros.
    cases y.
    + propositional.
    + simplify.
      invert H.
  - intros y z Heq.
    simplify.
    invert Heq.
Qed.

(*|
A few gotchas
-------------

Natural numbers saturate at 0:
|*)

Compute (3 - 5 + 3).

(*|
The order in which you perform induction on variables matters: if `x` comes before `y` and you induct on `y`, your induction hypothesis will not be general enough.
|*)

Lemma add_comm:
  forall x y: nat, x + y = y + x.
Proof.
  induct y.
  - induct x; simplify; equality.
  - simplify.
    (* `IHy` is valid only for one specific `y` *)
Abort.

Lemma add_comm:
  forall x y: nat, x + y = y + x.
Proof.
  induct x.
  - induct y; simplify; equality.
  - simplify.
    (* `IHx` starts with `forall y`. *)
Abort.

(*|
Here's an example where this subtlety matters:
|*)

Fixpoint factorial (n: nat) :=
  match n with
  | O => 1
  | S n' => n * factorial n'
  end.

Fixpoint factorial_acc (n: nat) (acc: nat) :=
  match n with
  | O => acc
  | S n' => factorial_acc n' (n * acc)
  end.

(*|
First attempt, but our lemma is too weak.
|*)

Lemma factorial_acc_correct:
  forall n, factorial n = factorial_acc n 1.
Proof.
  induct n.
  - equality.
  - simplify.
    Search (_ * 1).
    rewrite Nat.mul_1_r.

(*|
Stuck!  We have no way to simplify `factorial_acc n (S n)`.
|*)

Abort.

(*|
Second attempt: a generalized lemma, but we put the `acc` first, so induction will not generalize it.
|*)

Lemma factorial_acc_correct:
  forall acc n, factorial n * acc = factorial_acc n acc.
Proof.
  induct n.
  - simplify.
    Search (_ + 0).
    rewrite Nat.add_0_r.
    equality.
  - simplify.
    Fail rewrite <- IHn.

(*|
Stuck!  IHn is too weak.
|*)

Abort.

(*|
Third time's the charm!  Note how we ordered `n` and `acc`.
|*)

Lemma factorial_acc_correct:
  forall n acc, factorial n * acc = factorial_acc n acc.
Proof.
  induct n.
  - simplify.
    linear_arithmetic.
  - simplify.

(*|
IHn is strong enough now!
|*)

    rewrite <- IHn.
    linear_arithmetic.
Qed.


(*########################################################*)
(*#-------3 Main Properties and other related terms------#*)
(*########################################################*)

Require Export Definitions.

Set Implicit Arguments.

Section Properties.

Section competitiveness.

Definition bcompetitive (b b':order):= (Nat.ltb (oprice b') (oprice b)) ||
((Nat.eqb (oprice b') (oprice b)) && (Nat.leb (otime b) (otime b') )).

Definition acompetitive (a a':order):= (Nat.ltb (oprice a) (oprice a')) ||
((Nat.eqb (oprice a) (oprice a')) && (Nat.leb (otime a) (otime a') )).

Definition eqcompetitive (a a':order):= ((Nat.eqb (oprice a) (oprice a')) && (Nat.eqb (otime a) (otime a') )).

Lemma bcompetitive_contadiction (b b':order):
bcompetitive b b'-> bcompetitive b' b -> ~eqcompetitive b b' -> False.
Proof. unfold bcompetitive.  unfold eqcompetitive. intros.
       move /orP in H. move /orP in H0. destruct H0; destruct H.
       {  move /ltP in H. move /ltP in H0. lia. }
       {  destruct H1. move /andP in H. destruct H.
          apply /andP. move /eqP in H.  split. apply /eqP.
          auto. move /ltP in H0. move /leP in H1. lia. }
       {  destruct H1. move /andP in H0. destruct H0.
          apply /andP. move /eqP in H0.  split. apply /eqP.
          auto. move /ltP in H. move /leP in H1. lia. }
       {  destruct H1. move /andP in H0. destruct H0.
          move /andP in H. destruct H. apply /andP. split.
          auto. move /leP in H1. move /leP in H2. apply /eqP. lia. } Qed.

Lemma acompetitive_contadiction (a a':order):
acompetitive a a'-> acompetitive a' a -> ~eqcompetitive a a' -> False.
Proof. unfold acompetitive.  unfold eqcompetitive. intros.
       move /orP in H. move /orP in H0. destruct H0; destruct H.
       {  move /ltP in H. move /ltP in H0. lia. }
       {  destruct H1. move /andP in H. destruct H.
          apply /andP. move /eqP in H.  split. apply /eqP.
          auto. move /ltP in H0. move /leP in H1. lia. }
       {  destruct H1. move /andP in H0. destruct H0.
          apply /andP. move /eqP in H0.  split. apply /eqP.
          auto. move /ltP in H. move /leP in H1. lia. }
       {  destruct H1. move /andP in H0. destruct H0.
          move /andP in H. destruct H. apply /andP. split.
          auto. move /leP in H1. move /leP in H2. apply /eqP. lia. } Qed.

Lemma bcompetitive_P : transitive bcompetitive /\ comparable2 bcompetitive.
Proof.  { split.
          { unfold transitive. unfold bcompetitive.
            intros y x z H H1. move /orP in H1. move /orP in H.
            apply /orP. destruct H1;destruct H.
            { left. move /leP in H0. move /leP in H. apply /leP. lia. }
            { move /andP in H. destruct H. left.
              move /leP in H0. move /eqP in H. apply /leP. lia. }
            { move /andP in H0. destruct H0. left.
              move /leP in H. move /eqP in H0. apply /leP. lia. }
            { move /andP in H0. move /andP in H. destruct H0. destruct H.
              right.
              move /eqP in H. move /eqP in H0. apply /andP.
              split. apply /eqP. lia. apply /leP. move /leP in H1.
              move /leP in H2. lia. } }
            { unfold comparable2.
              unfold bcompetitive. intros. destruct x. destruct y.  simpl.
              assert((oprice0 = oprice)\/(oprice0 < oprice)\/(oprice < oprice0)).
              lia. destruct H.
              subst. assert(Nat.ltb oprice oprice = false).
              apply /ltP. lia. rewrite H. simpl.
              assert(Nat.eqb oprice oprice =true). auto. rewrite H0. simpl.
              assert((otime0 <= otime)\/(otime < otime0)). lia. destruct H1.
              right. apply /leP. auto. left. apply /leP. lia.
              destruct H. left. apply /orP. left. apply /ltP. auto. right.
              apply /orP. left. apply /ltP. auto.
               } } Qed.

Lemma acompetitive_P : transitive acompetitive /\ comparable2 acompetitive.
Proof.  { split.
          { unfold transitive. unfold acompetitive.
            intros y x z H H1. move /orP in H1. move /orP in H.
            apply /orP. destruct H1;destruct H.
            { left. move /leP in H0. move /leP in H. apply /leP. lia. }
            { move /andP in H. destruct H. left.
              move /leP in H0. move /eqP in H. apply /leP. lia. }
            { move /andP in H0. destruct H0. left.
              move /leP in H. move /eqP in H0. apply /leP. lia. }
            { move /andP in H0. move /andP in H. destruct H0. destruct H.
              right.
              move /eqP in H. move /eqP in H0. apply /andP.
              split. apply /eqP. lia. apply /leP. move /leP in H1.
              move /leP in H2. lia. } }
            { unfold comparable2.
              unfold acompetitive. intros. destruct x. destruct y.  simpl.
              assert((oprice0 = oprice)\/(oprice < oprice0)\/(oprice0 < oprice)).
              lia. destruct H.
              subst. assert(Nat.ltb oprice oprice = false).
              apply /ltP. lia. rewrite H. simpl.
              assert(Nat.eqb oprice oprice =true). auto. rewrite H0. simpl.
              assert((otime0 <= otime)\/(otime < otime0)). lia. destruct H1.
              right. apply /leP. auto. left. apply /leP. lia.
              destruct H. left. apply /orP. left. apply /ltP. auto. right.
              apply /orP. left. apply /ltP. auto.
               } } Qed.

Lemma not_acompetitive (a1 a2:order): ~acompetitive a1 a2 -> acompetitive a2 a1.
Proof. unfold acompetitive. intros H. unfold not in H. apply /orP.
       destruct(Nat.ltb (oprice a1) (oprice a2)) eqn:H1.
       { simpl in H. destruct H. auto. }
       { simpl in H.  destruct(Nat.eqb (oprice a1) (oprice a2)) eqn: H2.
          { simpl in H. destruct (Nat.leb (otime a1) (otime a2)) eqn: H3.
           destruct H. auto. right. apply /andP. split. move /eqP in H2.
           rewrite H2. apply /eqP. auto. move /leP in H3. apply /leP. lia. }
          { simpl in H. destruct (Nat.leb (otime a1) (otime a2)) eqn: H3.
            move /ltP in H1. move /eqP in H2. left. apply /ltP. lia.
            move /ltP in H1. move /eqP in H2. move /leP in H3.
            left. apply /ltP. lia.
           }
         }
         Qed.

Lemma not_bcompetitive (b1 b2:order): ~bcompetitive b1 b2 -> bcompetitive b2 b1.
Proof. unfold bcompetitive. intros H. unfold not in H. apply /orP.
       destruct(Nat.ltb (oprice b2) (oprice b1)) eqn:H1.
       { simpl in H. destruct H. auto. }
       { simpl in H.  destruct(Nat.eqb (oprice b2) (oprice b1)) eqn: H2.
          { simpl in H. destruct (Nat.leb (otime b1) (otime b2)) eqn: H3.
           destruct H. auto. right. apply /andP. split. move /eqP in H2.
           rewrite H2. apply /eqP. auto. move /leP in H3. apply /leP. lia. }
          { destruct (Nat.leb (otime b1) (otime b2)) eqn: H3.
            move /ltP in H1. move /eqP in H2. left. apply /ltP. lia.
            move /ltP in H1. move /eqP in H2. move /leP in H3.
            left. apply /ltP. lia.
           }
         }
         Qed.

End competitiveness.

Notation "s === t" := (perm s t) (at level 80, no associativity).

Inductive command:Set:=
|buy
|sell
|del.

Record instruction :Type:= Mk_instruction { cmd : command; ord : order}.
Definition action0:=del.
Definition tau0:={| cmd := action0; ord := w0 |}.

Definition Absorb (B A: list order)(tau: instruction):=
match (cmd tau) with
|buy => ((ord tau)::B, A)
|sell =>(B, (ord tau)::A)
|del =>(delete_order B (id (ord tau)), delete_order A (id (ord tau)))
end.

Lemma Absorb_perm (B1 B2 A1 A2 : list order)(tau: instruction):
perm B1 B2 -> perm A1 A2 ->
perm (fst (Absorb B1 A1 tau)) (fst (Absorb B2 A2 tau))/\
perm (snd (Absorb B1 A1 tau)) (snd (Absorb B2 A2 tau)).
Proof. case (cmd tau) eqn:H. unfold Absorb. replace (cmd tau) with buy. simpl. eauto.
unfold Absorb. replace (cmd tau) with sell. simpl. eauto.
unfold Absorb. replace (cmd tau) with del. simpl. intros. split.
apply delete_order_perm. auto. apply delete_order_perm. auto. Qed.

Lemma Absorb_notIn_nodup_id (B A: list order)(tau: instruction):
NoDup (ids B) ->NoDup (ids A) -> ~In (id (ord tau)) (ids B) -> ~In (id (ord tau)) (ids A) ->
NoDup (ids (fst (Absorb B A tau)))/\NoDup (ids (snd (Absorb B A tau))).
Proof. intros. case (cmd tau) eqn:Ht.
split. unfold Absorb. replace (cmd tau) with buy. simpl. eauto.
unfold Absorb. replace (cmd tau) with buy. simpl. eauto.
unfold Absorb. replace (cmd tau) with sell. simpl. eauto.
unfold Absorb. replace (cmd tau) with del. simpl. split.
apply delete_order_ids_nodup. auto. apply delete_order_ids_nodup. auto.
Qed.

Lemma Absorb_del_nodup_id (B A: list order)(tau: instruction):
NoDup (ids B) ->NoDup (ids A) -> (cmd tau ) = del ->
NoDup (ids (fst (Absorb B A tau)))/\NoDup (ids (snd (Absorb B A tau))).
Proof. intros. unfold Absorb. rewrite H1. simpl. split. apply delete_order_ids_nodup. auto. apply delete_order_ids_nodup. auto. Qed.

Lemma Absorb_notIn_nodup_time (B A: list order)(tau: instruction):
NoDup (timesof B) ->NoDup (timesof A) -> ~In (otime (ord tau)) (timesof B) ->
~In (otime (ord tau)) (timesof A) ->
NoDup (timesof (fst (Absorb B A tau)))/\NoDup (timesof (snd (Absorb B A tau))).
Proof. intros. case (cmd tau) eqn:Ht.
unfold Absorb. replace (cmd tau) with buy. simpl. eauto.
unfold Absorb. replace (cmd tau) with sell. simpl. eauto.
unfold Absorb. replace (cmd tau) with del. simpl.
split. apply delete_order_timesof_nodup. auto. apply delete_order_timesof_nodup. auto.
Qed.

Definition Condition1 (M: list transaction)(B A hat_B hat_A: list order)
(tau: instruction):Prop:=
not (matchable hat_B hat_A).

Definition Condition2a (M: list transaction)(B:list order):Prop:=
forall b b', (In b B)/\(In b' B)/\(bcompetitive b b'/\~eqcompetitive b b')/\(In (id b') (ids_bid_aux M)) ->
(Qty_bid M (id b)) = (oquantity b).

Definition Condition2b (M: list transaction)(A:list order):Prop:=
forall a a', (In a A)/\(In a' A)/\(acompetitive a a'/\~eqcompetitive a a')/\(In (id a') (ids_ask_aux M)) ->
(Qty_ask M (id a)) = (oquantity a).

Definition Condition3a (M: list transaction)(B A: list order)
(tau: instruction):Prop:=
let B' := (fst (Absorb B A tau)) in
let A' := (snd (Absorb B A tau)) in
Matching M B' A'.

Definition Condition3b (M: list transaction)(B A hat_B: list order)
(tau: instruction):Prop:=
let B' := (fst (Absorb B A tau)) in
hat_B === (odiff B' (bids M B')).

Definition Condition3c (M: list transaction)(B A hat_A: list order)
(tau: instruction):Prop:=
let A' := (snd (Absorb B A tau)) in
(hat_A === (odiff A' (asks M A'))).

Definition admissible (B A :list order) :=
(NoDup (ids B))/\(NoDup (ids A))/\
(NoDup (timesof B))/\(NoDup (timesof A)).

Definition Legal_input (B A :list order)(tau: instruction):=
admissible (fst (Absorb B A tau)) (snd (Absorb B A tau))/\
not (matchable B A).

Lemma legal_perm (B1 B2 A1 A2 : list order)(tau: instruction):
perm B1 B2/\ perm A1 A2/\Legal_input B1 A1 tau -> Legal_input B2 A2 tau.
Proof. unfold Legal_input. intros H. destruct H. destruct H0.
destruct H1 as [Hb Ha]. unfold admissible in Hb.
destruct Hb as [Hb Hc]. destruct Hc as [Hc Hd].  destruct Hd as [Hd He].
assert(G1:=H). assert(G2:=H0).
unfold perm in G1. move /andP in G1. destruct G1 as [G1a G1b].
unfold perm in G2. move /andP in G2. destruct G2 as [G2a G2b].
apply Absorb_perm with (B1:=B1)(B2:=B2)(tau:=tau) in H0.
destruct H0. repeat split.
apply ids_perm in H0. eauto.
apply ids_perm in H1. eauto.
apply timesof_perm in H0. eauto.
apply timesof_perm in H1. eauto.
intro. destruct Ha.
unfold matchable in H2. destruct H2. destruct H2.
unfold matchable. exists x. exists x0. destruct H2.
destruct H3.
split. eauto. split. eauto. auto. auto. Qed.

Definition Properties (Process: (list order) ->(list order) ->instruction
-> (list order)*(list order)*(list transaction)):=
forall A B tau,
Legal_input B A tau ->
let B' := (fst (Absorb B A tau)) in
let A' := (snd (Absorb B A tau)) in
let hat_B := (Blist (Process B A tau)) in
let hat_A := (Alist (Process B A tau)) in
let M := (Mlist (Process B A tau)) in

Condition1 M B A hat_B hat_A tau /\
Condition2a M B'/\
Condition2b M A'/\
Condition3a M B A tau /\
Condition3b M B A hat_B tau /\
Condition3c M B A hat_A tau.

(*----------------Term require for Gloal theorem part----------------*)

Fixpoint orders (I:list instruction) :(list order):=
match I with
|nil => nil
|i::I' => (ord i)::orders I'
end.

Fixpoint tilln (l: list order)(k:nat):=
match (l,k) with
|(nil, 0) => nil
|(x::l', 0) => x::nil
|(nil, S k) => nil
|(hd::tail, S k) => hd::(tilln tail k)
end.

Lemma tilln_contains_nth (l: list order)(k:nat):
l<>nil/\|l|>=k+1 -> In (nth k l w0) (tilln l k).
Proof. revert k. induction l. intros. destruct H. destruct H. auto.
       destruct k.  simpl. auto. simpl.
       intros. destruct H. assert(l<>nil). intro.
       subst l. simpl in H0. lia. right. apply IHl. split.
       auto. lia. Qed.

Lemma tilln_Subset_whole (l: list order)(k:nat):
Subset (tilln l k) l.
Proof. revert k. induction l. destruct k eqn: Hk. simpl. auto.
simpl. auto. destruct k eqn: Hk. simpl. auto. simpl.
apply Subset_intro. auto. Qed.

Lemma tilln_Subset_next (I: list order)(k:nat):
Subset (tilln I (k-1)) (tilln I k).
Proof. revert I. induction k. simpl. auto. intros.
replace (S k -1) with k. destruct k. destruct I. simpl. auto.
simpl. auto. destruct I. simpl. auto. simpl.
replace (S k -1) with k in IHk. specialize (IHk I).
eauto. lia. lia. Qed.

Lemma timesof_nodup_notIn (B: list order)(k: nat):
NoDup (timesof B) -> Sorted Nat.ltb (timesof B) ->
S k <= (| B |) -> k>0 ->
~In (otime (nth k B w0)) (timesof (tilln B (k - 1))).
Proof. revert B. induction k. intros. lia.
 destruct B. simpl. intros. lia. replace (S k -1) with k.
destruct k. simpl. intros. destruct B. simpl in H1. lia.
simpl. intro. destruct H3.
apply Sorted_elim4 with (x:= (otime o0)) in H0. move /ltP in H0.  lia.
simpl.  auto.  auto. simpl. intros. assert(In (nth (S k) B w0) B).
assert(In (nth (S k) B w0) (tilln B (S k))).
apply tilln_contains_nth. split. intro.
subst B. simpl in H1. lia. lia. assert(Subset (tilln B (S k)) B).
apply tilln_Subset_whole. auto. intro.
destruct H4. apply timesof_elim in H3.
apply Sorted_elim4 with (x:= (otime (nth (S k) B w0))) in H0.
move /ltP in H0.  lia.  auto. assert(S (S k) <= (| B |)). lia.
apply IHk in H5. replace (S k -1) with k in H5.
destruct (H5 H4). lia. eauto. eauto. lia. lia. Qed.

Lemma ordersI_length (I:list instruction) :
|I| = |orders I|.
Proof. induction I. simpl;auto. simpl;lia. Qed.

Lemma ordersI_nil (I:list instruction) :
I <> nil -> (orders I) <> nil.
Proof. intros. induction I. destruct H. auto. simpl.
       intro. inversion H0. Qed.

Definition structured (I :list instruction):=
(forall t:nat,  (t+1) <= (length I) -> (cmd (nth t I tau0) = del)\/
(~In (id (ord (nth t I tau0))) (ids (tilln (orders I) (t-1))))\/
((id (ord (nth t I tau0))) = (id (ord (nth (t-1) I tau0)))/\
(cmd (nth (t-1) I tau0) = del)))
/\ Sorted (Nat.ltb) (timesof (orders I))/\ NoDup ((timesof (orders I))).

Fixpoint iterate (P: (list order)->(list order) -> instruction -> (list order)*(list order)*(list transaction))
(I : list instruction)(k:nat) :=
match k with
|0 => (nil, nil, nil)
| S k' =>  let it:=(iterate P I k') in P (Blist it) (Alist it)
    (nth k' I tau0)
end.

Definition iterated (P: (list order)->(list order) -> instruction -> (list order)*(list order)*(list transaction))
(I : list instruction)(k:nat) :=
if (Nat.ltb (length I) k) then (nil,nil,nil) else iterate P I k.

End Properties.


Lemma eq_sym : forall (X : Type)(x y : X), x = y -> y = x.
intros X x y A.
rewrite A.
reflexivity.
Qed.

Lemma modus_ponens : forall X Y : Prop, X -> (X -> Y) -> Y.
intros X Y x A.
exact (A x).
Qed.

Lemma barbara : forall X Y Z : Prop, (X -> Y) -> (Y -> Z) -> (X -> Z).
intros X Y Z A B x.
exact (B (A x)).
Qed.

Lemma eq_trans : forall (X : Type)(x y z : X), x = y -> y = z -> x = z.
intros.
transitivity y.
assumption.
apply H0.
Qed.

Lemma const : forall X Y, X -> Y -> X.
intros.
apply X0.
Qed.

Goal forall X Y, (forall Z, (X -> Y -> Z) ->
 Z) -> X.
intros X Y Z0.
apply Z0.
apply const.
Qed.

Lemma const' : forall X Y, X -> Y -> Y.
intros.
apply X1.
Qed.

Goal forall X Y, (forall Z, (X -> Y -> Z) -> Z) -> Y.
intros.
apply X0.
apply const'.
Qed.

Lemma leibniz_equality : forall (X : Type)(x y : X),(forall p : X -> Prop, p x -> p y) -> x = y.
intros.
apply (H (fun z => x = z)).
reflexivity.
Qed.

Goal forall X : Type, (fun x : X => x) = (fun y : X => y).
intros.
reflexivity.
Qed.

Goal forall X : Prop, X -> ~~X.
intros X x A.
exact (A x).
Qed.


From Coq Require Import Arith NArith Lia.
Require Import Nibble Instructions List2 Logic2.

(** This is N(i, w) defined in (141), quite close to the paper. *)
Definition paper_next_valid_instruction_position (i: N) (b: byte)
:= let push1  := N_of_byte (byte_of_instruction (PUSH  1 eq_refl)) in
   let push32 := N_of_byte (byte_of_instruction (PUSH 32 eq_refl)) in
   let w := N_of_byte b in
   (if ((push1 <=? w)  &&  (w <=? push32))%bool
     then i + w - push1 + 2
     else i + 1)%N.

(** This is a nicer equivalent of the previous function. *)
Definition next_valid_instruction_position (i: N) (b: byte)
:= (i + match instruction_of_byte b with
        | Some (PUSH n _) => n + 1
        | _               => 1
        end)%N.

Lemma next_valid_instruction_position_ok (i: N) (b: byte):
  next_valid_instruction_position i b = paper_next_valid_instruction_position i b.
Proof.
unfold paper_next_valid_instruction_position.
match goal with
|- _ = if ?cond then (i + ?a - ?b + ?c)%N else (i + 1)%N =>
    replace (if cond then (i + a - b + c)%N else (i + 1)%N)
      with  (i + if cond then a - b + c else 1)%N
end.
2:{
  remember (andb _ _) as cond. destruct cond.
  repeat (rewrite N.add_sub_assoc || rewrite N.add_assoc). 1-3: trivial.
  symmetry in Heqcond.
  apply Bool.andb_true_iff in Heqcond.
  apply N.leb_le. tauto.
}
unfold next_valid_instruction_position.
f_equal.
(* this is stupid, we need an is_push test *)
destruct b as (b7, b6, b5, b4, b3, b2, b1, b0).
destruct b7; destruct b6; destruct b5; destruct b4;
destruct b3; destruct b2; destruct b1; destruct b0; trivial.
Qed.

Lemma next_valid_instruction_position_bound (i: N) (b: byte):
  (i + 1 <= next_valid_instruction_position i b)%N.
Proof.
unfold next_valid_instruction_position.
destruct (instruction_of_byte b) as [op|]; try destruct op; try apply N.le_refl.
lia.
Qed.

(**
   This is as close to D_J(c, i) defined in (140) as feasible,
   however, fuel had to be introduced to satisfy Coq's termination check.
 *)
Fixpoint paper_valid_jump_destinations_from (code: list byte)
                                             (i: N)
                                             (fuel: nat)
: list N
:= match fuel with
   | O => nil
   | S remaining_fuel =>
      match List.nth_error code (N.to_nat i) with
      | None => nil
      | Some b =>
         let tail := paper_valid_jump_destinations_from
                       code
                       (next_valid_instruction_position i b)
                       remaining_fuel
         in if (N_of_byte b =? N_of_byte (byte_of_instruction JUMPDEST))%N
                then i :: tail
                else tail
      end
   end.

Local Lemma valid_jump_destinations_from_2_helper
                (code: list byte)
                (i: N)
                (b: byte)
                (code_tail: list byte)
                (ok: code_tail = List.skipn (N.to_nat i) code):
  let next := next_valid_instruction_position i b in
  List.skipn (N.to_nat (next - i)) code_tail = List.skipn (N.to_nat next) code.
Proof.
subst. intro. unfold next_valid_instruction_position in next.
rewrite skipn_skipn.
f_equal. subst next.
rewrite N.add_comm.
rewrite<- N.add_sub_assoc by apply N.le_refl.
rewrite N.sub_diag.
rewrite N.add_0_r.
symmetry. apply N2Nat.inj_add.
Qed.

(* This version carries around the code tail so that it doesn't have to count from the start. *)
Local Fixpoint valid_jump_destinations_from_2 (code: list byte)
                                                (i: N)
                                                (fuel: nat)
                                                (code_tail: list byte)
                                                (ok: code_tail = List.skipn (N.to_nat i) code)
: list N
:= match fuel with
   | O => nil
   | S remaining_fuel =>
      match List.hd_error code_tail with
      | None => nil
      | Some b =>
         let next := next_valid_instruction_position i b in
         let tail := valid_jump_destinations_from_2
                       code
                       next
                       remaining_fuel
                       (List.skipn (N.to_nat (next - i)) code_tail)
                       (valid_jump_destinations_from_2_helper code i b code_tail ok)
         in if (N_of_byte b =? N_of_byte (byte_of_instruction JUMPDEST))%N
                then (i :: tail)%list
                else tail
      end
   end.

Local Lemma valid_jump_destinations_from_2_ok (code: list byte)
                                                (i: N)
                                                (fuel: nat)
                                                (code_tail: list byte)
                                                (ok: code_tail = List.skipn (N.to_nat i) code):
  paper_valid_jump_destinations_from code i fuel
   =
  valid_jump_destinations_from_2 code i fuel code_tail ok.
Proof.
revert ok. revert code_tail. revert i code.
induction fuel. { easy. }
intros. cbn.
subst code_tail. rewrite<- List2.nth_hd_skipn.
destruct (List.nth_error code (N.to_nat i)). 2:{ trivial. }
destruct (N_of_byte b =? _)%N; now rewrite<- IHfuel.
Qed.

(* This version replaces hd_error with a match and also drops [code] and [ok] parameters. *)
Local Fixpoint valid_jump_destinations_from_3 (code_tail: list byte)
                                                (i: N)
                                                (fuel: nat)
: list N
:= match fuel with
   | O => nil
   | S remaining_fuel =>
      match code_tail with
      | nil => nil
      | (b :: _)%list =>
         let next := next_valid_instruction_position i b in
         let tail := valid_jump_destinations_from_3
                       (List.skipn (N.to_nat (next - i)) code_tail)
                       next
                       remaining_fuel
         in if (N_of_byte b =? N_of_byte (byte_of_instruction JUMPDEST))%N
                then (i :: tail)%list
                else tail
      end
   end.

Local Lemma valid_jump_destinations_from_3_ok (code: list byte)
                                               (i: N)
                                               (fuel: nat)
                                               (code_tail: list byte)
                                               (ok: code_tail = List.skipn (N.to_nat i) code):
  valid_jump_destinations_from_3 code_tail i fuel
   =
  valid_jump_destinations_from_2 code i fuel code_tail ok.
Proof.
revert code i code_tail ok.
induction fuel. { easy. }
intros. cbn.
destruct code_tail; cbn. { trivial. }
destruct (N_of_byte b =? _)%N; now rewrite<- IHfuel.
Qed.

(* This version gets rid of the fuel and does skipping by itself. *)
Local Fixpoint valid_jump_destinations_from_4 (code: list byte) (current: N) (next_valid: N)
: list N
:= match code with
   | nil => nil
   | (h :: t)%list =>
        if (current <? next_valid)%N
           then valid_jump_destinations_from_4 t (current + 1)%N next_valid
           else
             let tail := valid_jump_destinations_from_4 t
                                                        (current + 1)%N
                                                        (next_valid_instruction_position current h)
             in if (N_of_byte h =? N_of_byte (byte_of_instruction JUMPDEST))%N
                  then (current :: tail)%list
                  else tail
  end.

Local Lemma valid_jump_destinations_from_4_skips (code: list byte) (current: N) (next_valid: N)
                                                  (ok: (current <= next_valid)%N):
  valid_jump_destinations_from_4 code current next_valid
   =
  valid_jump_destinations_from_4 (List.skipn (N.to_nat (next_valid - current)) code)
                                 next_valid
                                 next_valid.
Proof.
remember (N.to_nat (next_valid - current)) as k.
assert(K: next_valid = (current + N.of_nat k)%N) by lia.
clear Heqk ok. subst next_valid.
revert code current.
induction k; intros. { cbn. now repeat rewrite N.add_0_r. }
destruct code; cbn. { trivial. }
replace (current <? current + N.pos (Pos.of_succ_nat k))%N with true.
2:{
  symmetry.
  apply N.ltb_lt.
  lia.
}
replace (current + N.pos (Pos.of_succ_nat k))%N with (current + 1 + N.of_nat k)%N by lia.
apply IHk.
Qed.

Local Lemma valid_jump_destinations_from_4_ok (code: list byte)
                                               (i: N)
                                               (fuel: nat)
                                               (EnoughFuel: (length code < fuel)%nat):
  valid_jump_destinations_from_4 code i i
   =
  valid_jump_destinations_from_3 code i fuel.
Proof.
revert code EnoughFuel i.
induction fuel; intros. { now apply Nat.nlt_0_r in EnoughFuel. }
cbn. destruct code. { easy. }
cbn.
replace (i <? i)%N with false.
2:{ symmetry. apply (b_false (N.ltb_lt _ _)). apply N.lt_irrefl. }
replace (valid_jump_destinations_from_4 code (i + 1) (next_valid_instruction_position i b))
  with (valid_jump_destinations_from_3
        (List.skipn (N.to_nat (next_valid_instruction_position i b - i)) (b :: code))
        (next_valid_instruction_position i b) fuel).
{ trivial. }
assert (B := next_valid_instruction_position_bound i b).
rewrite valid_jump_destinations_from_4_skips by assumption.
symmetry. rewrite IHfuel.
{
  replace (N.to_nat (next_valid_instruction_position i b - i))
     with (S ((N.to_nat (next_valid_instruction_position i b - (i + 1))))) by lia.
  now rewrite List.skipn_cons.
}
rewrite List.skipn_length.
cbn in EnoughFuel.
lia.
Qed.


Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import Lia.
Require Import EquivDec.
From sflib Require Import sflib.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.Order.

Set Implicit Arguments.

Module Time.
  Include Nat.

  Definition pred_opt (ts:t): option t :=
    match ts with
    | O => None
    | S n => Some n
    end.

  (* Definition le (a b:t) := a <= b. *)
  Definition join (a b:t) := max a b.
  Definition bot: t := 0.

  Global Program Instance order: orderC join bot.
  Next Obligation. unfold join. lia. Qed.
  Next Obligation. unfold join. lia. Qed.
  Next Obligation. eauto using Max.max_assoc. Qed.
  Next Obligation. eauto using Max.max_comm. Qed.
  Next Obligation. unfold join. lia. Qed.
  Next Obligation. unfold bot. lia. Qed.

  Global Instance eqdec: EqDec t eq := nat_eq_eqdec.
End Time.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_onray_shared_initial_point.
Require Import ProofCheckingEuclid.lemma_s_conga.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_equalangleshelper :
	forall A B C a b c p q,
	CongA A B C a b c ->
	OnRay b a p ->
	OnRay b c q ->
	CongA A B C p b q.
Proof.
	intros A B C a b c p q.
	intros CongA_ABC_abc.
	intros OnRay_ba_p.
	intros OnRay_bc_q.

	destruct CongA_ABC_abc as (U & V & u & v & OnRay_BA_U & OnRay_BC_V & OnRay_ba_u & OnRay_bc_v & Cong_BU_bu & Cong_BV_bv & Cong_UV_uv & nCol_A_B_C).

	pose proof (lemma_onray_shared_initial_point _ _ _ _ OnRay_ba_p OnRay_ba_u) as OnRay_bp_u.
	pose proof (lemma_onray_shared_initial_point _ _ _ _ OnRay_bc_q OnRay_bc_v) as OnRay_bq_v.

	pose proof (
		lemma_s_conga
		A B C p b q
		_ _ _ _
		OnRay_BA_U
		OnRay_BC_V
		OnRay_bp_u
		OnRay_bq_v
		Cong_BU_bu
		Cong_BV_bv
		Cong_UV_uv
		nCol_A_B_C
	) as CongA_ABC_pbq.

	exact CongA_ABC_pbq.
Qed.

End Euclid.


Require Import Ensembles Relations.
Set Implicit Arguments.
Implicit Arguments In [U].

Definition var := nat.
Inductive formula : Set :=
| Atom : var -> formula
| Bot : formula
| And : formula -> formula -> formula
| Or : formula -> formula -> formula
| Imp : formula -> formula -> formula.
Infix "'->" := Imp (at level 70, right associativity).
Infix "'\/" := Or (at level 60).
Infix "'/\" := And (at level 50).
Coercion Atom : var >-> formula.

Inductive provable : Ensemble formula -> formula -> Prop :=
| By_axiom : forall fs f, In fs f -> provable fs f
| By_K : forall fs f g, provable fs (f '-> g '-> f)
| By_S : forall fs f g h,
  provable fs ((f '-> g '-> h) '-> (f '-> g) '-> (f '-> h))
| By_proj1 : forall fs f g, provable fs (f '/\ g '-> f)
| By_proj2 : forall fs f g, provable fs (f '/\ g '-> g)
| By_conj : forall fs f g, provable fs (f '-> g '-> f '/\ g)
| By_in1 : forall fs f g, provable fs (f '-> f '\/ g)
| By_in2 : forall fs f g, provable fs (g '-> f '\/ g)
| By_case : forall fs f g h,
  provable fs ((f '-> h) '-> (g '-> h) '-> (f '\/ g '-> h))
| By_exfalso : forall fs f, provable fs (Bot '-> f)
| By_MP : forall fs f g,
  provable fs (f '-> g) -> provable fs f -> provable fs g.

Hint Constructors provable.

Module Type KRIPKE_MODEL.
  Parameter W : Type.
  Parameter R : relation W.
  Axiom R_refl : reflexive _ R.
  Axiom R_trans : transitive _ R.
  Parameter V : W -> var -> Prop.
  Axiom monotone : forall x y p, V x p -> R x y -> V y p.
End KRIPKE_MODEL.

Module Kripke_Semantics (K : KRIPKE_MODEL).
  Export K.

  Fixpoint satisfies x f :=
    match f with
      | Atom p => V x p
      | Bot => False
      | And f f' => satisfies x f /\ satisfies x f'
      | Or f f' => satisfies x f \/ satisfies x f'
      | Imp f f' => forall y, R x y -> satisfies y f -> satisfies y f'
    end.

  Hint Resolve R_refl R_trans monotone.
  Lemma hereditary : forall x y f,
    satisfies x f -> R x y -> satisfies y f.
    induction f; simpl; intuition eauto.
  Qed.

  Theorem soundness : forall fs f x,
    provable fs f -> (forall g, In fs g -> satisfies x g) -> satisfies x f.
    induction 1; simpl; intuition; eauto using hereditary.
  Qed.
End Kripke_Semantics.

Lemma deduction_theorem' : forall fs fs' f g,
  provable fs' g -> fs' = Add _ fs f -> provable fs (f '-> g).
  induction 1; intro; subst; [| eauto ..].
  inversion H; try inversion H0; subst; eauto.
  Existential 1 := Bot.
  Existential 1 := Bot.
  Existential 1 := Bot.
Qed.

Lemma deduction_theorem : forall fs f g,
  provable (Add _ fs f) g -> provable fs (f '-> g).
  eauto using deduction_theorem'.
Qed.

Lemma weakening : forall fs f g, provable fs f -> provable (Add _ fs g) f.
  induction 1; solve [repeat constructor; auto | eauto].
Qed.

Hint Constructors Union Singleton.
Hint Extern 1 (provable (Add _ _ _) _) => unfold Add.

Lemma converse_deduction_theorem :
  forall fs f g, provable fs (f '-> g) -> provable (Add _ fs f) g.
  intros; apply (@By_MP _ f g); auto using weakening.
Qed.

Module Canonical_Model <: KRIPKE_MODEL.
  Definition prime fs :=
    forall f g, provable fs (f '\/ g) -> provable fs f \/ provable fs g.
  Definition consistent fs := ~provable fs Bot.

  Definition W := { T : Ensemble formula | prime T /\ consistent T }.

  Definition R (x y : W) :=
    forall f, provable (proj1_sig x) f -> provable (proj1_sig y) f.
  Hint Unfold R Included.
  Lemma R_refl : forall x, R x x.
    auto.
  Qed.
  Lemma R_trans : forall x y z, R x y -> R y z -> R x z.
    auto.
  Qed.
  Definition V (x : W) (p : var) := provable (proj1_sig x) p.
  Hint Unfold V.
  Lemma monotone : forall x y p, V x p -> R x y -> V y p.
    intuition.
  Qed.
End Canonical_Model.

Module Canonical_Model_facts.
  Module M := Kripke_Semantics Canonical_Model.

  Import M.

  Hint Unfold R.

  Axiom prime_lemma : forall fs f,
    (forall x : W, (forall g, provable fs g -> provable (proj1_sig x) g) ->
      provable (proj1_sig x) f) ->
    provable fs f.

  Ltac destruct_iff :=
    match goal with
      [ H : forall _, _ <-> _ |- _] =>
      pose proof (fun x => proj1 (H x));
        pose proof (fun x => proj2 (H x));
          clear H
    end.

  Lemma equivalence : forall f x, provable (proj1_sig x) f <-> satisfies x f.
    induction f;
      intro x; destruct x as [T [? ?]];
        simpl in *; intuition;
          repeat destruct_iff; eauto 3.

    assert (provable T f1 /\ provable T f2) by firstorder.
    intuition; eauto.

    assert (provable T f1 \/ provable T f2) by auto; intuition.

    assert (provable T f1) by firstorder.
    eauto.

    assert (provable T f2) by firstorder.
    eauto.

    eauto.

    apply deduction_theorem.
    apply prime_lemma.
    auto 8 using weakening.
  Qed.

  Hint Resolve (fun f x => proj1 (equivalence f x)).
  Hint Resolve (fun f x => proj2 (equivalence f x)).

  Theorem completeness : forall fs f,
    (forall T, (forall g, In fs g -> satisfies T g) -> satisfies T f) ->
    provable fs f.
    auto 7 using prime_lemma.
  Qed.
End Canonical_Model_facts.


Require Export Iron.Language.SystemF2Cap.Type.Exp.
Require Export Iron.Language.SystemF2Cap.Type.Relation.WfT.
Require Export Iron.Language.SystemF2Cap.Type.Relation.FreeT.

(*******************************************************************)
(* Lift type indices that are at least a certain depth. *)
Fixpoint liftTT (n: nat) (d: nat) (tt: ty) : ty :=
 match tt with
 |  TVar ix
 => match nat_compare ix d with
    | Lt => tt
    | _  => TVar (ix + n)
    end

 |  TForall k t    => TForall k (liftTT n (S d) t)
 |  TApp t1 t2     => TApp      (liftTT n d t1) (liftTT n d t2)
 |  TSum t1 t2     => TSum      (liftTT n d t1) (liftTT n d t2)
 |  TBot k         => TBot  k

 |  TCon0 tc       => TCon0 tc
 |  TCon1 tc t1    => TCon1 tc  (liftTT n d t1)
 |  TCon2 tc t1 t2 => TCon2 tc  (liftTT n d t1) (liftTT n d t2)
 |  TCap  _        => tt
 end.
Hint Unfold liftTT.

(********************************************************************)
Lemma liftTT_TVar_exists
 : forall n d n1
 , exists n2, liftTT n d (TVar n1) = liftTT n d (TVar n2).
Proof.
 intros.
 unfold liftTT. exists n1. snorm.
Qed.

Lemma liftTT_TVar_not_zero
 : forall t
 , liftTT 1 0 t <> TVar 0.
Proof.
 intros.
 destruct t;
  try (solve [unfold not; snorm; inverts H; omega]);
  try (solve [unfold not; snorm; nope]).
Qed.
Hint Resolve liftTT_TVar_not_zero.

Lemma liftTT_TVar_not_succ
 : forall t d
 ,             t <> TVar d
 -> liftTT 1 0 t <> TVar (S d).
Proof.
 intros. gen d.
 destruct t; intros;
   try (solve [simpl; congruence]).

 - Case "TVar".
   unfold liftTT.
   snorm.
   + subst. congruence.
   + unfold not. intros.
     inverts H0. omega.
   + congruence.
Qed.
Hint Resolve liftTT_TVar_not_succ.

Lemma liftTT_TVar_above
 :  forall n i d
 ,  d > i
 -> liftTT n d (TVar i) = TVar i.
Proof.
 snorm; omega.
Qed.
Hint Resolve liftTT_TVar_above.

Lemma liftTT_isTVar_true
 :  forall n i t d
 ,  d > i
 -> IsTVar i (liftTT n d t)
 -> IsTVar i t.
Proof.
 intros.
  destruct t;
   try (solve [simpl; auto]).

 - Case "TVar".
   apply isTVar_form in H0.
   snorm; inverts H0; unfold IsTVar; snorm;
    rewrite beq_nat_true_iff; omega.
Qed.
Hint Resolve liftTT_isTVar_true.

Lemma liftTT_TCap
 :  forall n d t tc
 ,  liftTT n d t = TCap tc
 -> t            = TCap tc.
Proof.
 intros.
 destruct t; simpl in *; nope.
  snorm; nope.
Qed.

Lemma liftTT_wfT
 :  forall kn t d
 ,  WfT kn t
 -> WfT (S kn) (liftTT 1 d t).
Proof.
 intros. gen kn d.
 induction t; intros; inverts H; snorm.
Qed.
Hint Resolve liftTT_wfT.

Lemma liftTT_zero
 :  forall d t
 ,  liftTT 0 d t = t.
Proof.
 intros. gen d. lift_burn t.
Qed.
Hint Resolve liftTT_zero.
Hint Rewrite liftTT_zero : global.

Lemma liftTT_comm
 :  forall n m d t
 ,  liftTT n d (liftTT m d t)
 =  liftTT m d (liftTT n d t).
Proof.
 intros. gen d. lift_burn t.
Qed.
Hint Resolve liftTT_comm.

Lemma liftTT_succ
 :  forall n m d t
 ,  liftTT (S n) d (liftTT m     d t)
 =  liftTT n     d (liftTT (S m) d t).
Proof.
 intros. gen d m n. lift_burn t.
Qed.
Hint Resolve liftTT_succ.
Hint Rewrite liftTT_succ : global.

Lemma liftTT_plus
 : forall n m d t
 , liftTT (n + m) d t
 = liftTT n d (liftTT m d t).
Proof.
 intros. gen n d.
 induction m; intros.
 - rewrite liftTT_zero; burn.
 - rrwrite (n + S m = S n + m).
   rewrite IHm.
   rewrite liftTT_succ.
   auto.
Qed.
Hint Resolve liftTT_plus.
Hint Rewrite liftTT_plus : global.

Lemma liftTT_wfT_1
 :  forall t n ix
 ,  WfT n t
 -> liftTT 1 (n + ix) t = t.
Proof.
 intros. gen n ix.
 induction t; intros; inverts H; burn;
  try (solve [snorm; rewritess; burn]).

 - Case "TForall".
   snorm. f_equal.
   spec IHt H1.
   rrwrite (S (n + ix) = S n + ix).
   burn.
Qed.
Hint Resolve liftTT_wfT_1.

Lemma liftTT_closedT_id_1
 :  forall t d
 ,  ClosedT t
 -> liftTT 1 d t = t.
Proof.
 intros.
 rrwrite (d = d + 0). eauto.
Qed.
Hint Resolve liftTT_closedT_id_1.

Lemma liftTT_closedT_10
 :  forall t
 ,  ClosedT t
 -> ClosedT (liftTT 1 0 t).
Proof.
 intros.
 rrwrite (0 = 0 + 0).
 rewrite liftTT_wfT_1; auto.
Qed.
Hint Resolve liftTT_closedT_10.

(* Changing the order of lifting.
   We build this up in stages.
   Start out by only allow lifting by a single place for both
   applications. Then allow lifting by multiple places in the first
   application, then multiple places in both.
*)
Lemma liftTT_liftTT_11
 :  forall d d' t
 ,  liftTT 1 (1 + (d + d')) (liftTT 1 d t)
 =  liftTT 1 d              (liftTT 1 (d + d') t).
Proof.
 intros. gen d d'.
 induction t; intros.

 - Case "TVar".
   repeat (lift_cases; unfold liftTT); try f_equal; try omega; burn.

 - Case "TForall".
   snorm.
   rrwrite (S (d + d') = (S d) + d').
   rewritess. snorm.

 - Case "TApp".
   snorm; rewritess; auto.

 - Case "TCon".
   snorm; rewritess; auto.

 - Case "TBot".
   snorm; rewritess; auto.

 - Case "TCon0".
   snorm; rewritess; auto.

 - Case "TCon1".
   snorm; rewritess; auto.

 - Case "TCon2".
   snorm; rewritess; auto.

 - Case "TCap".
   snorm; rewritess; auto.
Qed.

Lemma liftTT_liftTT_1
 :  forall n1 m1 n2 t
 ,  liftTT m1   n1 (liftTT 1 (n2 + n1) t)
 =  liftTT 1 (m1 + n2 + n1) (liftTT m1 n1 t).
Proof.
 intros. gen n1 m1 n2 t.
 induction m1; intros; simpl.
  burn.

  rrwrite (S m1 = 1 + m1).
  rewrite liftTT_plus.
  rewritess.
  rrwrite (m1 + n2 + n1 = n1 + (m1 + n2)) by omega.
  rewrite <- liftTT_liftTT_11.
  burn.
Qed.

Lemma liftTT_liftTT
 :  forall m1 n1 m2 n2 t
 ,  liftTT m2 (m1 + n2 + n1) (liftTT m1 n1 t)
 =  liftTT m1 n1 (liftTT m2 (n2 + n1) t).
Proof.
 intros. gen n1 m1 n2 t.
 induction m2; intros.
  burn.
  rrwrite (S m2 = 1 + m2).
  rewrite liftTT_plus.
  rewrite IHm2.
  rewrite <- liftTT_liftTT_1.
  burn.
Qed.
Hint Rewrite liftTT_liftTT : global.

Lemma liftTT_liftTT_Sd
 : forall n d t
 , liftTT n (S d) (liftTT 1 0 t)
 = liftTT 1 0     (liftTT n d t).
Proof.
 intros.
 lets D: liftTT_liftTT 1 0 n d t.
 simpl in D.
 rrwrite (d + 0 = d) in D.
 auto.
Qed.
Hint Rewrite liftTT_liftTT_Sd : global.

Lemma liftTT_map_liftTT
 :  forall m1 n1 m2 n2 ts
 ,  map (liftTT m1 n1) (map (liftTT m2 (n2 + n1)) ts)
 =  map (liftTT m2 (m1 + n2 + n1)) (map (liftTT m1 n1) ts).
Proof.
 induction ts; simpl; f_equal; norm; auto.
Qed.

Lemma liftTT_freeT
 : forall d t
 , ~(FreeT d (liftTT 1 d t)).
Proof.
 intros. gen d.
 induction t; snorm; firstorder.
Qed.
Hint Resolve liftTT_freeT.


Require Import Arith.
Require Import Program.
Require Import Compare_dec.

Set Implicit Arguments.

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

Inductive variable : nat -> Set :=
| var : forall g i, i < g -> variable g.

Inductive type : nat -> Set :=
| ty_var    : forall g, variable g -> type g
| ty_arr    : forall g, type g -> type g -> type g
| ty_forall : forall g, type (S g) -> type g.

Definition shift_var : forall g c,
  variable (c + g) -> variable (c + 1 + g).
intros g c v. inversion v. subst.
destruct (le_lt_dec c i).
 apply var with (i:=S i). rewrite (plus_comm c 1). simpl. apply lt_n_S. assumption.
 apply var with (i:=i). rewrite <- plus_assoc. simpl. rewrite <- plus_Snm_nSm. apply le_S. assumption.
Defined.

Definition shift (g : nat) (c : nat) :
  type (c + g) -> type (c + 1 + g).
intros.
set (g':=c+g) in *. set (e:=refl_equal g' : g' = c+g). generalize g' H c e. clear g' H c e. intros g' H.
induction H; intros; subst.
 (* ty_var *)
 apply ty_var. apply shift_var. apply v.
 (* ty_arr *)
 apply ty_arr.
  apply IHtype1. reflexivity.
  apply IHtype2. reflexivity.
 (* ty_forall *)
 apply ty_forall.
  change (S (c + 1 + g)) with ((S c) + 1 + g).
  apply IHtype. reflexivity.
Defined.

Definition shift1 : forall g, type g -> type (S g).
intros.
change (S g) with (0 + 1 + g).
apply shift with (c:=0). apply H.
Defined.

Definition subst_var (g c d : nat) (v : variable d) :
 d = c + 1 + g ->
 type (c + g) -> type (c + g).
intros. destruct v. subst.
destruct (lt_eq_lt_dec i c) as [[X|X]|X].
 apply ty_var. apply var with (i:=i). apply lt_plus_trans. assumption.
 apply H0.
 destruct (O_or_S i) as [[i' i_eq_Si'] | i_eq_0].
  apply ty_var. apply var with (i:=i'). subst. rewrite (plus_comm c 1) in l. simpl in l. apply lt_S_n. assumption.
  elimtype False. subst. inversion X.
Defined.

Definition subst (g : nat) (c : nat) :
  type (c + g) ->
  type (c + 1 + g) ->
  type (c + g).
intros. dependent induction H0.
 (* ty_var *)
 apply subst_var with (d:=c + 1 + g). assumption. reflexivity. assumption.
 (* ty_arr *)
 apply ty_arr.
  apply IHtype1. apply H.
  apply IHtype2. apply H.
 (* ty_forall *)
 apply ty_forall.
 apply IHtype with (c0:=S c). apply shift1. apply H. reflexivity.
Defined.

Definition type_subst1 : forall g, type (S g) -> type g -> type g.
intros.
change g with (0 + g).
apply subst. apply H0. apply H.
Defined.


Section MinimalPropositionalLogic.

Axiom P : Prop.
Axiom Q : Prop.
Axiom R : Prop.
Axiom T : Prop.

Theorem ImplicationsAreTransitive : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intro H0.
  intro H1.
  intro p.
  apply H1.
  apply H0.
  assumption.
Qed.

Section AssumptionExample.

Hypothesis H : P -> Q -> R.

Lemma L1 : P -> Q -> R.
Proof.
  assumption.
Qed.

End AssumptionExample.

Theorem ApplyExample : (Q -> R -> T) -> (P -> Q) -> P -> R -> T.
Proof.
  intros H1 H2 p.
  apply H1.
  exact (H2 p).
Qed.

(*
Theorem ImplicationIsDistributive : (forall A B C : Prop, (A -> (A -> B -> C) -> (A -> B) -> (B -> C))).
Proof.
  intro A.
  intro B.
  intro C.
  intro a.
  intro H1.
  intro H2.
  intro H3.
  apply H1.
  assumption.
  apply H3.
Qed.

*)

Theorem ImplicationIsDistributive : ((P -> Q -> R) -> (P -> Q) -> (P -> R)).
Proof.
  intros H1 H2 p.
  apply H1.
  assumption.
  exact (H2 p).
Qed.

Section ExamplesCh3Section3.

Lemma Identity : (P -> P).
Proof.
  intro p.
  exact p.
Qed.

Lemma IdentityImplication : ((P -> P) -> (P -> P)).
Proof.
  intro H0.
  exact H0.
Qed.

Lemma ImplicationIsTransitive : ((P -> Q) -> (Q -> R) -> P -> R).
Proof.
  intro H1.
  intro H2.
  intro p.
  apply H2.
  exact (H1 p).
Qed.

Lemma ImplicationPer : ((P -> Q -> R) -> (Q -> P -> R)).
Proof.
  intro H1.
  intro H2.
  intro p.
  apply H1.
  - assumption.
  - apply H2.
Qed.

Lemma IgnoreQ : ((P -> R) -> P -> Q -> R).
Proof.
  intro H1.
  intro H2.
  intro H3.
  apply H1.
  apply H2.
Qed.

Lemma DeltaImplication : ((P -> Q) -> (P -> P -> Q)).
Proof.
  intro H1.
  intro H2.
  intro H3.
  apply H1.
  apply H2.
Qed.

Lemma DeltaImplicationReverse : ((P -> P -> Q) -> P -> Q).
Proof.
  intro H1.
  intro H2.
  apply H1.
  assumption.
  assumption.
Qed.

Lemma Diamond : ((P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T).
Proof.
  intro H1.
  intro H2.
  intro H3.
  intro H4.
  apply H3.
  apply H1.
  apply H4.
  apply H2.
  assumption.
Qed.

Lemma WeakPeirce : (((((P -> Q) -> P) -> P) -> Q) -> Q).
Proof.
  intro H1.
  apply H1.
  intro H2.
  apply H2.
  intro H3.
  apply H1.
  intro H4.
  assumption.
Qed.

End ExamplesCh3Section3.

Theorem ModusPonens : ((P -> Q) -> P -> Q).
Proof.
  intros.
  rename H into H1.
  apply H1.
  assumption.
Qed.

(* TODO: Complete
Theorem ModusTollens : ((P -> Q) -> ~Q -> ~P).
Proof.
  intros.
*)

Section ProofOfTripleImplication.

Hypothesis H : (((P -> Q) -> Q) -> Q).
Hypothesis p : P.

Lemma Rem : ((P -> Q) -> Q).
Proof (fun H0: (P -> Q) => H0 p).

Theorem TripleImplication : Q.
Proof (H Rem).

End ProofOfTripleImplication.

Print TripleImplication.

Print Rem.

Theorem ThenExample : (P -> Q -> (P -> Q -> R) -> R).
Proof.
  intros p q H1.
  apply H1; assumption.
Qed.

Theorem TripleImplicationOneShot : ((((P -> Q) -> Q) -> Q) -> P -> Q).
Proof.
  intros H p; apply H; intro H0; apply H0; assumption.
Qed.

Theorem ComposeExample : ((P -> Q -> R) -> (P -> Q) -> (P -> R)).
Proof.
  intros H1 H2 p.
  apply H1; [assumption | apply H2; assumption].
Qed.

Lemma L3 : ((P -> Q) -> (P -> R) -> (P -> Q -> R -> T) -> P -> T).
Proof.
  intros H1 H2 H3 p.
  apply H3; [idtac | apply H1 | apply H2]; assumption.
Qed.

Theorem ThenFailExample : ((P -> Q) -> (P -> Q)).
Proof.
  intro H; apply H; fail.
Qed.

Section SectionForCutExample.

Hypothesis (H1 : P -> Q)
           (H2 : Q -> R)
           (H3 : (P -> R) -> T -> Q)
           (H4 : (P -> R) -> T).

Theorem CutExample : Q.
Proof.
  cut (P -> R).
  intro H5.
  apply H3.
  assumption.
  apply H4; assumption.
  intro H6.
  apply H2.
  apply H1.
  assumption.
Qed.

Print CutExample.

Theorem CutWithoutCutExample : Q.
Proof.
  apply H3.
  intro H5.
  apply H2.
  apply H1.
  assumption.
  apply H4.
  intro H5.
  apply H2.
  apply H1.
  assumption.
Qed.

End SectionForCutExample.

End MinimalPropositionalLogic.

Print ImplicationIsDistributive.

Section UsingImplicationIsDistributive.

Variables (P1 P2 P3 : Prop).

(* Not working

Check (ImplicationIsDistributive P1 P2 P3).

*)

Theorem Exercise5P5 : (forall A B C D : Set, A = C \/ B = C \/ C = C \/ D = C).
Proof.
  intro A.
  intro B.
  intro C.
  intro D.
  right.
  right.
  left.
  reflexivity.
Qed.

Theorem ModusTollens : (forall P Q : Prop, (P -> Q) -> ~Q -> ~P).
Proof.
  intro P.
  intro Q.
  intro H.
  unfold not.
  apply (ImplicationTransitivity).
  exact (H).
Qed.


Require Import Coq.Reals.Reals.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Reals.ROrderedType.
Require Import Lists.List.
Import ListNotations.
Open Scope R_scope.

From HYDLA Require Export Partial.

Definition Inf := None : option R.

(* see https://coq.inria.fr/library/Coq.Reals.ROrderedType.html#Reqb *)
Definition Rleb r1 r2 := if Rle_dec r1 r2 then true else false.
Definition Rltb r1 r2 := if Rlt_dec r1 r2 then true else false.
Definition Rgeb r1 r2 := if Rge_dec r1 r2 then true else false.
Definition Rgtb r1 r2 := if Rgt_dec r1 r2 then true else false.
Example test_Rleb1: forall r1 r2 : R, r1 <= r2 <-> Rleb r1 r2 = true.
Proof.
  intros.
  split.
  - intros.
    unfold Rleb.
    destruct (Rle_dec r1 r2).
    + trivial.
    + apply Rnot_le_gt in n.
      apply Rgt_lt in n.
      apply Rle_lt_trans with (r3:=r1) in H.
      * apply Rlt_irrefl in H.
        inversion H.
      * trivial.
  - unfold Rleb.
    destruct (Rle_dec r1 r2).
    + trivial.
    + intros.
      discriminate H. Qed.
Example test_Rleb2: forall r1 r2 : R, r1 > r2 <-> Rleb r1 r2 = false.
Proof.
  intros.
  split.
  - intros.
    unfold Rleb.
    destruct (Rle_dec r1 r2).
    + apply Rgt_lt in H.
      apply Rle_lt_trans with (r3:=r1) in r.
      * apply Rlt_irrefl in r.
        inversion r.
      * trivial.
    + trivial.
  - unfold Rleb.
    destruct (Rle_dec r1 r2).
    + intros.
      discriminate H.
    + intros.
      apply Rnot_le_lt in n.
      trivial. Qed.
Example test_Rltb1: forall r1 r2 : R, r1 < r2 <-> Rltb r1 r2 = true.
Proof.
  intros.
  split.
  - intros.
    unfold Rltb.
    destruct (Rlt_dec r1 r2).
    + trivial.
    + apply Rnot_lt_ge in n.
      apply Rge_le in n.
      apply Rlt_le_trans with (r3:=r1) in H.
      * apply Rlt_irrefl in H.
        inversion H.
      * trivial.
  - unfold Rltb.
    destruct (Rlt_dec r1 r2).
    + intros.
      trivial.
    + intros.
      discriminate H. Qed.
Example test_Rltb2: forall r1 r2 : R, r1 >= r2 <-> Rltb r1 r2 = false.
Proof.
  intros.
  split.
  - intros.
    unfold Rltb.
    destruct (Rlt_dec r1 r2).
    + apply Rge_le in H.
      apply Rlt_le_trans with(r3:=r1) in r.
      * apply Rlt_irrefl in r.
        inversion r.
      * trivial.
    + trivial.
  - intros.
    unfold Rltb in H.
    destruct (Rlt_dec r1 r2).
    + inversion H.
    + apply Rnot_lt_ge in n.
      trivial. Qed.
Example test_Reqb1: forall r1 r2 : R, r1 = r2 <-> Reqb r1 r2 = true.
Proof.
  intros.
  split.
  - intros.
    unfold Reqb.
    destruct (Req_dec r1 r2).
    + trivial.
    + rewrite H in n.
      apply Rdichotomy in n.
      generalize n.
      intros [A|B].
      * apply Rlt_irrefl in A.
        inversion A.
      * apply Rgt_irrefl in B.
        inversion B.
  - unfold Reqb.
    destruct (Req_dec r1 r2).
    + trivial.
    + intros.
      discriminate H. Qed.
Example test_Reqb2: forall r1 r2 : R, r1 <> r2 <-> Reqb r1 r2 = false.
Proof.
  intros.
  split.
  - intros.
    apply Rdichotomy in H.
    generalize H.
    intros [A|B].
    + unfold Reqb.
      destruct (Req_dec r1 r2).
      * rewrite e in A.
        apply Rlt_irrefl in A.
        inversion A.
      * trivial.
    + unfold Reqb.
      destruct (Req_dec r1 r2).
      * rewrite e in B.
        apply Rgt_irrefl in B.
        inversion B.
      * trivial.
  - unfold Reqb.
    destruct (Req_dec r1 r2).
    + intros.
      discriminate H.
    + trivial. Qed.

(* update value of m at x with v, i.e. m(x):=v *)
Definition update_pt (m : partial) (x : option R) (v : option R) :=
  fun y =>
    match x with
    | Some x' => if Reqb x' y then v else m y
    | None => m y
    end.
Notation "x '|-->' v ';' m" := (update_pt m x v)
  (at level 100, v at next level, right associativity).
Notation "x '|-->' v" := (update_pt empty x v)
  (at level 100).
Example test_update_pt1: (Some 0 |--> Some 10) 0 = Some 10.
Proof.
  simpl.
  destruct (Reqb 0 0) eqn:E.
  - trivial.
  - unfold Reqb in E.
    destruct (Req_dec 0 0).
    + discriminate E.
    + apply Rdichotomy in n.
      generalize n.
      intros [A|B].
      * apply Rlt_irrefl in A.
        inversion A.
      * apply Rgt_irrefl in B.
        inversion B. Qed.
Example test_update_pt2: (Some 0 |--> Some 10) 1 = None.
Proof.
  simpl.
  destruct (Reqb 0 1) eqn:E.
  - apply test_Reqb1 in E.
    apply eq01_False in E.
    destruct E.
  - unfold empty.
    trivial. Qed.

(* update m in open interval (begt, endt) by m' *)
Definition update_in (m : partial) (m' : partial) (begt : option R) (endt : option R) : partial :=
  fun x' =>
    match (begt, endt) with
    | (Some begt', Some endt') => if andb (Rltb begt' x') (Rltb x' endt') then m' x' else m x'
    | (Some begt', Inf) => if Rltb begt' x' then m' x' else m x'
    | (_, _) => m x'
    end.
Notation "n '|_(' begt ',' endt ')' ';' m" := (update_in m n begt endt)
  (at level 100, right associativity).
Notation "n '|_(' begt ',' endt ')'" := (update_in empty n begt endt)
  (at level 100).
Example test_update_in1: (fun x => Some x)|_(Some 0, Some 2) 1 = Some 1.
Proof.
  unfold update_in.
  simpl.
  destruct (Rltb 0 1) eqn:E1.
  - simpl.
    destruct (Rltb 1 2) eqn:E2.
    + trivial.
    + unfold Rltb in E2.
      destruct (Rlt_dec 1 2).
      * inversion E2.
      * apply Rnot_lt_le in n.
        apply le21_False in n.
        destruct n.
  - simpl.
    unfold Rltb in E1.
    destruct (Rlt_dec 0 1).
    + discriminate E1.
    + apply Rnot_lt_ge in n.
      apply Rge_le in n.
      apply le10_False in n.
      destruct n. Qed.
Example test_update_in2: (fun x => Some x)|_(Some 0, Some 2) 2 = None.
Proof.
  unfold update_in.
  unfold Rltb.
  destruct (Rlt_dec 2 2).
  - apply Rlt_irrefl in r.
    destruct r.
  - destruct (Rlt_dec 0 2).
    + unfold empty. reflexivity.
    + unfold empty. reflexivity. Qed.

Inductive phase : Type := pp (v : option R) | ip (m : partial) (begt : option R) (endt : option R).
Definition trajectory : Type := list phase.
(* the def of trajectory dosen't request alternation of PP and IP, *)
(* so validation might be needed *)

(* entry point is valid, not valid2 *)
Require Import Coq.funind.Recdef.
(* TODO: check continuity on ip *)
Function valid2 (tr : trajectory) {measure length tr} : Prop :=
  match tr with
  | [pp _; ip _ begt endt] => lt begt endt \/ endt = Inf
  | pp _ :: ip _ begt1 endt1 :: pp v2 :: ip m2 begt2 endt2 :: tr'
      => (lt begt1 endt1 \/ endt1 = Inf) /\ endt1 = begt2 /\ valid2 (pp v2 :: ip m2 begt2 endt2 :: tr')
  | _ => False
  end.
Proof.
  intros.
  simpl.
  repeat apply lt_n_S.
  apply lt_n_SSn. Qed.
Definition valid (tr : trajectory) : Prop :=
  match tr with
  | (pp v) :: (ip m (Some t) endt) :: tr' => t = 0 /\ valid2 tr
  | _ => False
  end.
Example test_valid1: valid [pp (Some 0) ; ip (fun x => Some x) (Some 0) Inf].
Proof.
  unfold valid.
  split.
  - trivial.
  - rewrite valid2_equation.
    right.
    trivial. Qed.
Example test_valid2:
  valid [pp (Some 0) ; ip (fun x => Some(2*x)) (Some 0) (Some 1) ; pp (Some 2) ; ip (fun x => Some x) (Some 1) Inf].
Proof.
  unfold valid.
  split.
  - trivial.
  - rewrite valid2_equation.
    split.
    + unfold lt.
      left.
      apply Rlt_0_1.
    + split.
      * trivial.
      * rewrite valid2_equation.
        right.
        trivial. Qed.
Example test_not_valid1: ~ valid [pp (Some 0) ; pp (Some 0)].
Proof.
  unfold valid.
  intro.
  destruct H. Qed.
Example test_not_valid2: ~ valid [pp (Some 0) ; ip (fun x => Some x) (Some 1) Inf].
Proof.
  unfold valid.
  intros [A B].
  symmetry in A.
  apply eq01_False in A.
  destruct A. Qed.
Example test_not_valid3: ~ valid [pp (Some 0) ; ip (fun x => Some x) (Some 0) (Some (-1))].
Proof.
  unfold valid.
  rewrite valid2_equation.
  unfold lt.
  intros [A B].
  destruct B.
  - apply Rlt_le_trans with (r3:=0) in H.
    + apply Rlt_irrefl in H.
      destruct H.
    + left.
      apply Rplus_lt_reg_l with (r:=1).
      rewrite Rplus_opp_r.
      rewrite Rplus_0_r.
      apply Rlt_0_1.
  - inversion H. Qed.
Example test_not_valid4: ~ valid [pp (Some 0) ; ip (fun x => Some x) (Some 0) (Some 1); pp (Some 0) ; ip (fun x => Some x) (Some 0) (Some 1)].
Proof.
  unfold valid.
  rewrite valid2_equation.
  intros [A [B [C D]]].
  - inversion C.
    symmetry in H0.
    apply eq01_False in H0.
    destruct H0. Qed.

(* convert trajectory to partial *)
Fixpoint tr2partial (tr : trajectory) : partial :=
  match tr with
  | [] => empty
  | (pp v) :: (ip m begt endt) :: tr' => (begt |--> v ; m|_(begt, endt) ; (tr2partial tr'))
  | _ => empty
  end.
Example test_tr2partial1: tr2partial [pp (Some 0) ; ip (fun x => Some x) (Some 0) Inf] 1 = Some 1.
Proof.
  unfold tr2partial.
  unfold update_pt.
  unfold update_in.
  unfold Inf.
  unfold Reqb.
  destruct (Req_dec 0 1).
  - apply eq01_False in e.
    destruct e.
  - unfold Rltb.
    destruct (Rlt_dec 0 1).
    + trivial.
    + apply Rnot_lt_le in n0.
      apply le10_False in n0.
      destruct n0. Qed.
Example test_tr2partial2: tr2partial [pp (Some 0) ; ip (fun x => Some x) (Some 0) Inf] (-1) = None.
Proof.
  unfold tr2partial.
  unfold update_pt.
  unfold update_in.
  unfold Inf.
  unfold Reqb.
  destruct (Req_dec 0 (-1)).
  - apply eq0m1_False in e.
    destruct e.
  - unfold Rltb.
    destruct (Rlt_dec 0 (-1)).
    + apply Rplus_lt_compat_r with (r:=1) in r.
      assert (0 + 1 = 1). { ring. } rewrite H in r.
      assert (-1 + 1 = 0). { ring. } rewrite H0 in r.
      apply Rlt_le in r.
      apply le10_False in r.
      destruct r.
    + unfold empty.
      trivial. Qed.