(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_A.

Coq < Goal forall m n h k l c d f g:Prop, (((~m /\ ~n) -> ((~m \/ h) -> (k /\ l))) /\ (~m /\ (c -> d)) /\ (~n /\ (f <-> g))) -> (k /\ ~n).
1 subgoal

  ============================
   forall m n h k l c d f g : Prop,
   (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
   (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g) -> k /\ ~ n

Unnamed_thm < intros.
1 subgoal

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  ============================
   k /\ ~ n

Unnamed_thm < elim H.
1 subgoal

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  ============================
   (~ m /\ ~ n -> ~ m \/ h -> k /\ l) ->
   (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g) -> k /\ ~ n

Unnamed_thm < intro.
1 subgoal

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  ============================
   (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g) -> k /\ ~ n

Unnamed_thm < intro.
1 subgoal

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  ============================
   k /\ ~ n

Unnamed_thm < decompose [and or] H.
1 subgoal

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  ============================
   k /\ ~ n

Unnamed_thm < split.
2 subgoals

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  ============================
   k

subgoal 2 is:
 ~ n

Unnamed_thm < 2:exact H4.
1 subgoal

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  ============================
   k

Unnamed_thm < decompose [and or] H0.
1 subgoal

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  ============================
   k

Unnamed_thm < elim H.
1 subgoal

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  ============================
   (~ m /\ ~ n -> ~ m \/ h -> k /\ l) ->
   (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g) -> k

Unnamed_thm < intro.
1 subgoal

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  H5 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  ============================
   (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g) -> k

Unnamed_thm < intro.
1 subgoal

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  H5 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H8 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  ============================
   k

Unnamed_thm < destruct H5.
3 subgoals

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  H8 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  ============================
   ~ m /\ ~ n

subgoal 2 is:
 ~ m \/ h
subgoal 3 is:
 k

Unnamed_thm < apply conj.
4 subgoals

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  H8 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  ============================
   ~ m

subgoal 2 is:
 ~ n
subgoal 3 is:
 ~ m \/ h
subgoal 4 is:
 k

Unnamed_thm < 2:exact H4.
3 subgoals

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  H8 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  ============================
   ~ m

subgoal 2 is:
 ~ m \/ h
subgoal 3 is:
 k

Unnamed_thm < exact H3.
2 subgoals

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  H8 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  ============================
   ~ m \/ h

subgoal 2 is:
 k

Unnamed_thm < apply or_introl.
2 subgoals

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  H8 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  ============================
   ~ m

subgoal 2 is:
 k

Unnamed_thm < exact H3.
1 subgoal

  m : Prop
  n : Prop
  h : Prop
  k : Prop
  l : Prop
  c : Prop
  d : Prop
  f : Prop
  g : Prop
  H : (~ m /\ ~ n -> ~ m \/ h -> k /\ l) /\
      (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H0 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H1 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  H2 : ~ m /\ ~ n -> ~ m \/ h -> k /\ l
  H3 : ~ m
  H6 : c -> d
  H4 : ~ n
  H7 : f <-> g
  H5 : k
  H9 : l
  H8 : (~ m /\ (c -> d)) /\ ~ n /\ (f <-> g)
  ============================
   k

Unnamed_thm < exact H5.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
decompose [and or] H.
split.
 2: exact H4.

 decompose [and or] H0.
 elim H.
 intro.
 intro.
 destruct H5.
  apply conj.
   2: exact H4.

   exact H3.

  apply or_introl.
  exact H3.

  exact H5.

Unnamed_thm is defined

Coq <

*)

Section Exercise_A.
Goal forall m n h k l c d f g:Prop, (((~m /\ ~n) -> ((~m \/ h) -> (k /\ l))) /\ (~m /\ (c -> d)) /\ (~n /\ (f <-> g))) -> (k /\ ~n).
intros.
elim H.
intro.
intro.
decompose [and or] H.
split.
 2: exact H4.
 decompose [and or] H0.
 elim H.
 intro.
 intro.
 destruct H5.
 apply conj.
  2: exact H4.
  exact H3.
 apply or_introl.
 exact H3.
  exact H5.
Qed.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden,-parsing".

From Coq Require Import Arith.Arith.

From PLF Require Import Maps.
From PLF Require Import Imp.
From PLF Require Import Types.
From PLF Require Import Smallstep.
From PLF Require Import LibTactics.

From PLF Require Stlc.
From PLF Require Equiv.
From PLF Require Imp.
From PLF Require References.
From PLF Require Smallstep.
From PLF Require Hoare.
From PLF Require Sub.

Module IntrovExamples.
Import Stlc.
Import Imp.
Import STLC.

Theorem ceval_deterministic: forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseTactics" "UseTactics.IntrovExamples.ceval_deterministic".
introv E1 E2.
Abort.

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
(exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof. hammer_hook "UseTactics" "UseTactics.IntrovExamples.dist_exists_or".
introv.
Abort.

Theorem ceval_deterministic': forall c st st1,
(st =[ c ]=> st1) ->
forall st2,
(st =[ c ]=> st2) ->
st1 = st2.
Proof. hammer_hook "UseTactics" "UseTactics.IntrovExamples.ceval_deterministic'".
introv E1 E2.
Abort.

Theorem exists_impl: forall X (P : X -> Prop) (Q : Prop) (R : Prop),
(forall x, P x -> Q) ->
((exists x, P x) -> Q).
Proof. hammer_hook "UseTactics" "UseTactics.IntrovExamples.exists_impl".
introv [x H2]. eauto.

Qed.

End IntrovExamples.

Module InvertsExamples.
Import Stlc.
Import Equiv.
Import Imp.
Import STLC.

Theorem skip_left: forall c,
cequiv (SKIP;; c) c.
Proof. hammer_hook "UseTactics" "UseTactics.InvertsExamples.skip_left".
introv. split; intros H.
dup.

- inversion H. subst. inversion H2. subst. assumption.

- inverts H. inverts H2. assumption.
Abort.

Theorem ceval_deterministic: forall c st st1 st2,
st =[ c ]=> st1  ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseTactics" "UseTactics.InvertsExamples.ceval_deterministic".
introv E1 E2. generalize dependent st2.
induction E1; intros st2 E2.
admit. admit.
dup.

- inversion E2. subst. admit.

- inverts E2. admit.
Abort.

Theorem ceval_deterministic': forall c st st1 st2,
st =[ c ]=> st1  ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseTactics" "UseTactics.InvertsExamples.ceval_deterministic'".
introv E1 E2. generalize dependent st2.
(induction E1); intros st2 E2;
inverts E2 as.
-  reflexivity.
-

subst n.
reflexivity.
-

intros st3 Red1 Red2.
assert (st' = st3) as EQ1.
{  apply IHE1_1; assumption. }
subst st3.
apply IHE1_2. assumption.

-

intros.
apply IHE1. assumption.
-
intros.
rewrite H in H5. inversion H5.

Abort.

Theorem skip_left': forall c,
cequiv (SKIP;; c) c.
Proof. hammer_hook "UseTactics" "UseTactics.InvertsExamples.skip_left'".
introv. split; intros H.
inverts H as U V.
inverts U. assumption.
Abort.

Example typing_nonexample_1 :
~ exists T,
has_type empty
(abs x Bool
(abs y Bool
(app (var x) (var y))))
T.
Proof. hammer_hook "UseTactics" "UseTactics.InvertsExamples.typing_nonexample_1".
dup 3.

- intros C. destruct C.
inversion H. subst. clear H.
inversion H5. subst. clear H5.
inversion H4. subst. clear H4.
inversion H2. subst. clear H2.
inversion H1.

- intros C. destruct C.
inverts H as H1.
inverts H1 as H2.
inverts H2 as H3 H4.
inverts H3 as H5.
inverts H5.

- intros C. destruct C.
inverts H as H.
inverts H as H.
inverts H as H1 H2.
inverts H1 as H1.
inverts H1.
Qed.

End InvertsExamples.

Module NaryExamples.
Import References.
Import Smallstep.
Import STLCRef.

Lemma demo_splits : forall n m,
n > 0 /\ n < m /\ m < n+10 /\ m <> 3.
Proof. hammer_hook "UseTactics" "UseTactics.NaryExamples.demo_splits".
intros. splits.
Abort.

Lemma demo_branch : forall n m,
n < m \/ n = m \/ m < n.
Proof. hammer_hook "UseTactics" "UseTactics.NaryExamples.demo_branch".
intros.
destruct (lt_eq_lt_dec n m) as [[H1|H2]|H3].
- branch 1. apply H1.
- branch 2. apply H2.
- branch 3. apply H3.
Qed.

End NaryExamples.

Module EqualityExamples.

Theorem mult_0_plus : forall n m : nat,
(0 + n) * m = n * m.
Proof. hammer_hook "UseTactics" "UseTactics.EqualityExamples.mult_0_plus".
dup.

intros n m.
assert (H: 0 + n = n). reflexivity. rewrite -> H.
reflexivity.

intros n m.
asserts_rewrite (0 + n = n).
reflexivity.
reflexivity.
Qed.

Theorem mult_0_plus' : forall n m : nat,
(0 + n) * m = n * m.
Proof. hammer_hook "UseTactics" "UseTactics.EqualityExamples.mult_0_plus'".
intros n m.
cuts_rewrite (0 + n = n).
reflexivity.
reflexivity.
Qed.

Theorem mult_0_plus'' : forall u v w x y z: nat,
(u + v) * (S (w * x + y)) = z.
Proof. hammer_hook "UseTactics" "UseTactics.EqualityExamples.mult_0_plus''".
intros. asserts_rewrite (forall a b, a*(S b) = a*b+a).

Abort.

Lemma demo_substs : forall x y (f:nat->nat),
x = f x ->
y = x ->
y = f x.
Proof. hammer_hook "UseTactics" "UseTactics.EqualityExamples.demo_substs".
intros. substs.
assumption.
Qed.

Lemma demo_fequals : forall (a b c d e : nat) (f : nat->nat->nat->nat->nat),
a = 1 ->
b = e ->
e = 2 ->
f a b c d = f 1 2 c 4.
Proof. hammer_hook "UseTactics" "UseTactics.EqualityExamples.demo_fequals".
intros. fequals.

Abort.

Axiom big_expression_using : nat->nat.

Lemma demo_applys_eq_1 : forall (P:nat->nat->Prop) x y z,
P x (big_expression_using z) ->
P x (big_expression_using y).
Proof. hammer_hook "UseTactics" "UseTactics.EqualityExamples.demo_applys_eq_1".
introv H. dup.

assert (Eq: big_expression_using y = big_expression_using z).
admit.
rewrite Eq. apply H.

applys_eq H 1.
admit.
Abort.

Lemma demo_applys_eq_2 : forall (P:nat->nat->Prop) x y z,
P (big_expression_using z) x ->
P (big_expression_using y) x.
Proof. hammer_hook "UseTactics" "UseTactics.EqualityExamples.demo_applys_eq_2".
introv H. applys_eq H 2.
Abort.

Lemma demo_applys_eq_3 : forall (P:nat->nat->Prop) x1 x2 y1 y2,
P (big_expression_using x2) (big_expression_using y2) ->
P (big_expression_using x1) (big_expression_using y1).
Proof. hammer_hook "UseTactics" "UseTactics.EqualityExamples.demo_applys_eq_3".
introv H. applys_eq H 1 2.

Abort.

End EqualityExamples.

Module UnfoldsExample.
Import Hoare.

Lemma bexp_eval_true : forall b st,
beval st b = true ->
(bassn b) st.
Proof. hammer_hook "UseTactics" "UseTactics.UnfoldsExample.bexp_eval_true".
intros b st Hbe. dup.

unfold bassn. assumption.

unfolds. assumption.
Qed.

End UnfoldsExample.

Lemma demo_false : forall n,
S n = 1 ->
n = 0.
Proof. hammer_hook "UseTactics" "UseTactics.demo_false".
intros. destruct n. reflexivity. false.
Qed.

Lemma demo_false_arg :
(forall n, n < 0 -> False) ->
3 < 0 ->
4 < 0.
Proof. hammer_hook "UseTactics" "UseTactics.demo_false_arg".
intros H L. false H. apply L.
Qed.

Lemma demo_tryfalse : forall n,
S n = 1 ->
n = 0.
Proof. hammer_hook "UseTactics" "UseTactics.demo_tryfalse".
intros. destruct n; tryfalse. reflexivity.
Qed.

Module GenExample.
Import Stlc.
Import STLC.

Lemma substitution_preserves_typing : forall Gamma x U v t S,
has_type (update Gamma x U) t S ->
has_type empty v U ->
has_type Gamma ([x:=v]t) S.
Proof. hammer_hook "UseTactics" "UseTactics.GenExample.substitution_preserves_typing".
dup.

intros Gamma x U v t S Htypt Htypv.
generalize dependent S. generalize dependent Gamma.
induction t; intros; simpl.
admit. admit. admit. admit. admit. admit.

introv Htypt Htypv. gen S Gamma.
induction t; intros; simpl.
admit. admit. admit. admit. admit. admit.
Abort.

End GenExample.

Module SkipExample.
Import Stlc.
Import STLC.

Theorem demo_admits : True.
Proof. hammer_hook "UseTactics" "UseTactics.SkipExample.demo_admits".
admits H: (forall n m : nat, (0 + n) * m = n * m).
Abort.

Theorem mult_plus_0 : forall n m : nat,
(n + 0) * m = n * m.
Proof. hammer_hook "UseTactics" "UseTactics.SkipExample.mult_plus_0".
dup 3.

intros n m.
assert (H: n + 0 = n). admit. rewrite -> H. clear H.
reflexivity.

intros n m.
admit_rewrite (n + 0 = n).
reflexivity.

intros n m.
admit_rewrite (forall a, a + 0 = a).
reflexivity.
Admitted.

Theorem ceval_deterministic: forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseTactics" "UseTactics.SkipExample.ceval_deterministic".

admit_goal.

introv E1 E2. gen st2.
(induction E1); introv E2; inverts E2 as.
-  reflexivity.
-
subst n.
reflexivity.
-
intros st3 Red1 Red2.
assert (st' = st3) as EQ1.
{

eapply IH. eapply E1_1. eapply Red1. }
subst st3.

eapply IH. eapply E1_2. eapply Red2.

Abort.

End SkipExample.

Module SortExamples.
Import Imp.

Theorem ceval_deterministic: forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "UseTactics" "UseTactics.SortExamples.ceval_deterministic".
intros c st st1 st2 E1 E2.
generalize dependent st2.
(induction E1); intros st2 E2; inverts E2.
admit. admit.
sort.
Abort.

End SortExamples.

Module ExamplesLets.
Import Sub.

Import Sub.

Axiom typing_inversion_var : forall (G:context) (x:string) (T:ty),
has_type G (var x) T ->
exists S, G x = Some S /\ subtype S T.

Lemma demo_lets_1 : forall (G:context) (x:string) (T:ty),
has_type G (var x) T ->
True.
Proof. hammer_hook "UseTactics" "UseTactics.ExamplesLets.demo_lets_1".
intros G x T H. dup.

lets K: typing_inversion_var H.
destruct K as (S & Eq & Sub).
admit.

lets (S & Eq & Sub): typing_inversion_var H.
admit.
Abort.

Lemma demo_lets_2 : forall (G:context) (x:string) (T:ty), True.
Proof. hammer_hook "UseTactics" "UseTactics.ExamplesLets.demo_lets_2".
intros G x T.
lets (S & Eq & Sub): typing_inversion_var G x T ___.
Abort.

Lemma demo_lets_3 : forall (x:string), True.
Proof. hammer_hook "UseTactics" "UseTactics.ExamplesLets.demo_lets_3".
intros x.
lets (S & Eq & Sub): typing_inversion_var x ___.
Abort.

Lemma demo_lets_4 : True.
Proof. hammer_hook "UseTactics" "UseTactics.ExamplesLets.demo_lets_4".
lets (S & Eq & Sub): typing_inversion_var ___.
Abort.

Lemma demo_lets_5 : True.
Proof. hammer_hook "UseTactics" "UseTactics.ExamplesLets.demo_lets_5".
lets H: typing_inversion_var.
Abort.

Lemma demo_lets_underscore :
(forall n m, n <= m -> n < m+1) ->
True.
Proof. hammer_hook "UseTactics" "UseTactics.ExamplesLets.demo_lets_underscore".
intros H.

lets K: H 3.
clear K.

lets K: H __ 3.
clear K.
Abort.

End ExamplesLets.

Module ExamplesInstantiations.
Import Sub.

Lemma substitution_preserves_typing : forall Gamma x U v t S,
has_type (update Gamma x U) t S ->
has_type empty v U ->
has_type Gamma ([x:=v]t) S.
Proof with eauto. hammer_hook "UseTactics" "UseTactics.ExamplesInstantiations.substitution_preserves_typing".
intros Gamma x U v t S Htypt Htypv.
generalize dependent S. generalize dependent Gamma.
(induction t); intros; simpl.
-
rename s into y.

lets (T&Hctx&Hsub): typing_inversion_var Htypt.
unfold update, t_update in Hctx.
destruct (eqb_stringP x y)...
+
subst.
inversion Hctx; subst. clear Hctx.
apply context_invariance with empty...
intros x Hcontra.

lets [T' HT']: free_in_context S (@empty ty) Hcontra...
inversion HT'.
-

admit.

-
rename s into y. rename t into T1.

lets (T2&Hsub&Htypt2): typing_inversion_abs Htypt.

applys T_Sub (Arrow T1 T2)...
apply T_Abs...
destruct (eqb_stringP x y).
+
eapply context_invariance...
subst.
intros x Hafi. unfold update, t_update.
destruct (eqb_stringP y x)...
+
apply IHt. eapply context_invariance...
intros z Hafi. unfold update, t_update.
destruct (eqb_stringP y z)...
subst. rewrite false_eqb_string...
-
lets: typing_inversion_true Htypt...
-
lets: typing_inversion_false Htypt...
-
lets (Htyp1&Htyp2&Htyp3): typing_inversion_if Htypt...
-

lets: typing_inversion_unit Htypt...

Admitted.

End ExamplesInstantiations.


Require Import Coq.Program.Equality.

Require Import BinNums.

Require Import Prelude.Control.
Require Import Prelude.Control.Classes.

Require Import FreeSpec.Tactics.
Require Import FreeSpec.Interface.
Require Import FreeSpec.Semantics.
Require Import FreeSpec.Program.
Require Import FreeSpec.Compose.
Require Import FreeSpec.Component.
Require Import FreeSpec.Specification.

Require Import FreeSpec.Stdlib.FileSystem.Definitions.
Require Import FreeSpec.Stdlib.FileSystem.Specifications.

Require Import String.

Local Open Scope prelude_scope.
Local Open Scope free_scope.

Definition openclose {ix} `{Use FileSystem.i ix} (str : string)
: Program ix unit :=
	fd <- FileSystem.open FileSystem.ReadOnly FileSystem.DontCreate str;
	FileSystem.close fd.

Definition s := initialState.

Lemma correct (str : string) :
		openclose str |> specs[s].
Proof.
constructor.
+ compute.
	constructor.
	simpl.
	intro Hf.
	now inversion Hf.
+	intros.
	constructor.
	- simpl.
		constructor.
		unfold opened_fd.
		rewrite setFunOk.
		easy.
	- constructor.
Qed.


Require Export Iron.Language.SystemF2Effect.Type.Relation.KindT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.LowerTT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.SubstTT.Base.

Lemma lowerTT_substTT
 :  forall ix t1 t1' t2
 ,  lowerTT ix    t1 = Some t1'
 -> substTT ix t2 t1 = t1'.
Proof.
 intros. gen ix t2 t1'.
 induction t1; intros; simpl;
  try (solve [snorm; espread; nope]).

 simpl in H. snorm; f_equal; eauto.
 simpl in H. snorm; f_equal; eauto.
 simpl in H. snorm; f_equal; eauto.
Qed.
Hint Resolve lowerTT_substTT.
Hint Rewrite lowerTT_substTT : global.

(* What a horrow show *)
Lemma lowerTT_substTT_liftTT
 :  forall t1 t1' d d' t2
 ,  lowerTT d t1 = Some t1'
 -> lowerTT d (substTT (1 + d + d') (liftTT 1 d t2) t1)
       = Some (substTT (d + d')      t2              t1').
Proof.
 intros. gen d d' t2 t1'.
 induction t1; intros;
  try (solve [snorm]).

 Case "TVar".
  repeat (simpl in *; norm1); try nope; try omega.

 Case "TForall".
  snorm. repeat f_equal.

   (* Goal 10 *)
   lets D: IHt1 (S d) d' (liftTT 1 0 t2) t0.
   symmetry in HeqH1. rip. clear IHt1. clear HeqH1.
   rrwrite (S (S d + d') = S (S (d + d'))) in D.
   norm. rewrite D in HeqH0. snorm.

   (* Goal 8 *)
   lets D: IHt1 (S d) d' (liftTT 1 0 t2) t.
   symmetry in HeqH1. rip. clear IHt1. clear HeqH1.
   rrwrite (S (S d + d') = S (S (d + d'))) in D.
   norm. rewrite D in HeqH0. nope.

(* This seems to have been broken in the last Coq release.
   It worked in ~2013.
 Case "TApp".
  snorm; nope.
   repeat (espread; burn); burn.
   erewrite IHt1_1 in *; eauto.
   erewrite IHt1_2 in *; eauto. nope.
   erewrite IHt1_1 in *; eauto. nope.

 Case "TSum".
  snorm; nope.
   repeat (espread; burn); burn.
   erewrite IHt1_1 in *; eauto.
   erewrite IHt1_2 in *; eauto. nope.
   erewrite IHt1_1 in *; eauto. nope.

 Case "TCon1".
  snorm; nope.
   repeat (espread; burn).
   erewrite IHt1 in *; eauto. nope.

 Case "TCon2".
  snorm; nope.
   repeat (espread; burn); burn.
   erewrite IHt1_1 in *; eauto.
   erewrite IHt1_2 in *; eauto. nope.
   erewrite IHt1_1 in *; eauto. nope.
*)

 admit.
 admit.
 admit.
 admit.
Admitted.

(* If we can lower a particular index then the term does not use it,
   so we can delete the corresponding slot from the enviornment. *)
Lemma lower_type_type_ix
 :  forall ix ke sp t1 k1 t2
 ,  lowerTT ix t1 = Some t2
 -> KindT ke sp t1 k1
 -> KindT (delete ix ke) sp t2 k1.
Proof.
 intros. gen ix ke sp k1 t2.
 induction t1; intros; simpl;
  try (solve [inverts_kind; snorm; eauto; nope]).

 - Case "TVar".
   inverts_kind. snorm.
    SCase "n > ix".
     eapply KiVar.
     rewrite <- H4.
     destruct n.
      simpl. burn.
      simpl. norm.

 - Case "TForall".
   inverts_kind. snorm.
    eapply KiForall.
    rewrite delete_rewind.
    eauto.

 - Case "TCon2".
   inverts_kind. snorm.
   eapply KiCon2; eauto.
    destruct tc; destruct t; eauto.
Qed.

Lemma lower_type_type
 :  forall t1 t2 ke sp k1 k2
 ,  lowerTT 0 t1 = Some t2
 -> KindT (ke :> k1) sp t1 k2
 -> KindT ke         sp t2 k2.
Proof.
 intros.
 lets D: lower_type_type_ix H H0.
 simpl in D. auto.
Qed.


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Template Require Import config utils.
From MetaCoq.PCUIC Require Import
  PCUICAst PCUICAstUtils PCUICTyping PCUICSafeLemmata PCUICValidity
  PCUICReduction PCUICEquality PCUICConfluence PCUICUnivSubstitutionConv
  PCUICUnivSubstitutionTyp.

Require Import Equations.Prop.DepElim.

(** We assume normalisation of the reduction.
    We state is as well-foundedness of the reduction.
*)

Record normalizing_flags {cf : checker_flags} : Prop :=
  { nor_check_univs :> check_univs }.

Existing Class normalizing_flags.

#[local] Instance default_normalizing :
  @normalizing_flags default_checker_flags.
Proof.
  now constructor.
Qed.

#[local] Instance extraction_normalizing :
  @normalizing_flags extraction_checker_flags.
Proof.
  now constructor.
Qed.

Class NormalisationIn {cf : checker_flags} {no : normalizing_flags} (Σ : global_env_ext) :=
  normalisation_in :
    forall Γ t,
      welltyped Σ Γ t ->
      Acc (cored Σ Γ) t.
Class Normalisation {cf : checker_flags} {no : normalizing_flags} :=
  normalisation : forall Σ, wf_ext Σ -> NormalisationIn Σ.
#[export] Hint Mode NormalisationIn - - + : typeclass_instances.
#[export] Typeclasses Opaque Normalisation.

(** Since we are working with name annotations, reduction is sensitive to names.
    In this section we provide cored' which corresponds to reduction up to
    α-renaming, as well as the necessary lemmata to show it is well-founded and
    can be used instead of the usual reduction as a measure.
*)

Section Alpha.

  Context {cf : checker_flags} {no : normalizing_flags}.
  Context (Σ : global_env_ext) {normalisation : NormalisationIn Σ}.

  Notation eqt u v := (∥ upto_names u v ∥).

  Definition cored' Γ u v :=
    exists u' v', cored Σ Γ u' v' /\ eqt u u' /\ eqt v v'.

  Lemma cored_alt :
    forall Γ u v,
      cored Σ Γ u v <~> ∥ Relation.trans_clos (red1 Σ Γ) v u ∥.
  Proof using Type.
    intros Γ u v.
    split.
    - intro h. induction h.
      + constructor. constructor. assumption.
      + destruct IHh as [ih]. constructor.
        eapply Relation.t_trans.
        * eassumption.
        * constructor. assumption.
    - intros [h]. induction h.
      + constructor. assumption.
      + eapply cored_trans'. all: eassumption.
  Qed.

  Local Instance substu_pres_eq : SubstUnivPreserving eq.
  Proof using Type.
    red. intros s u u'.
    unfold R_universe_instance.
    intros f. eapply Forall2_map_inv in f.
    assert (u = u') as ->.
    { induction f; cbn; auto. f_equal; auto.
      now eapply Universe.make_inj in H. }
    reflexivity.
  Qed.

  Lemma cored'_postpone :
    forall Γ u v,
      cored' Γ u v ->
      exists u', cored Σ Γ u' v /\ eqt u u'.
  Proof using Type.
    intros Γ u v [u' [v' [r [[hu] [hv]]]]].
    apply cored_alt in r.
    destruct r as [r].
    induction r in u, v, hu, hv.
    - eapply red1_eq_term_upto_univ_r in r. 10: eassumption.
      all:tc.
      destruct r as [u' [r e]].
      exists u'. split.
      * constructor. assumption.
      * constructor. etransitivity. 1: eauto.
        now symmetry.
    - specialize (IHr1 y v).
      destruct IHr1 as [y' [h1 [e1]]]; auto. reflexivity.
      specialize (IHr2 u y').
      destruct IHr2 as [u' [h2 ?]]; auto. now symmetry.
      exists u'. split.
      + eapply cored_trans'. all: eauto.
      + assumption.
  Qed.

  Corollary cored_upto :
    forall Γ u v v',
      cored Σ Γ u v ->
      eqt v v' ->
      exists u', cored Σ Γ u' v' /\ eqt u u'.
  Proof using Type.
    intros Γ u v v' h e.
    eapply cored'_postpone.
    exists u, v. intuition eauto.
    - constructor. reflexivity.
    - destruct e; constructor; now symmetry.
  Qed.

  Lemma Acc_impl :
    forall A (R R' : A -> A -> Prop),
      (forall x y, R x y -> R' x y) ->
      forall x, Acc R' x -> Acc R x.
  Proof using Type.
    intros A R R' h x hx.
    induction hx as [x h1 h2].
    constructor. intros y hy.
    eapply h2. eapply h. assumption.
  Qed.

  Lemma Acc_cored_cored' :
    forall Γ u,
      Acc (cored Σ Γ) u ->
      forall u', eqt u u' -> Acc (cored' Γ) u'.
  Proof using Type.
    intros Γ u h. induction h as [u h ih].
    intros u' e. constructor. intros v [v' [u'' [r [[e1] [e2]]]]].
    assert (ee : eqt u'' u).
    { destruct e. constructor. symmetry; etransitivity; tea. }
    eapply cored_upto in r as hh. 2: exact ee.
    destruct hh as [v'' [r' [e']]].
    eapply ih.
    - eassumption.
    - destruct ee. constructor. symmetry; etransitivity; eassumption.
  Qed.

  Lemma normalisation_upto :
    forall Γ u,
      welltyped Σ Γ u ->
      Acc (cored' Γ) u.
  Proof using normalisation.
    intros Γ u h.
    apply normalisation in h.
    eapply Acc_cored_cored'.
    - eassumption.
    - constructor; reflexivity.
  Qed.

  (* TODO Maybe switch to eq_context *)
  Lemma cored_eq_context_upto_names :
    forall Γ Δ u v,
      eq_context_upto_names Γ Δ ->
      cored Σ Γ u v ->
      cored Σ Δ u v.
  Proof using Type.
    intros Γ Δ u v e h.
    apply cored_alt in h as [h].
    induction h in Δ, e |- *.
    - constructor. eapply red1_eq_context_upto_names. all: eauto.
    - eapply cored_trans'.
      + eapply IHh2. assumption.
      + eapply IHh1. assumption.
  Qed.

  Lemma cored_eq_term_upto :
    forall Σ' Re Rle Γ u v u',
      RelationClasses.Reflexive Re ->
      SubstUnivPreserving Re ->
      RelationClasses.Reflexive Rle ->
      SubstUnivPreserving Rle ->
      RelationClasses.Symmetric Re ->
      RelationClasses.Transitive Re ->
      RelationClasses.Transitive Rle ->
      RelationClasses.subrelation Re Rle ->
      eq_term_upto_univ Σ' Re Rle u u' ->
      cored Σ Γ v u ->
      exists v', cored Σ Γ v' u' /\ ∥ eq_term_upto_univ Σ' Re Rle v v' ∥.
  Proof using Type.
    intros Σ' Re Rle Γ u v u' X X0 X1 X2 X3 X4 X5 X6 e h.
    apply cored_alt in h as [h].
    induction h in u', e |- *.
    - eapply red1_eq_term_upto_univ_l in r. 9: eauto. all: auto.
      destruct r as [? [? ?]].
      eexists. split.
      + constructor. eassumption.
      + constructor. assumption.
    - specialize (IHh1 _ e). destruct IHh1 as [y' [r1 [e1]]].
      specialize (IHh2 _ e1). destruct IHh2 as [z' [r2 [e2]]].
      exists z'. split.
      + eapply cored_trans'. all: eassumption.
      + constructor. assumption.
  Qed.

  Lemma cored_eq_context_upto :
    forall Σ' Re Γ Δ u v,
      RelationClasses.Reflexive Re ->
      RelationClasses.Symmetric Re ->
      RelationClasses.Transitive Re ->
      SubstUnivPreserving Re ->
      eq_context_upto Σ' Re Re Γ Δ ->
      cored Σ Γ u v ->
      exists u', cored Σ Δ u' v /\ ∥ eq_term_upto_univ Σ' Re Re u u' ∥.
  Proof using Type.
    intros Σ' Re Γ Δ u v hRe1 hRe2 hRe3 hRe4 e h.
    apply cored_alt in h as [h].
    induction h.
    - eapply red1_eq_context_upto_l in r. all: eauto. 2:tc.
      destruct r as [? [? ?]].
      eexists. split.
      + constructor. eassumption.
      + constructor. assumption.
    - destruct IHh1 as [x' [r1 [e1]]].
      destruct IHh2 as [y' [r2 [e2]]].
      eapply cored_eq_term_upto in r2. 10: exact e1. all: auto.
      2:tc.
      destruct r2 as [y'' [r2' [e2']]].
      exists y''. split.
      * eapply cored_trans'. all: eassumption.
      * constructor. eapply eq_term_upto_univ_trans. all: eauto.
  Qed.

  (* Lemma eq_context_upto_nlctx :
    forall Γ,
      eq_context_upto Σ eq eq Γ (nlctx Γ).
  Proof.
    intros Γ.
    induction Γ as [| [na [b|] A] Γ ih ].
    - constructor.
    - simpl. constructor; simpl; try apply binder_anonymize; tas.
      + constructor; tas; auto. eapply eq_term_upto_univ_tm_nl.
        all: auto.
        eapply eq_term_upto_univ_tm_nl.
        all: auto.
    - simpl. constructor; auto. constructor.
      + apply binder_anonymize.
      + simpl. eapply eq_term_upto_univ_tm_nl.
        all: auto.
  Qed.

  Lemma cored_cored'_nl :
    forall Γ u v,
      cored Σ Γ u v ->
      cored' (nlctx Γ) (nl u) (nl v).
  Proof.
    intros Γ u v h.
    eapply cored_eq_context_upto in h.
    6: eapply eq_context_upto_nlctx.
    all: auto.
    - destruct h as [u' [r [e]]].
      eexists _, _. intuition eauto.
      + constructor. eapply eq_term_trans.
        * eapply eq_term_sym. eapply eq_term_tm_nl.
        * eapply eq_term_upto_univ_impl; eauto. all:typeclasses eauto.
      + constructor. eapply eq_term_sym. eapply eq_term_tm_nl.
    - intros ? ? ? []. auto.
    - intros ? ? ? r. apply Forall2_eq in r. apply map_inj in r.
      + subst. reflexivity.
      + apply Universe.make_inj.
  Qed. *)

  Lemma cored_cored' :
    forall Γ u v,
      cored Σ Γ u v ->
      cored' Γ u v.
  Proof using Type.
    intros Γ u v h.
    exists u, v. intuition eauto.
    - constructor. reflexivity.
    - constructor. reflexivity.
  Qed.

End Alpha.


(** a small plugin to add the contraposition of implications as axiom **)

Require Import MetaCoq.Template.All.

From MetaCoq.PCUIC Require Import
     PCUICAst PCUICAstUtils PCUICInduction
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

From MetaCoq.PCUIC Require Import PCUICToTemplate.

Require Import List String.
Import ListNotations MonadNotation Nat.
Require Import MetaCoq.Template.Pretty.
Require Import MetaCoq.PCUIC.PCUICPretty.

Require Import List String.

Open Scope string.

Ltac addContrapos H :=
  match H with
    ?A -> ?B => assert (B->A) by admit
  | _ => fail "wrong structure"
  end.

Definition termNegType t := Ast.tProd nAnon t <% False %>.

Definition addContraposType {A:Type} (H:A) (name:ident) :TemplateMonad unit :=
  p <- tmQuote H;;
  match p with
  | Ast.tProd nAnon t1 t2 =>
    na <- tmFreshName name;;
    q <- tmUnquoteTyped Type (Ast.tProd nAnon (termNegType t2) (termNegType t1));;
    tmAxiomRed na None (q:Type);;
    tmPrint q;;
    tmMsg (append "was added to the environment as axiom " na)
  | Ast.tProd _ _ _ => tmFail "A non dependent implication is expected"
  | _ => tmFail "Invalid argument. Implication expected"
  end.

MetaCoq Run (addContraposType (True -> False) "Contra").
MetaCoq Run (addContraposType (bool -> nat) "Contra").

Definition H := True -> False.
MetaCoq Run (
  p <- tmAbout "H";;
  tmPrint p
).
MetaCoq Run (
  p <- tmQuote H;;
  tmPrint p
).
MetaCoq Run (
  p <- tmQuoteConstant "H" false;;
  q <- tmEval hnf p;;
  tmPrint q
).

Definition computeContrapos (t:Ast.term) (name:ident) : TemplateMonad unit :=
  match t with
  | Ast.tProd nAnon t1 t2 =>
    na <- tmFreshName name;;
    q1 <- tmUnquoteTyped Prop t1;;
    q2 <- tmUnquoteTyped Prop t2;;
    let q := ~q2 -> ~q1 in
    (
      tmAxiomRed na None q;;
      tmPrint q;;
      tmMsg (append "was added to the environment as axiom " na)
    )
  | Ast.tProd _ _ _ => tmFail "A non dependent implication is expected"
  | _ => tmFail "Invalid argument. Implication expected"
  end.

Definition addContrapos (H:Prop) (name:ident) :TemplateMonad unit :=
  p <- tmQuote H;;
  match p with
  | Ast.tConst qual _ =>
    q <- tmQuoteConstant qual false;;
    match Ast.cst_body q with
    | Some t => computeContrapos t name
    | None => tmFail "a constant with an opaque body is not a valid argument"
    end
  | _ => computeContrapos p name
  end.

MetaCoq Run (addContrapos (False -> True) "Contra").
Print Contra1.
MetaCoq Run (addContrapos H "Contra_H").
Print Contra_H.
Fail MetaCoq Run (addContrapos (bool -> nat) "Contra").
Fail MetaCoq Run (addContrapos 0).
Fail MetaCoq Run (addContrapos (forall (x:bool), nat)).

Print Contra1.

Axiom (H2:Type).

Definition H3:Type.
exact (True -> True).
Qed.

Fail MetaCoq Run (addContrapos H2 "T").
Fail MetaCoq Run (addContrapos H3 "T").


From iris.algebra Require Import ofe.

Instance equiv_ext_discrete_fun {A B} :
  subrelation (≡@{A -d> B}) (pointwise_relation A (≡)).
Proof. done. Qed.

Instance dist_ext_discrete_fun {A B n} :
  subrelation (dist n (A := A -d> B)) (pointwise_relation A (dist n)).
Proof. done. Qed.

Instance equiv_ext_discrete_fun_forall {A B} :
  subrelation (≡@{A -d> B}) (forall_relation (const (≡))).
Proof. done. Qed.
Instance dist_ext_discrete_fun_forall {A B n} :
  subrelation (dist n (A := A -d> B)) (forall_relation (const (dist n))).
Proof. done. Qed.

Instance equiv_ext_ofe_mor {A B} :
  subrelation (≡@{A -n> B}) (pointwise_relation A (≡)).
Proof. done. Qed.

Instance dist_ext_ofe_mor {A B n} :
  subrelation (dist n (A := A -n> B)) (pointwise_relation A (dist n)).
Proof. done. Qed.

Instance equiv_ext_ofe_mor_forall {A B} :
  subrelation (≡@{A -n> B}) (forall_relation (const (≡))).
Proof. done. Qed.

Module foo1.
Section discrete_fun.
Context {A B C: ofeT} (f g : A -d> B) (h : B -d> C).
  (* Instance: Proper (pointwise_relation _ (≡)) f := _.
  Instance: Proper (pointwise_relation _ (≡)) g := _. *)
  Context `{!Proper ((≡) ==> (≡)) h}.

  (* About forall_relation.
  About equiv_ext_ofe_mor . *)

  Lemma foo x : f ≡ g → f x ≡ g x.
  Proof. by move->. Qed.

  (* Ditto here: *)
  Lemma foo' : f ≡ g → ∀ x, f x ≡ g x.
  Proof.
    intros Heq.
    Fail rewrite Heq.
    by setoid_rewrite Heq.
  Qed.

  Lemma bar x : f ≡ g → h (f x) ≡ h (g x).
  Proof.
    intros Heq.
    by rewrite Heq.
    (* Fail setoid_rewrite Heq.
    Fail apply Heq. (* Of course *)
    (* workaround: call stdpp's f_equiv by hand. *)
    f_equiv. apply Heq. *)
  Qed.
End discrete_fun.
End foo1.

Section foo.
Context {A B C: ofeT} (f g : A -n> B) (h : B -n> C).

  Lemma foo1 x : f ≡ g → f x ≡ g x.
  Proof.
    intros Heq.
    Fail rewrite ->Heq.
    Fail rewrite Heq.
    pose proof (ofe_mor_car_proper f g Heq x x (reflexivity _)) as Heq'.
    Fail rewrite Heq'.
    rewrite ->Heq'.
    (* Undo *)
    Restart. intros Heq.
    pose proof (ofe_mor_car_proper f g Heq x x (reflexivity _)) as Heq'.
    unfold ofe_mor_car in Heq'.
    by rewrite Heq'.
  Qed.

  Global Instance ofe_mor_car_proper2 :
  Proper ((≡) ==> (≡@{A}) ==> (≡@{B})) (ofe_mor_car _ _) := ne_proper_2 _.

  Global Instance ofe_mor_car_proper3 :
  Proper ((≡) ==> (≡@{A}) ==> (≡@{B})) (fun x => ofe_mor_car _ _ x) := ne_proper_2 _.
  About ofe_mor_car_proper .

  (* About forall_relation.
  About equiv_ext_ofe_mor . *)
  Lemma foo x : f ≡ g → f x ≡ g x.
  Proof.
    intros Heq.
    pose proof ofe_mor_car_proper2 as H.
    unfold ofe_mor_car in H.
    Fail rewrite Heq.
    pose proof (ofe_mor_car_proper2 f g Heq x x (reflexivity _)) as Heq'.
    Fail rewrite Heq'.
    unfold ofe_mor_car in Heq'.
    rewrite Heq'.

    by rewrite -(ofe_mor_car_proper3 f g Heq x x (reflexivity _)).
  Qed.

  Instance: Proper (pointwise_relation _ (≡)) f := _.
  Instance: Proper (pointwise_relation _ (≡)) g := _.
  Instance: Proper (pointwise_relation _ (≡)) h := _.
  (* Ditto here: *)
  Lemma foo' : f ≡ g → ∀ x, f x ≡ g x.
  Proof.
    intros Heq.
    Fail rewrite Heq.
    Fail setoid_rewrite Heq.
    apply Heq.
  Qed.

  Lemma bar x : f ≡ g → h (f x) ≡ h (g x).
  Proof.
    intros Heq.
    Fail rewrite Heq.
    Fail setoid_rewrite Heq.
    Fail apply Heq. (* Of course *)
    (* workaround: call stdpp's f_equiv by hand. *)
    f_equiv. apply Heq.
  Qed.
End foo.


(** What does it mean for a physical quantity
    to be controlled by an output device.

    [uptoTime] only makes sense if it is later than
    the timestamp of the last event
 *)
(*
Fixpoint OutDevBehaviourCorrectUpto
    {Env : Type}
    (physQ : Time -> Env)
    (outDev : RosOutDevNode Env)
    (processedEvts: list E)
    (uptoTime : Time) :=
  match processedEvts with
  | nil => (fst (odev outDev)) _ (restrictTill physQ uptoTime)
  | last :: rest =>
      let recUptoTime := (eTime last) in
      let timeDiff := tdiff uptoTime recUptoTime in
      let recProp := OutDevBehaviourCorrectUpto physQ outDev rest recUptoTime in
      let restMsgs := map eMesg rest in
      let outdBh := getRosOutDevBhv outDev restMsgs in
      recProp /\ outdBh timeDiff
            (fastFwdAndRestrict physQ recUptoTime uptoTime)
      (* physQ needs to be advanced *)
  end.

Definition OutDevBehaviourCorrect
    {Env : Type}
    (physQ : Time -> Env)
    (outDev : RosOutDevNode Env)
    (locEvents : nat -> option E)
    (lastEvtIndex : Time -> nat)
     :=
  forall (t : Time),
    let lastIndex := lastEvtIndex t in
    let prevProcEvents :=  prevProcessedEvents lastIndex locEvents in
    OutDevBehaviourCorrectUpto physQ outDev prevProcEvents t.

Definition noMessagesAfter
    (locEvents : nat -> option E)
    (lastEvtIndex : Time -> nat)
    (t : Time) : Prop :=

  let tIndex := lastEvtIndex t in
  forall n:nat,
     n > tIndex
     -> locEvents n = None.

Definition nextMessageAtTime
    (locEvents : nat -> option E)
    (lastEvtIndex : Time -> nat)
    (curTime : Time)
    (mesgTime : Time)
    (m : Message) : Prop :=

  let tIndex := lastEvtIndex curTime in
  match locEvents tIndex with
  | None => False
  | Some ev  => (realV _ (eTime ev) = curTime [+] mesgTime)
                /\ (eMesg ev = m)
  end.

CoFixpoint InpDevBehaviourCorrectAux
    {Env : Type}
    (physQ : Time -> Env)
    (inpDev : RosInpDevNode Env)
    (locEvents : nat -> option E)
    (lastEvtIndex : Time -> nat)
    (startTime : Time) : CoList Prop :=

  let indev := getIDev (idev inpDev) in
  match (indev (fastFwd physQ startTime)) with
  | inl _ =>
      ccons (noMessagesAfter
                  locEvents
                  lastEvtIndex
                  startTime)
            (@cnil Prop)
  | inr ((mesg, timeSent), newIdev) =>
      ccons (nextMessageAtTime
                  locEvents
                  lastEvtIndex
                  startTime
                  timeSent
                  (makeTopicMesg mesg))
            (InpDevBehaviourCorrectAux
                  physQ
                  ( substIDev inpDev newIdev )
                  locEvents
                  lastEvtIndex
                  timeSent)
  end.

Definition InpDevBehaviourCorrect
  {Env : Type}
  (physQ : Time -> Env)
  (inpDev : RosInpDevNode Env)
  (locEvents : nat -> option E)
  (lastEvtIndex : Time -> nat) :=

  let props := InpDevBehaviourCorrectAux physQ inpDev locEvents lastEvtIndex 0 in
  forall n, ConjL (initialSegment n props).

*)

(** this is a correct proof; only temporarily wrong *)
Lemma velMessages:
  forall n : nat,
     match getVelFromMsg (motorEvents n) with
     | Some v => v = speed \/ v = (0-speed)
     | None => True
     end.
Proof.
  intros n.
  unfold motorEvents.
  unfold getVelFromMsg.
  unfold getVelFromEv.
  (** the message of this deque event must have come
      from a prior enque event as evEnq*)
  pose proof (corrFIFO eo) as Hfifo.
  pose proof (deqEnq Hfifo BASEMOTOR n) as Henq.
  unfold deqMesgOp in Henq.
  unfold opBind.
  unfold opBind in Henq.
  remember (localEvts BASEMOTOR n)  as oev.
  destruct oev as [ ev| ]; [| auto; fail].
  remember (deqMesg ev)  as om.
  destruct om as [ sm| ]; [| auto; fail].
  destruct Henq as [evEnq Henq].
  clear Hfifo.
  (** someone must have sent this message
      which is contained in the receive (enque)
      event evEnq. let the sent message
      be [sm] and the corresponding event be [es] *)
  pose proof (recvSend eo evEnq) as Hrecv.
  repnd.
  destruct Hrecv as [es Hrecv];
    [unfold isRecvEvt; rewrite Henqrrl; auto |].
  TrimAndRHS Hrecv.
  unfold PossibleSendRecvPair in Hrecv.
  rewrite Henqrrl in Hrecv.
  rewrite Henqrrr in Hrecv.
  rewrite <- Henqrl in Hrecv.
  clear Henqrrl Henqrl Henqrrr.
  remember (eKind es) as eks.
  destruct eks; try contradiction;[].
  simpl in Hrecv.
  repnd. clear Hrecvrrr.
  (** since [BASEMOTOR] only receives on [MOTOR]
      topic, the message [sm] must have that topic *)
  unfold validRecvMesg in Hrecvrl.
  simpl in Hrecvrl.
  unfold validSendMesg in Hrecvrrl.
  destruct Hrecvrl as [Hmt | ?];[| contradiction].
  rewrite Hrecvl in Hrecvrrl.
  rewrite <- Hmt in Hrecvrrl.
  remember (eLoc es) as sloc.
  (** Only [SWCONTROLLER] sends on that topic *)
  destruct sloc; simpl in Hrecvrrl;
    try contradiction;
    inversion Hrecvrrl;
    try discriminate;
    try contradiction;[].
  clear H Hrecvrrl.
  apply swControllerMessages in Heqeks;
    [| trivial].
  rewrite <- Hrecvl. trivial.
Qed.

(** A node only receives messeages from subscribed topics *)
(*
Definition noSpamRecv
    (locEvents : nat -> option EV)
    (rnode :  @RosNode  _ _ _ EV) :=

    forall n, match (locEvents n) with
              | Some rv => validRecvMesg (topicInf rnode) (eMesg rv)
              | None => True
              end.

Definition noSpamSend
    (locEvents : nat -> option EV)
    (rnode :  @RosNode  _ _ _ EV) :=
    forall n, match (locEvents n) with
              | Some rv => validSendMesg (topicInf rnode) (eMesg rv)
              | None => True
              end.

*)

(** Some properties about events at a particular location. In the
    next Coq Section, we formalize the interlocation properties. *)

(** first event is innermost, last event is outermost *)
Fixpoint prevProcessedEvents (m : nat)
  (locEvents : nat -> option EV) : list EV :=
  match m with
  | 0 => nil
  | S m' => (match locEvents m' with
              | Some ev => match (eKind ev) with
                            | deqEvt => (ev)::nil
                            | _ => nil
                            end
              | None => nil (* this will never happen *)
             end
            )++ (prevProcessedEvents m' locEvents)
  end.

Fixpoint futureSends (start : nat) (len : nat)
  (locEvents : nat -> option EV) : list EV :=
  match len with
  | 0 => nil
  | S len' =>
      match locEvents (start + len') with
      | Some ev =>
          match (eKind ev) with
          | sendEvt => ev :: (futureSends (S start) len' locEvents)
          | deqEvt => nil (* event processing is atomic, as of now*)
          | enqEvt => (futureSends (S start) len' locEvents)
          end
      | None => nil (* this will never happen *)
       end
  end.

Definition sendsInRange  (startIncl : nat) (endIncl : nat)
  (locEvents : nat -> option EV) : list Message :=
  map eMesg (futureSends startIncl (endIncl + 1 - startIncl) locEvents).

Open Scope Q_scope.

Definition CorrectSWNodeBehaviour
    (swNode : RosSwNode)
    (locEvts: nat -> option EV) : Prop :=

  forall n: nat,
  match (locEvts n) with
  | None  => True
  | Some ev =>
      let procEvts := prevProcessedEvents (S (eLocIndex ev))locEvts in
      let procMsgs := map eMesg procEvts in
      let lastOutMsgs := getLastOutputL (process swNode) procMsgs in
      let evIndex := eLocIndex ev in

      match (eKind ev) with
        | deqEvt =>
            exists len, let sEvts := (futureSends (eLocIndex ev) len locEvts) in
                    map eMesg sEvts = lastOutMsgs
                    /\ match (rev sEvts) with
                        | hsm :: _ =>
                                (eTime hsm <
                                         (eTime ev) +
                                              (pTiming swNode (eMesg ev)))
                        | nil => True
                        end

        | sendEvt =>
          match procEvts with
          | nil => False
          | last :: _ =>
    (** NOT REQD; DERIVABLE*) In (eMesg ev) lastOutMsgs /\
              length (sendsInRange (eLocIndex last)  evIndex locEvts)
                 <= length lastOutMsgs
          end

        | enqEvt => True (* messages are always welcome. When modelling a finite sized mailbox,this may no longer be true *)
      end
  end.

Definition DeviceBehaviourCorrect
    {Env : Type}
    (physQ : Time -> Env)
    (inpDev : Device Env)
    (locEvents : nat -> option EV) : Prop :=

 inpDev physQ locEvents.

(*
Class RosMesgType (T : Type) {unm: UniqueNames T} := {
    payLoadType : T -> Type
}.
  {unm : UniqueNames MT}
  {rmt : RosMesgType MT}
    masterAndName : RT -> TCP * string;
    rtInj : InjectiveFun masterAndName;
  {deqtcp : DecEq TCP}
  {tcpad : TCPAddressType TCP}

Class TCPAddressType (T : Type) {deq : DecEq T}:= {
}.

*)

(*
Definition SimpleSwProc (inT outT : RosTopic) : Type :=
Process (topicType inT) (list (topicType outT)).

Definition SSimpleSwProc (inT outT : RosTopic) : Type :=
Process (topicType inT) (topicType outT).

CoFixpoint makeSuperSimple {inT outT : RosTopic}
  (sswp : SSimpleSwProc inT outT) : SimpleSwProc inT outT.
  constructor. intro inp.
  apply sswp in inp. repnd.
  split; [ | exact [inp]; fail].
  apply makeSuperSimple.
  trivial.
Defined.

Coercion  makeSuperSimple : SSimpleSwProc >-> SimpleSwProc.
*)

(*
Inductive RosNode : Type :=
| rsw :> RosSwNode -> RosNode
| rhi :> forall {Env : Type},
        RosInpDevNode Env -> RosNode
| rho :> forall {Env : Type},
        RosOutDevNode Env -> RosNode.

Open Scope list_scope.

Definition SubscribeTopics  (rn : RosNode) : list RosTopic
  :=
match rn with
| rsw rsn => subscribeTopics rsn
| rhi _ _ => nil
| rho _ rout =>  cons (inpTopic rout) nil
end.

Definition PublishTopics  (rn : RosNode) : list RosTopic
  :=
match rn with
| rsw rsn => publishTopics rsn
| rhi _ rinp => cons (outTopic rinp) nil
| rho _ _ =>   nil
end.

Definition TimeValuedEnvType  (rn : RosNode) : Type
  :=
match rn with
| rsw rsn => unit
| rhi Env _ => Time -> Env
| rho Env _ => Time -> Env
end.

*)

(*
Definition mkSimplePureRosProc {InTopic OutTopic}
  (f : SimplePureProcess InTopic OutTopic)
    : Process Message (list Message) :=
*)

(** There is no code to extract for devices
    These are here to model environment *)

Record RosInpDevNode (Env : Type) :=
{
  (*  IDnodeName : string; *)
    outTopic : RosTopic;
    idev :> InpDev Env  (topicType outTopic)
}.

Definition substIDev {Env : Type} (rid : RosInpDevNode Env)
  (newd : InpDev Env ((topicType (outTopic rid))))
  : RosInpDevNode Env :=
Build_RosInpDevNode
                    (outTopic rid)
                    newd.

Record RosOutDevNode (Env : Type) :=
{
    (* ODMasterAddress : TCPAddress;
    ODnodeName : string; *)
    inpTopic : RosTopic;
    odev :> OutDev Env ((topicType inpTopic))
}.

(** Implementing this will need simplification of topic definitions.
  We need decidable equality on topics, which is not currently true.
  Also, one could have 2 topics with same string name and different
  payload types

 *)

Definition getRosOutDevBhv  {Env : Type}
    (p: RosOutDevNode Env )
    (allInputs : list Message)  : OutDevBehaviour Env :=
    let filterMsgs := filterMegsByTopic allInputs (inpTopic p) in
    match filterMsgs with
    | nil => fst (odev p)
    | last :: rest => getLastOutput (snd (odev p)) rest last
    end.

Lemma RHSSafe : forall t: QTime,  (centerPosAtTime tstate t) [<=] Z2R 95.
Proof.
  intros.
  pose proof (less_cotransitive_unfolded _ (Z2R 94) (Z2R 95)) as Hdi.
  lapply Hdi; [clear Hdi; intro Hdi
                |apply inj_Q_less; unfold inject_Z; simpl; lra; fail].
  match goal with
  [|- ?l [<=] ?r] => specialize (Hdi l)
  end.
  destruct Hdi;[|apply less_leEq].
  assert False;[| contradiction].
Abort.
(** While this method works, a better one is also constructive *)

Lemma velocityMessagesEv : forall m t,
  member m (velocityMessages t)
  -> sig (fun ev=> (eMesg ev) = ((mkMesg MOTOR (fst m))::nil)
                /\ eTime ev < t
                /\ eTime ev = (snd m)
                /\ eLoc ev = BASEMOTOR
                /\ isDeqEvt ev).
Admitted.

(** not relevant for code generation,
    only relevant for reasoning *)

Section Dev.

Variable Env : Type.

(** Output devices receive messages and
    affect their environment. Examples are
    heating devices, motors in mobile robots
    like iCreate

    In our model,
    an output device receives a message and outputs
    a property about how future environment evolves.
    Note that the device can use the previous history of
    inputs.

    For example, when a roomba icreate receives
    a message with a request to go along X axis with
    speed 1m/s , the output property could be
    that the robots physical speed somewhere between
    0.9m/s and 1.1 m/s until a new message arrives
 *)
Open Scope type_scope.

Record OutDevBehaviour := {
  allowedBhv :> forall (t:RTime), (RInInterval (clcr [0] t) -> Env) -> Prop

    (* ; extendTime : forall (t1 t2 :Time)
            (ev1 : RInInterval (clcr [0] t1) -> Env) ,
            t1 [<] t2
            -> allowedBhv t1 ev1
            -> {ev2 : RInInterval (clcr [0] t2) -> Env | allowedBhv t2 ev2} *)
}.

Definition OutDev (Inp : Type) :=
  OutDevBehaviour * Process Inp OutDevBehaviour.

Definition MemoryLessOutDev (Inp : Type) :=
  OutDevBehaviour * (Inp -> OutDevBehaviour).
Close Scope type_scope.

CoFixpoint makeOutDevAux {Inp: Type}
  (m: Inp -> OutDevBehaviour)
    : Process Inp OutDevBehaviour :=
   buildP (fun inp : Inp => (makeOutDevAux  m,  m inp)).

Definition makeOutDev {Inp: Type}
  (m: MemoryLessOutDev Inp)
    : OutDev  Inp :=
  (fst m,  makeOutDevAux (snd m)).

Definition getOutDevBhv  {In : Type}
    (p: OutDev In )
    (allInputs : list In)  : OutDevBehaviour :=
    match allInputs with
    | nil => fst p
    | last :: rest => getLastOutput (snd p) rest last
    end.

Coercion makeOutDev : MemoryLessOutDev >-> OutDev.

(** An input device observes the environment over time
    and may emit messages.
    In the following model, it is a function which
    when given how environment evolved,
    either never outputs a message ([unit] case)
    our outputs a triple indicating the output message,
    time of output and a new device (possibly storing some state)

    Time is relative to the previous emitted message.
    If no message was emitted yet, time is relative to
    the instant the device (driver) was turned on.

    The reason why [InpDev] cannot be modeled
    by a software node is because unlike
    software nodes, input devices can emit
    messages even when they did not receive
    any input. Maybe we can generalize software
    nodes to do that.
*)
CoInductive InpDev (Out : Type) :=
maybeSendMesg :
      ((Time -> Env)
        -> (unit + (Out * Time * InpDev Out)))
        -> InpDev Out.

(** Input devices may receive message as instructions.
    This model is not expressive enough to capture that.

    Howver, that is not too bad. In ROS, sensors like
    kinect continuously emit and there is no control data.
 *)

Definition getIDev {Out : Type} (idv : InpDev Out ) :
((Time -> Env) -> (unit + (Out * Time * InpDev Out)))
  :=
match idv with
maybeSendMesg mmm => mmm
end.

End Dev.

(*
CoInductive StateFulProcess (In State Out : Type) :=
buildSP : (In -> State -> ((StateFulProcess In State Out)* Out))
          -> StateFulProcess In State Out.

CoFixpoint fromSFProcess {In State Out : Type} (initState : State)
  (sfp : StateFulProcess In State Out)
   : Process In Out.
constructor. intro inp.
destruct sfp.
pose proof (p inp initState) as Hsfs.
destruct Hsfs; split; [| trivial]. clear p.
eauto.
Defined.

Coercion  fromSFProcess : StateFulProcess >-> Process.
*)

Lemma restrictTill {A} (f : Time -> A)
    (right : Time) : (RInInterval (clcr [0] right)) -> A.
  intro rint.
  destruct rint.
  apply f. exists realV0.
  unfold iprop.
  unfold iprop in realVPos0.
  destruct realVPos0.
  trivial.
Defined.

Lemma fastFwd {A} (f : Time -> A)
    (duration : Time) : Time  -> A.
  intro rint.
  destruct rint.
  apply f. exists (realV0 [+] duration).
  destruct duration. simpl.
  unfold iprop.
  unfold iprop in realVPos0.
  unfold iprop in realVPos1.
  eauto with *.
Defined.

Lemma TimeDiffOprBnd : ∀ (opr : QTime),
  let t0 : QTime := MotorEventsNthTime 0 (decAuto (0<4)%nat I) in
  let t1 : QTime := MotorEventsNthTime 1 (decAuto (1<4)%nat I) in
 (Qabs.Qabs
        (opr * (t1 - t0) -
         opr *
         (Qabs.Qabs (approximate (polarTheta targetPos) anglePrec) *
          / rotspeed)) <= opr * ((1 + 1) * (sendTimeAcc + delivDelayVar)))%Q.
Proof.
  intros ? ? ?. pose proof MotorEv01Gap as Hg.
  simpl in Hg.
  fold t0 t1 in Hg.
  apply Q.Qmult_le_compat_l with (z:= Qabs.Qabs opr) in Hg;
      [|apply Qabs.Qabs_nonneg].
  rewrite <- Qabs.Qabs_Qmult in Hg. idtac.
  revert Hg.
  unfoldMC.
  intros Hg.
  rewrite foldQminus in Hg.
  rewrite  QmultOverQminusL in Hg.
  rewrite foldQminus in Hg.
  unfold CanonicalNotations.norm, NormSpace_instance_Q in Hg.
  revert Hg.
  unfoldMC.
  intros Hg.
  rewrite QabsTime in Hg.
  trivial.
Qed.

(*
Definition UIP_refl := ∀ (U:Type) (x:U) (p:x = x), p = eq_refl.
Definition VoidNat_Ext := ∀ (f g : void -> nat), f = g.

Lemma UIP_implies_not_void_ext :
  UIP_refl -> VoidNat_Ext -> False.
Proof.
  intros Huip Hvn.
  specialize (Hvn (λ x, 0) (λ x, 1)).
  specialize (Huip _ _ Hvn).
*)

Definition isVecDerivativeOf
    {n : nat} (f f' : Vector n TContR) : Type.
  revert f f'.
  induction n as [| np Hind]; intros f f';[exact unit|].
  destruct f as [fv ft].
  destruct f' as [fv' ft'].
  exact ((isDerivativeOf ft ft') × (Hind fv fv')).
Defined.

(*
Lemma XChangeUBEv2To3_2 :
  let t3 : QTime := MotorEventsNthTime 3 (decAuto (3<4)%nat I) in
  let t2 : QTime := MotorEventsNthTime 2 (decAuto (2<4)%nat I) in

   ({X rotOrigininPos} t3 [-] {X rotOrigininPos} t2)
      ≤  (Ev23TimeGapUB * (speed + transErrTrans)%Q).
Proof.
  intros.
  pose proof (XChangeUBEv2To3) as Hyd.
  cbv zeta in Hyd.
  eapply leEq_transitive;[apply Hyd|].
  fold t2 t3. clear Hyd.
  unfold Q2R. rewrite inj_Q_mult.
  apply mult_resp_leEq_rht;[apply MotorEv23Gap2_3; fail|].
  eauto 2 with CoRN ROSCOQ.
Qed.
*)

(*
Lemma ThetaConstFunSin :  IContREqInIntvl
                          Ev2To3Interval
                            ((linVel icreate)[*]CFSine (theta icreate))
                            ((ContConstFun _ _ (Sin θ2)) [*] (linVel icreate)).
Proof.
  intros t Hb.
  rewrite TContRMult, TContRMult, CFSineAp.
  rewrite mult_commutes.
  apply mult_wdl.
  apply pfwdef.
  simpl. eapply TContRR2QCompactIntEq2; eauto.
  apply OmegaThetaEv2To3.
  unfold inBounds, Ev2To3Interval in Hb.
  simpl in Hb.   rewrite <- QT2T_Q2R, <- QT2T_Q2R in Hb.
  assumption.
Qed.

Lemma ThetaConstFunCos :  IContREqInIntvl
                          Ev2To3Interval
                            ((linVel icreate)[*]CFCos (theta icreate))
                            ((ContConstFun _ _ (Cos θ2)) [*] (linVel icreate)).
Proof.
  intros t Hb.
  rewrite TContRMult, TContRMult, CFCosAp.
  rewrite mult_commutes.
  apply mult_wdl.
  apply pfwdef.
  simpl. eapply TContRR2QCompactIntEq2; eauto.
  apply OmegaThetaEv2To3.
  unfold inBounds, Ev2To3Interval in Hb.
  simpl in Hb.   rewrite <- QT2T_Q2R, <- QT2T_Q2R in Hb.
  assumption.
Qed.

Lemma PosPosAtEV3 :
  let t3 : QTime := MotorEventsNthTime 3 (decAuto (3<4)%nat I) in
  posAtTime t3 = {|X := distTraveled * (Cos θ2);
                            Y := distTraveled * (Sin θ2) |}.
Proof.
  pose proof (TBarrowEta (derivX icreate) Ev2To3Interval) as HX.
  pose proof ThetaConstFunCos as Heq.
  apply Cintegral_wd2 in Heq.
  rewrite Heq in HX.
  simpl scs_elem in HX.
  unfold fst, snd in HX.
  clear Heq.
  rewrite CIntegral_scale in HX.
  fold distTraveled in HX.
  pose proof (TBarrowEta (derivY icreate) Ev2To3Interval) as HY.
  pose proof ThetaConstFunSin as Heq.
  apply Cintegral_wd2 in Heq.
  rewrite Heq in HY.
  simpl scs_elem in HY.
  unfold fst, snd in HY.
  clear Heq.
  rewrite CIntegral_scale in HY.
  fold distTraveled in HY.
  pose proof (TransVelPosAtEV2
      (MotorEventsNthTime 2 (decAuto (2 < 4)%nat I))) as H2.
  unfold le, Le_instance_QTime in H2.
  DestImp H2;
    [|split; [apply MotorEventsNthTimeInc; omega| lra]].
  repnd.
  unfold posAtTime in H2r.
  unfold equiv, EquivCart in H2r.
  simpl in H2r. repnd.
  rewrite H2rl in HX.
  rewrite H2rr in HY.
  clear H2rr H2rl.
  destruct (initPos icreate) as [Hx Hy].
  setoid_rewrite Hx in HX.
  setoid_rewrite Hy in HY.
  clear Hx Hy.
  intros ?.
  fold t3 in HX, HY.
  unfold zero, Zero_instance_IR, cg_minus in HX, HY.
  ring_simplify in HX.
  ring_simplify in HY.
  unfold posAtTime, equiv, EquivCart.
Local Opaque Sin Cos.
  simpl.
  rewrite <- HX, <- HY.
  unfoldMC. unfold Mult_instance_IR.
  split; ring.
Qed.

Lemma normSqrQ : ∀ (q : Cart2D Q),
  (' (X q))[^]2 [+] (' (Y q))[^]2
  [=] ('(|q|))[^]2.
Proof.
  intros q.
  unfold CanonicalNotations.norm, NormSpace_instance_Cart2D.
  unfold cast, Cart_CR_IR, Cast_instace_Q_IR.
  unfold sqrtFun, rational_sqrt_SqrtFun_instance.
  rewrite rational_sqrt_correct.
  rewrite IRasCRasIR_id.
  rewrite sqrt_sqr. rewrite <- inj_Q_power, <- inj_Q_power.
  rewrite <- inj_Q_plus.
  apply inj_Q_wd.
  simpl. unfoldMC. reflexivity.
Grab Existential Variables.
  rewrite <- inj_Q_Zero.
  apply inj_Q_leEq.
  unfoldMC. pose proof (cc_abs_aid _ (X q) (Y q)) as HH.
  simpl in HH.
  simpl. lra.
Qed.

(*
Lemma ABCSqrRW : ∀ d X Y: IR,
d[^]2 [+] X[^]2 [+] Y[^]2 =
(d [-] NRootIR.sqrt (X[^]2 [+] Y[^]2) _ )[^]2
  [+] 2[*] NRootIR.sqrt (X[^]2 [+] Y[^]2) _.
*)

Local Opaque nexp_op.
Require Import  MathClasses.interfaces.additional_operations.

Lemma XDistEV3 :
  let t3 : QTime := MotorEventsNthTime 3 (decAuto (3<4)%nat I) in
  (distSqr (posAtTime t3) targetPosR) =
      (distTraveled - ('|targetPos |)) ^ 2
      + 2 * distTraveled *('|targetPos |) * (1 - Cos (optimalTurnAngle - θ2)).
Proof.
  simpl. rewrite PosPosAtEV3.
  unfold targetPosR, cast, castCart.
  unfold distSqr.
  unfold canonical_names.negate, Negate_instance_Cart2D
      ,plus, Plus_instance_Cart2D.
  simpl. unfold normSqr.
  simpl.
  unfoldMC. fold zero. autounfold with IRMC.
  remember (' X targetPos) as Xt.
  remember (' Y targetPos) as Yt.
  remember (Cos θ2) as ct.
  remember (Sin θ2) as st.
  remember distTraveled as dt.

  match goal with
  [ |- ( ?x [=] _) ] => assert (x
      [=] (dt[*]dt)[*](ct[*]ct [+] st[*]st)
          [+] (Xt[*]Xt [+] Yt[*]Yt)
          [-] ([1] [+] [1]) [*]dt[*](Xt[*]ct [+] Yt[*]st)) as Heq
  end.
  unfold cg_minus. ring.
  rewrite Heq. clear Heq.
  subst ct st.
  repeat (rewrite <- nexp_two).
  rewrite FFT.
  rewrite mult_one.
  rewrite HeqXt at 1.
  rewrite HeqYt at 1.
  rewrite normSqrQ.
  rewrite <- squareMinusIR2.
  fold (normSqr targetPosR).
  unfold cg_minus. rewrite <- plus_assoc_unfolded.
  unfold nat_pow.nat_pow_peano, peano_naturals.nat_1.
  unfold pow.
  unfoldMC. unfold One_instance_IR. rewrite mult_one.
  rewrite <- nexp_two.
  apply plus_resp_eq.
  rewrite one_plus_one.

  pose proof (CartToPolarToXIR targetPos) as Ht.
  simpl in Ht.
  unfold castCart in Ht.
  unfold equiv, EquivCart in Ht.
  simpl in Ht.
  repnd.
  rewrite <- HeqXt in Htl.
  rewrite <- HeqYt in Htr.
  rewrite Htr, Htl.
  Replace (' polarTheta targetPos [=] optimalTurnAngle).
  unfoldMC. unfold Mult_instance_IR.
  remember (' (|targetPos |)) as tp.

  match goal with
  [ |- ( ?x [=] _) ] => assert (x
      [=] Two[*]dt[*] tp [*] ([1] [-] (Cos optimalTurnAngle[*]Cos θ2[+] Sin optimalTurnAngle[*]Sin θ2))) as Heq
  end.
  unfoldMC. unfold cg_minus. ring.
  rewrite Heq. rewrite <- Cos_minus.
  unfold One_instance_IR.
  unfold cg_minus.
  subst tp. unfold cast.
  ring.
Qed.
*)
(*
Lemma TransVelPosAtEV3 :
  let t0 : QTime := MotorEventsNthTime 2 (decAuto (2<4)%nat I) in
  let t1 : QTime := MotorEventsNthTime 3 (decAuto (3<4)%nat I) in
  ∀ (t : QTime),  t0 ≤ t ≤ t1
      → t1 ≤ t ≤ t0.
Proof.
  intros ? ? ? Hle.
  unfold le, Le_instance_QTime in Hle.
  pose proof correctVel2to3 as Hc.
  simpl in Hc. fold t0 t1 in Hc.
  unfold correctVelDuring in Hc.
  apply proj1 in Hc. simpl rad in Hc.
  match type of Hc with
  context[changesTo _ _ _ (Q2R ?nv) _ (QT2Q ?om)]
    => remember om as opr
  end.
  assert ((t0 + reacTime < t1)%Q)
    as Hassumption by (apply MotorEventsNthTimeReac; omega).
  pose proof (qtimePos reacTime) as H99.
  (** multiply by the constant cos theta in Hc *)
  apply changesToDerivInteg2
    with (F:=(theta icreate)) (oldVal:=0) in Hc;
    eauto with ICR.
  clear H99.
Abort.
  rewrite initTheta in Ht0r.
  rewrite Ht0r in Hc.
  rewrite Ht0l in Hc.
  rewrite  (AbsIR_minus 0)  in Hc .
  rewrite cg_inv_zero in Hc.
  rewrite IR_inv_Qzero in Hc.
  rewrite AbsIRNewOmega in Hc.
  pose proof MotorEv01Gap2 as Hg.
  Local Opaque Qabs.Qabs.
  simpl in Hg.
  fold t0 t1 in Hg.
  apply (inj_Q_leEq IR) in Hg.
  rewrite <- AbsIR_Qabs in Hg.
  rewrite inj_Q_minus in Hg.
  rewrite <- inj_Q_mult in Hc.
  Local Opaque Qmult AbsIR.
  simpl in Hc.
  rewrite Qmult_comm in Hc.
  apply AbsIR_imp_AbsSmall in Hg.
  apply AbsIR_imp_AbsSmall in Hc.
  pose proof (AbsSmall_plus _ _ _ _ _ Hc Hg) as Hadd.
  fold (newVal) in Hadd.

  unfold Q2R in Hadd. ring_simplify in Hadd.
  unfold cg_minus in Hadd. ring_simplify in Hadd.
  clear Hg Hc.
  revert Hadd.
  unfoldMC. intro Hadd. unfold QT2R in Hadd.
  unfold Q2R in Hadd.
  Local Opaque inj_Q.
  autorewrite with QSimpl in Hadd. simpl in Hadd.
  match type of Hadd with
  AbsSmall (inj_Q _ ?r%Q) _ => assert (r == rotspeed * (2 * (sendTimeAcc + delivDelayVar) + reacTime) + opr * (t1 - t0))%Q
                                    as Heqq by (unfoldMC ;ring); rewrite Heqq in Hadd; clear Heqq
  end.
  pose proof (approximateAbsSmallIR (polarTheta targetPos) anglePrec) as Hball.
  apply AbsSmall_minus in Hball.
  pose proof (AbsSmall_plus _ _ _ _ _  Hadd Hball) as Haddd.
  clear Hball Hadd. rename Haddd into Hadd.
  fold (optimalTurnAngle) in Hadd.
  unfold Q2R, cg_minus in Hadd.
  ring_simplify in Hadd.
  rewrite <- inj_Q_plus in Hadd.
  subst opr.
  unfold Le_instance_IR.
  simpl in Hadd.
  apply AbsSmall_imp_AbsIR in Hadd.
  eapply leEq_transitive;[apply Hadd|].
  apply eqImpliesLeEq.
  apply inj_Q_wd.
  simpl. unfoldMC. ring.
*)


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)

(*| .. coq:: none |*)
Require Import Lia.
(*| .. coq::  |*)

(*|
Natural numbers
===============

The following extends some results from Coq natural numbers and the :coq:`PeanoNat.Nat` module.

|*)

(*| .. coq:: none |*)
Section PeanoNat_Nat_Ext.
(*| .. coq:: |*)

(*|
.. index:: zero_or_succ_positive, CoqExt; zero_or_succ_positive

* :coq:`zero_or_succ_positive` is a variant of :coq:`PeanoNat.Nat.zero_or_succ` to simplify our proofs.

|*)

Lemma zero_or_succ_positive: forall n : nat,
    n > 0 -> exists m, n = S m.
Proof.
    intros.
    assert (n = 0 \/ exists m, n = S m).
    apply PeanoNat.Nat.zero_or_succ.
    destruct H0.
    contradict H. lia.
    trivial.
Qed.

(*|
.. index:: nat_split, CoqExt; nat_split

* :coq:`nat_plit` is a technical trivial lemma to split a natural number that is known to be higher than another.

|*)

Lemma nat_split: forall n m: nat,
    n > m -> exists p, n = m + p.
Proof.
    intros.
    exists (n - m) ; lia.
Qed.

(*| .. coq:: none |*)
End PeanoNat_Nat_Ext.
(*| .. coq::  |*)


From caml5 Require Import
  prelude.
From caml5.lang Require Import
  notations
  proofmode.
From caml5.std Require Export
  base.
From caml5.std Require Import
  lst.

Record stack `{!heapGS Σ} {unboxed : bool} := {
  stack_make : val ;
  stack_is_empty : val ;
  stack_push : val ;
  stack_pop : val ;

  stack_model : val → list val → iProp Σ ;

  stack_model_timeless t vs :
    Timeless (stack_model t vs) ;

  stack_make_spec :
    {{{ True }}}
      stack_make #()
    {{{ t, RET t; stack_model t [] }}} ;

  stack_is_empty_spec t vs :
    {{{ stack_model t vs }}}
      stack_is_empty t
    {{{ RET #(bool_decide (vs = [])); stack_model t vs }}} ;

  stack_push_spec t vs v :
    {{{ stack_model t vs }}}
      stack_push t v
    {{{ RET #(); stack_model t (v :: vs) }}} ;

  stack_pop_spec t vs :
    {{{ stack_model t vs }}}
      stack_pop t
    {{{ o,
      RET o;
      (⌜vs = [] ∧ o = NONEV⌝ ∗ stack_model t []) ∨
      (∃ v vs', ⌜vs = v :: vs' ∧ o = SOMEV v⌝ ∗ stack_model t vs')
    }}} ;

    stack_unboxed :
      if unboxed then ∀ t vs,
        stack_model t vs -∗
        ⌜val_is_unboxed t⌝
      else
        True ;
}.
#[global] Arguments stack _ {_} _ : assert.
#[global] Arguments Build_stack {_ _} _ {_ _ _ _ _ _} _ _ _ _ _ : assert.
#[global] Existing Instance stack_model_timeless.

Section std_stack.
  Context `{!heapGS Σ}.
  Implicit Types l : loc.
  Implicit Types v t lst : val.

  Definition std_stack_make : val :=
    λ: <>,
      ref lst_nil.

  Definition std_stack_is_empty : val :=
    λ: "t",
      lst_is_empty !"t".

  Definition std_stack_push : val :=
    λ: "t" "v",
      "t" <- lst_cons "v" !"t".

  Definition std_stack_pop : val :=
    λ: "t",
      let: "lst" := !"t" in
      if: lst_is_empty "lst" then (
        NONE
      ) else (
        "t" <- lst_tail "lst" ;;
        SOME (lst_head "lst")
      ).

  Definition std_stack_model t vs : iProp Σ :=
    ∃ l lst, ⌜t = #l⌝ ∗ l ↦ lst ∗ lst_model lst vs.

  #[global] Instance std_stack_model_timeless t vs :
    Timeless (std_stack_model t vs).
  Proof.
    apply _.
  Qed.

  Lemma std_stack_make_spec :
    {{{ True }}}
      std_stack_make #()
    {{{ t, RET t; std_stack_model t [] }}}.
  Proof.
    iIntros "%Φ _ HΦ".
    wp_rec. wp_alloc l as "Hl".
    iApply "HΦ". iExists l, lst_nil. iFrame. iSplitL; first done. iApply lst_nil_spec.
  Qed.

  Lemma std_stack_is_empty_spec t vs :
    {{{ std_stack_model t vs }}}
      std_stack_is_empty t
    {{{ RET #(bool_decide (vs = [])); std_stack_model t vs }}}.
  Proof.
    iIntros "%Φ (%l & %lst & -> & Hl & #Hlst) HΦ".
    wp_rec. wp_load.
    wp_apply (lst_is_empty_spec with "Hlst"). iIntros "_".
    iApply "HΦ". iExists l, lst. naive_solver.
  Qed.

  Lemma std_stack_push_spec t vs v :
    {{{ std_stack_model t vs }}}
      std_stack_push t v
    {{{ RET #(); std_stack_model t (v :: vs) }}}.
  Proof.
    iIntros "%Φ (%l & %lst & -> & Hl & #Hlst) HΦ".
    wp_rec. wp_load.
    wp_apply (lst_cons_spec with "Hlst"). iIntros "%lst' #Hlst'".
    wp_store.
    iApply "HΦ". iExists l, lst'. naive_solver.
  Qed.

  Lemma std_stack_pop_spec t vs :
    {{{ std_stack_model t vs }}}
      std_stack_pop t
    {{{ o,
      RET o;
      (⌜vs = [] ∧ o = NONEV⌝ ∗ std_stack_model t []) ∨
      (∃ v vs', ⌜vs = v :: vs' ∧ o = SOMEV v⌝ ∗ std_stack_model t vs')
    }}}.
  Proof.
    iIntros "%Φ (%l & %lst & -> & Hl & #Hlst) HΦ".
    wp_rec. wp_load. wp_pures.
    wp_apply (lst_is_empty_spec with "Hlst"). iIntros "_".
    destruct vs as [| v vs]; wp_pures.
    - iApply "HΦ". iLeft. repeat iSplitR; try done.
      iExists l, lst. naive_solver.
    - wp_apply (lst_tail_spec with "Hlst"); first done. iIntros "%lst' #Hlst'".
      wp_store.
      wp_apply (lst_head_spec with "Hlst"); first done. iIntros "_".
      wp_pures.
      iApply "HΦ". iRight. iExists v, vs. repeat iSplitR; try done.
      iExists l, lst'. naive_solver.
  Qed.

  Lemma std_stack_unboxed t vs :
    std_stack_model t vs -∗
    ⌜val_is_unboxed t⌝.
  Proof.
    iIntros "(%l & %lst & -> & Hl & #Hlst) //".
  Qed.

  Definition std_stack :=
    Build_stack true
      std_stack_make_spec
      std_stack_is_empty_spec
      std_stack_push_spec
      std_stack_pop_spec
      std_stack_unboxed.
End std_stack.

#[global] Opaque std_stack_make.
#[global] Opaque std_stack_is_empty.
#[global] Opaque std_stack_push.
#[global] Opaque std_stack_pop.

#[global] Opaque std_stack_model.


Require Import
  MathClasses.interfaces.canonical_names MathClasses.misc.util.

Class Decision P := decide: sumbool P (¬P).
Arguments decide _ {Decision}.

Instance: ∀ P, Decision P → Stable P.
Proof. firstorder. Qed.

Ltac case_decide := match goal with
  | H : context [@decide ?P ?dec] |- _ => case (@decide P dec) in *
  | |- context [@decide ?P ?dec] => case (@decide P dec) in *
  end.

Ltac solve_trivial_decision :=
  match goal with
  | [ |- Decision (?P) ] => apply _
  | [ |- sumbool ?P (¬?P) ] => change (Decision P); apply _
  end.

Ltac solve_decision :=
  first [solve_trivial_decision | unfold Decision; decide equality; solve_trivial_decision].

(* We cannot state this as Proper (iff ==> iffT) Decision due to the lack of setoid rewriting in Type *)
Program Definition decision_proper (P Q : Prop) (PiffQ : P ↔ Q) (P_dec : Decision P) : Decision Q :=
  match P_dec with
  | left _ => left _
  | right _ => right _
  end.
Solve Obligations with (program_simpl; tauto).

Definition bool_decide (P : Prop) `{dec : !Decision P} : bool := if dec then true else false.

Lemma bool_decide_true `{dec : Decision P} : bool_decide P ≡ true ↔ P.
Proof. unfold bool_decide. split; intro; destruct dec; firstorder. Qed.

Lemma bool_decide_false `{dec : !Decision P} : bool_decide P ≡ false ↔ ¬P.
Proof. unfold bool_decide. split; intro; destruct dec; firstorder. Qed.

(*
  Because [vm_compute] evaluates terms in [Prop] eagerly and does not remove dead code we
  need the decide_rel hack. Suppose we have [(x = y) =def  (f x = f y)], now:
     bool_decide (x = y) → bool_decide (f x = f y) → ...
  As we see, the dead code [f x] and [f y] is actually evaluated, which is of course an utter waste.
  Therefore we introduce decide_rel and bool_decide_rel.
     bool_decide_rel (=) x y → bool_decide_rel (λ a b, f a = f b) x y → ...
  Now the definition of equality remains under a lambda and our problem does not occur anymore!
*)

Definition decide_rel `(R : A → B → Prop) {dec : ∀ x y, Decision (R x y)} (x : A) (y : B) : Decision (R x y)
  := dec x y.

Definition bool_decide_rel `(R : relation A) {dec : ∀ x y, Decision (R x y)} : A → A → bool
  := λ x y, if dec x y then true else false.

Lemma bool_decide_rel_true `(R : relation A) {dec : ∀ x y, Decision (R x y)} :
  ∀ x y, bool_decide_rel R x y ≡ true ↔ R x y.
Proof. unfold bool_decide_rel. split; intro; destruct dec; firstorder. Qed.

Lemma bool_decide_rel_false `(R : relation A)`{dec : ∀ x y, Decision (R x y)} :
  ∀ x y, bool_decide_rel R x y ≡ false ↔ ¬R x y.
Proof. unfold bool_decide_rel. split; intro; destruct dec; firstorder. Qed.

Program Definition decision_from_bool_decide {P b} (prf : b ≡ true ↔ P) :
  Decision P := match b with true => left _ | false => right _ end.
Next Obligation. now apply prf. Qed.
Next Obligation. rewrite <-prf. discriminate. Qed.

Program Instance prod_eq_dec `(A_dec : ∀ x y : A, Decision (x ≡ y))
     `(B_dec : ∀ x y : B, Decision (x ≡ y)) : ∀ x y : A * B, Decision (x ≡ y) := λ x y,
  match A_dec (fst x) (fst y) with
  | left _ => match B_dec (snd x) (snd y) with left _ => left _ | right _ => right _ end
  | right _ => right _
  end.
Solve Obligations with (program_simpl; f_equal; firstorder).

Program Instance and_dec `(P_dec : Decision P) `(Q_dec : Decision Q) : Decision (P ∧ Q) :=
  match P_dec with
  | left _ => match Q_dec with left _ => left _ | right _ => right _ end
  | right _ => right _
  end.
Solve Obligations with (program_simpl; tauto).

Program Instance or_dec `(P_dec : Decision P) `(Q_dec : Decision Q) : Decision (P ∨ Q) :=
  match P_dec with
  | left _ => left _
  | right _ => match Q_dec with left _ => left _ | right _ => right _ end
  end.
Solve Obligations with (program_simpl; firstorder).

Program Instance is_Some_dec `(x : option A) : Decision (is_Some x) :=
  match x with
  | None => right _
  | Some _ => left _
  end.

Program Instance is_None_dec `(x : option A) : Decision (is_None x) :=
  match x with
  | None => left _
  | Some _ => right _
  end.

Program Instance option_eq_dec `(A_dec : ∀ x y : A, Decision (x ≡ y))
     : ∀ x y : option A, Decision (x ≡ y) := λ x y,
  match x with
  | Some r =>
    match y with
    | Some s => match A_dec r s with left _ => left _ | right _ => right _ end
    | None => right _
    end
  | None =>
    match y with
    | Some s => right _
    | None => left _
    end
  end.

Program Instance True_dec: Decision True := left _.
Program Instance False_dec: Decision False := right _.


(* Default settings (from HsToCoq.Coq.Preamble) *)

Generalizable All Variables.

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

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Converted imports: *)

Require Coq.Numbers.BinNums.
Require Data.Bits.
Require Data.Foldable.
Require Data.IntSet.Internal.
Require GHC.Base.
Require GHC.Num.
Import Data.Bits.Notations.
Import GHC.Base.Notations.
Import GHC.Num.Notations.

(* No type declarations to convert. *)

(* Converted value declarations: *)

Fixpoint commonPrefix (t : Data.IntSet.Internal.IntSet) : bool
  := let sharedPrefix
      : Data.IntSet.Internal.Prefix -> Coq.Numbers.BinNums.N -> bool :=
       fun p a => p GHC.Base.== (p Data.Bits..&.(**) a) in
     match t with
     | Data.IntSet.Internal.Nil => true
     | Data.IntSet.Internal.Tip _ _ => true
     | (Data.IntSet.Internal.Bin p _ l r as b) =>
         andb (Data.Foldable.all (sharedPrefix p) (Data.IntSet.Internal.elems b)) (andb
               (commonPrefix l) (commonPrefix r))
     end.

Fixpoint maskPowerOfTwo (t : Data.IntSet.Internal.IntSet) : bool
  := match t with
     | Data.IntSet.Internal.Nil => true
     | Data.IntSet.Internal.Tip _ _ => true
     | Data.IntSet.Internal.Bin _ m l r =>
         andb (Utils.Containers.Internal.BitUtil.bitcount #0 (m) GHC.Base.== #1) (andb
               (maskPowerOfTwo l) (maskPowerOfTwo r))
     end.

Fixpoint maskRespected (t : Data.IntSet.Internal.IntSet) : bool
  := match t with
     | Data.IntSet.Internal.Nil => true
     | Data.IntSet.Internal.Tip _ _ => true
     | Data.IntSet.Internal.Bin _ binMask l r =>
         andb (Data.Foldable.all (fun x => Data.IntSet.Internal.zero x binMask)
               (Data.IntSet.Internal.elems l)) (andb (Data.Foldable.all (fun x =>
                                                                           negb (Data.IntSet.Internal.zero x binMask))
                                                      (Data.IntSet.Internal.elems r)) (andb (maskRespected l)
                                                                                (maskRespected r)))
     end.

Definition nilNeverChildOfBin : Data.IntSet.Internal.IntSet -> bool :=
  fun t =>
    let fix noNilInSet t'
      := match t' with
         | Data.IntSet.Internal.Nil => false
         | Data.IntSet.Internal.Tip _ _ => true
         | Data.IntSet.Internal.Bin _ _ l' r' => andb (noNilInSet l') (noNilInSet r')
         end in
    match t with
    | Data.IntSet.Internal.Nil => true
    | Data.IntSet.Internal.Tip _ _ => true
    | Data.IntSet.Internal.Bin _ _ l r => andb (noNilInSet l) (noNilInSet r)
    end.

Definition validTipPrefix : Data.IntSet.Internal.Prefix -> bool :=
  fun p => (#63 Data.Bits..&.(**) p) GHC.Base.== #0.

Fixpoint tipsValid (t : Data.IntSet.Internal.IntSet) : bool
  := match t with
     | Data.IntSet.Internal.Nil => true
     | (Data.IntSet.Internal.Tip p b as tip) => validTipPrefix p
     | Data.IntSet.Internal.Bin _ _ l r => andb (tipsValid l) (tipsValid r)
     end.

Definition valid : Data.IntSet.Internal.IntSet -> bool :=
  fun t =>
    andb (nilNeverChildOfBin t) (andb (maskPowerOfTwo t) (andb (commonPrefix t)
                                                               (andb (maskRespected t) (tipsValid t)))).

(* External variables:
     andb bool false negb true Coq.Numbers.BinNums.N Data.Bits.op_zizazi__
     Data.Foldable.all Data.IntSet.Internal.Bin Data.IntSet.Internal.IntSet
     Data.IntSet.Internal.Nil Data.IntSet.Internal.Prefix Data.IntSet.Internal.Tip
     Data.IntSet.Internal.elems Data.IntSet.Internal.zero GHC.Base.op_zeze__
     GHC.Num.fromInteger Utils.Containers.Internal.BitUtil.bitcount
*)