(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext ssrnat_ext.
Require Import machine_int.
Import MachineInt.
Require Import mips_seplog.
Require Import goto sgoto sgoto_hoare.

Local Close Scope Z_scope.
Local Close Scope positive_scope.
Local Open Scope mips_expr_scope.

Module Import sgoto_hoare_m := SGoto_Hoare WMIPS_Hoare.
Import sgoto_m.
Import goto_deter_m.
Import goto_m.
Import assert_m.
Import expr_m.

Local Open Scope sgoto_scope.
Local Open Scope sgoto_hoare_scope.
Local Open Scope machine_int_scope.
Local Open Scope eqmod_scope.

Module SumOfFirstNaturals.

(** printing `< %\ensuremath{<}% *)
(** printing `<= %\ensuremath{\leq}% *)
(** printing `+ %\ensuremath{\boxplus}% *)
(** printing one16 %\ensuremath{1_{16}}% *)
(** printing one32 %\ensuremath{1_{32}}% *)
(** printing zero32 %\ensuremath{0_{32}}% *)

(** printing =m %\ensuremath{=}% *)
(** printing {{ %\ensuremath{[}% *)
(** printing }} %\ensuremath{]}% *)

(** * Example: The Sum of the n First Naturals *)

(** %\label{sec:example}%

   %\noindent% This example corresponds to Section 4.3 in %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#. The main difference is that the program is shown to compute its result %{\em modulo $2^{32}$}%#modulo 2^32#, which is not the case with the archetypal assembly language of %\cite{saabasuustalu2007}%#[Saabas&Uustalu2007]#. *)

(** We first define registers to hold an intermediate value
  %\coqdocvar{x}%#x#, the output %\coqdocvar{r}%#r#, and the input
  %\coqdocvar{n}%#n#. Since registers have a finite size, the number of
  values that can be represented is limited. *)

Definition x := reg_t0.
Definition r := reg_t1.
Definition n := reg_t2.

(** The program consists of the following four labeled instructions: *)

Definition i1 := sB 1 (cjmp (beq x n) 5).
Definition i2 := sC 2 (addiu x x one16).
Definition i3 := sC 3 (addu r x r).
Definition i4 := sB 4 (jmp 1).
Definition prg : scode := i1 [+] ((i2 [+] i3) [+] i4).

(** The pre-condition is as follows. The output value %\coqdocvar{r}%#r# is initialized to 0
and the input value is expected to be positive (which actually holds naturally when registers' contents are regarded as unsigned). *)

Definition I1 : assn := fun pc => fun s h => pc = 1 /\ zero32 `<= [n]_s /\ [x]_s = zero32 /\ [r]_s = zero32.

(** The post-condition is as follows. The intermediate value %\coqdocvar{x}%#x# (repeatedly incremented during execution) is expected to be equal to the input value %\coqdocvar{n}%#n# and the output value is exepected to be equal to the sum of the $n$#n# first naturals %{\em modulo $2^{32}$}%#modulo 2^32#. The non-modulo equality cannot be achieved in practice because of potential arithmetic overflows. %\coqdoccst{u2Z}%#u2Z# is a function that interprets a finite-size integer as unsigned and returns its decimal value. *)

Local Open Scope zarith_ext_scope.

Definition I5' : assn := fun pc => fun s h => pc = 5 /\
  [x]_s = [n]_s /\ u2Z [r]_s =m Zisum (u2Z [x]_s) {{2^^32}}.

Definition I1' : assn := fun pc => fun s h => pc = 1 /\
  [x]_s `<= [n]_s /\
  u2Z [r]_s =m Zisum (u2Z [x]_s) {{ 2^^32 }}.

Definition I2 : assn := fun pc => fun s h => pc = 2 /\
  [x]_s `< [n]_s /\
  [x]_s `<= [n]_s /\
  u2Z [r]_s =m Zisum (u2Z [x]_s) {{ 2^^32 }}.

(** The correctness proof consists of the application of the rules of the Hoare logic for %\sgoto%#SGoto#. For the purpose of presentation, this proof can be decomposed in a sequence of basic steps, each consisting of the application of a single rule of the Hoare logic. For example, the following step shows that the addition of the intermediate value really corresponds to compute and add the next natural. *)

Definition I2' : assn := fun pc => fun s h => pc = 2 /\
  [x]_s `< [n]_s /\ u2Z [r]_s =m Zisum (u2Z [x]_s) {{ 2^^32 }}.

Definition I2'' : assn := fun pc => fun s h => pc = 2 /\
  [x]_s `+ one32 `<= [n]_s /\
  u2Z [r]_s + u2Z ([x]_s `+ one32) =m Zisum (u2Z ([x]_s `+ one32)) {{2^^32}}.

Definition I3 : assn := fun pc => fun s h => pc = 3 /\ [x]_s `<= [n]_s /\
  u2Z ([x]_s `+ [r]_s) =m Zisum (u2Z [x]_s) {{2^^32}}.

Definition I4 : assn := fun pc => fun s h => pc = 4 /\
  [x]_s `<= [n]_s /\
  u2Z [r]_s =m Zisum (u2Z [x]_s) {{2^^32}}.

Definition I5 : assn := fun pc => fun s h => pc = 5 /\
  ~ [x]_s `< [n]_s /\
  [x]_s `<= [n]_s /\
  u2Z [r]_s =m Zisum (u2Z [x]_s) {{2^^32}}.

Local Open Scope  mips_assert_scope.

Definition I1'24 := fun pc => I1' pc \\// (I2 pc \\// I4 pc).

Definition I1'25 : assn := fun pc => I1' pc \\// (I2 pc \\// I5 pc).

Definition I2'34 : assn := fun pc => I2' pc \\// (I3 pc \\// I4 pc).

Definition I25 : assn := fun pc => fun s h => I2 pc s h \/ I5 pc s h.

Definition J1' : assn := fun pc => fun s h =>
  pc = 1 /\
     (~~ eval_b (beq x n) s /\ I25 (S 1) s h
     \/
     (eval_b (beq x n) s) /\ (I25 5 s h \/ 5 = 1))
  \/
  pc <> 1 /\ I25 pc s h .

Definition J2'' : assn := fun pc => fun s h =>
  pc = 2 /\ (wp0 (addiu x x one16) (I3 3)) s h
  \/
  pc <> 2 /\ I3 pc s h.

Definition J3 : assn := fun pc => fun s h =>
  pc = 3 /\ (wp0 (addu r x r) (I4 4)) s h
  \/
  pc <> 3 /\ I4 pc s h.

Definition J4 : assn := fun pc => fun s h =>
  pc = 4 /\ (I1' 1 s h \/ 1 = 4)
  \/
  pc <> 4 /\ I1' pc s h.

Lemma step_20 : [^ J2'' ^] i2 [^ I3 ^].
Proof. rewrite /J2'' /i2. by apply hoare_cmd. Qed.

Lemma step_19 : [^ J2'' ^] i2 [^ I3 ^] -> [^ I2'' ^] i2 [^ I3 ^].
Proof.
move=> H; eapply hoare_sgoto_conseq; eauto => l s h.
- rewrite /I2'' /J2''.
  case=> H1 [H2 H3]; subst l; left; split; first by [].
  rewrite /wp0 /wp_addiu /I3; split; first by [].
  rewrite store.get_upd' // !store.get_upd // /one16 /one32 sext_Z2u //.
  split; first by [].
  eapply eqmod_trans; first by apply u2Z_add_eqmod.
  by rewrite addZC.
- by apply hoare_prop_m.entails_id.
Qed.

Local Open Scope Z_scope.

Lemma step_18 :  [^ I2'' ^] i2 [^ I3 ^] -> [^ I2' ^] i2 [^ I3 ^].
Proof.
move=> H; eapply hoare_sgoto_conseq; eauto => l s h.
- rewrite /I2' /I2''.
  case=> ? [x_lt_n Hr]; subst l; split; first by [].
  split; first exact: add_n_lt_n.
  eapply eqmod_trans.
  + eapply eqmod_compat_plus_R; by apply Hr.
  + apply lt_n2Zlt in x_lt_n.
    have X : u2Z [x]_s < 2 ^^ 32 - 1 by move: (max_u2Z [n]_s) => ?; lia.
    case: (Z_lt_le_dec (u2Z [x]_s + u2Z one32) (2 ^^ 32)) => Y.
    * rewrite u2Z_add // Z2uK // Zisum_prop.
      by apply eqmod_refl.
      by apply min_u2Z.
    * rewrite Z2uK // in Y.
      have : ~ (2 ^^ 32 <= u2Z [x]_s + 1) by lia.
      tauto.
- by apply hoare_prop_m.entails_id.
Qed.

Local Close Scope Z_scope.
Local Close Scope zarith_ext_scope.

Lemma step_17 : [^ I2' ^] i2 [^ I3 ^] ->
  [^ restrict I2'34 (sdom i2) ^] i2 [^ I2'34 ^].
Proof.
move=> H; eapply hoare_sgoto_conseq; eauto => l s h.
- rewrite /restrict /while.And /I2'34 /I2' /=.
  case=> X [H0 | H0 //].
  split; first by done.
  case: X => [X | [ [H1 H3] | [H1 H4] ] ].
  * tauto.
  * by subst l.
  * by subst l.
- rewrite /I3 /I2'34 => X; by right; left.
Qed.

Lemma step_16 : [^ J3 ^] i3 [^ I4 ^].
Proof. rewrite /J3 /i3. by apply hoare_cmd. Qed.

Lemma step_15 : [^ J3 ^] i3 [^ I4 ^] -> [^ I3 ^] i3 [^ I4 ^].
Proof.
move=> H; apply hoare_sgoto_conseq with J3 I4 => // l s h.
- rewrite /I3 /J3.
  case=> H1 [H2 H3].
  left; split; first by [].
  rewrite /wp0 /wp_addu /I4; split; first by [].
  by rewrite store.get_upd' // !store.get_upd.
- by apply hoare_prop_m.entails_id.
Qed.

Lemma step_14 : [^ I3 ^] i3 [^ I4 ^] ->
  [^ restrict I2'34 (sdom i3) ^] i3 [^ I2'34 ^].
Proof.
move=> H; eapply hoare_sgoto_conseq; eauto => l s h.
- rewrite /restrict /I2'34; move=> [[X|X] Y].
  case: X => X //; subst l; rewrite /= in Y; by case: Y.
  case: X => X //.
  case: X => X //; subst l; rewrite /= in Y; by case: Y.
- rewrite /I2'34 => H'; by right; right.
Qed.

Lemma step_13 : [^ restrict I2'34 (sdom i2) ^] i2 [^ I2'34 ^] ->
  [^ restrict I2'34 (sdom i3) ^] i3 [^ I2'34 ^] ->
  [^ I2'34 ^] i2 [+] i3 [^ restrict_cplt I2'34 (sdom (i2 [+] i3)) ^].
Proof. move=> ? ?. by apply hoare_sS. Qed.

Lemma step_12 : [^ I2'34 ^] i2 [+] i3 [^ restrict_cplt I2'34 (sdom (i2 [+] i3)) ^] ->
  [^ I2' ^] i2 [+] i3 [^ I4 ^].
Proof.
move=> H; eapply hoare_sgoto_conseq; eauto => l s h.
- rewrite /I2'34 => H'; by left.
- rewrite /restrict_cplt /while.Not; move => /= [X [ [Y1 _] | [ [Y1 _] | Y ] ] ] //; subst l; tauto.
Qed.

Lemma step_11 : [^ I2' ^] i2 [+] i3 [^ I4 ^] -> [^ I2 ^] i2 [+] i3 [^ I4 ^].
Proof.
move=> H; eapply hoare_sgoto_conseq; eauto => l s h.
- rewrite /I2 /I2'; by move=> [X [Y [Z W]]].
- by apply hoare_prop_m.entails_id.
Qed.

Lemma step_10 : [^ I2 ^] i2 [+] i3 [^ I4 ^] ->
  [^ restrict I1'24 (sdom (i2 [+] i3)) ^] i2 [+] i3 [^ I1'24 ^].
Proof.
move=> H; eapply hoare_sgoto_conseq; eauto => l s h.
- rewrite /restrict /I1'24; move=> [X /= Y].
  case: X => [X | X].
  + case: X => X //; subst l.
    case: Y => //; by case.
  + case: X => X //.
    case: X => X //; subst l.
    case: Y => //; by case.
- move=> *; by right; right.
Qed.

Lemma step_9 : [^ J4 ^] i4 [^ I1' ^].
Proof. rewrite /J4 /i4. by apply hoare_jmp. Qed.

Lemma step_8 :
  [^ J4 ^] i4 [^ I1' ^] -> [^ restrict I1'24 (sdom i4) ^] i4 [^ I1'24 ^].
Proof.
move=> H; eapply hoare_sgoto_conseq; eauto => l s h.
- rewrite /I1'24 /J4; case; case => [ [?] | [ [?] | [?] ]] X; subst l.
  + by right.
  + by case.
  + move=> _; left; split => //; by left.
- rewrite /I1'24 /while.Or; tauto.
Qed.

Lemma step_7 :
  [^ restrict I1'24 (sdom (i2[+]i3)) ^] i2 [+] i3 [^ I1'24 ^] ->
  [^ restrict I1'24 (sdom i4) ^] i4 [^ I1'24 ^] ->
  [^ I1'24 ^] (i2 [+] i3) [+] i4 [^ restrict_cplt I1'24 (sdom ((i2 [+] i3) [+] i4)) ^].
Proof. move=> ? ?; by apply hoare_sS. Qed.

Lemma step_6 :
  [^ I1'24 ^] (i2 [+] i3) [+] i4 [^ restrict_cplt I1'24 (sdom ((i2 [+] i3) [+] i4)) ^] ->
  [^ restrict I1'25 (sdom ((i2 [+] i3) [+] i4)) ^] (i2 [+] i3) [+] i4 [^ I1'25 ^].
Proof.
move=> H; eapply hoare_sgoto_conseq; eauto => l s h.
- rewrite /restrict; move=> /= [[ [X1 _] | [ X | [X1 _] ] ] Y].
  + subst l; by firstorder.
  + by right; left.
  + subst l; by firstorder.
- rewrite /restrict_cplt /while.Not; move => /= [X [ Y | [Y | [Y1 _]]]].
  + by left.
  + by right; left.
  + subst l; tauto.
Qed.

Lemma step_5 : [^ J1' ^] i1 [^ I25 ^].
Proof. rewrite /J1' /i1.
move: hoare_branch. rewrite /WMIPS_Hoare.eval_b. by apply.
Qed.

Lemma step_4 : [^ J1' ^] i1 [^ I25 ^] ->
  [^ restrict I1'25 (sdom i1) ^] i1 [^ I1'25 ^].
Proof.
move=> H; eapply hoare_sgoto_conseq; eauto => l s h.
- rewrite /restrict /while.And; case; case=> [ H1 _ | H1 H2].
  + rewrite /I1' in H1; rewrite /J1'.
    case: H1 => Hl [H2 H3].
    left; split; first exact Hl.
    case/boolP : (eval_b (beq x n) s) => [/eqP/u2Z_inj |] X.
    * right; split; first by [].
      left; rewrite /I25 /I5; right.
      split; first by [].
      rewrite {1 2}X.
      split; first exact: lt_n_irrefl.
      split; by [exact: le_n_refl | ].
    * left; split; first by [].
      rewrite /I25 /I2; left; split; first by [].
      split; last by [].
      apply le_nE in H2.
      case : H2 => H2 //.
      rewrite /= H2 in X.
      by move/eqP : X.
  + rewrite /= in H2; case : H2 => H2 //.
    subst l; case : H1; by case.
- rewrite /I25 /I1'25 /while.Or; tauto.
Qed.

Lemma step_3 : [^ restrict I1'25 (sdom i1) ^] i1 [^ I1'25 ^] ->
  [^ restrict I1'25 (sdom ((i2 [+] i3) [+] i4)) ^] (i2 [+] i3) [+] i4 [^ I1'25 ^] ->
  [^ I1'25 ^] prg [^ restrict_cplt I1'25 (sdom prg) ^].
Proof. move=> ? ?; by apply hoare_sS. Qed.

Lemma step_2 : [^ I1'25  ^] prg [^ restrict_cplt I1'25 (sdom prg) ^] ->
  [^ I1' ^] prg [^ I5 ^].
Proof.
move=> H; eapply hoare_sgoto_conseq; eauto => l s h; rewrite /I1'25.
- rewrite /while.Or; tauto.
- move=> [H1 [ [H2 _]|[ [H2 _] | H2 //]]]; subst l; by firstorder.
Qed.

Lemma step_1 : [^ I1' ^] prg [^ I5 ^] -> [^ I1 ^] prg [^ I5' ^].
Proof.
move=> H; apply hoare_sgoto_conseq with I1' I5 => //.
- move=> l s h; rewrite /I1 /I1'; move => [Hl [O_le_n [Hx Hr]]].
  rewrite Hx Hr Z2uK //.
  split; first by [].
  split; first by [].
  by apply eqmod_refl.
- move=> l s h; rewrite /I5 /I5'; move=> [H1 [H2 [x_le_n H4]]].
  move/le_nE in x_le_n; tauto.
Qed.

(** Once all such steps are proved individually, the correctness proof consists in the sequential application of the corresponding lemmas: *)

Lemma prf : [^ I1 ^] prg [^ I5' ^].
Proof.
apply step_1.
apply step_2.
apply step_3.
apply step_4.
apply step_5.
apply step_6.
apply step_7; last first.
apply step_8.
apply step_9.
apply step_10.
apply step_11.
apply step_12.
apply step_13; last first.
apply step_14.
apply step_15.
apply step_16.
apply step_17.
apply step_18.
apply step_19.
by apply step_20.
Qed.

End SumOfFirstNaturals.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  An attempt at a variable module in a context.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.

Add LoadPath "/home/milnes/Desktop/Research/Cyclone/CycloneCoq/3".
Require Export BoolEqualitySigDef.
Require Export EVarModuleDef.
Require Export PathModuleDef.
Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.

Module EVarPathModule <: BoolEqualitySig.
  Module E := EVarModule.
  Module P := PathModule.

  Definition UE := prod E.Var P.P.
  Definition T := UE.

Function beq_ue (u u' : UE) : bool :=
  match u, u' with
    | (x,p), (x', p') => andb (E.beq_var x x') (P.beq_path p p')
  end.
Hint Resolve beq_ue.
Definition beq_t := beq_ue.

Lemma beq_ue_refl:
 forall (u : UE),
   beq_ue u u = true.
Proof.
  induction u; crush.
Qed.
Hint Resolve beq_ue_refl.

Lemma beq_ue_sym : forall u u', beq_ue u u' = beq_ue u' u.
Proof.
  induction u; induction u'; try solve[crush].
  unfold beq_ue.
  fold beq_ue.
  rewrite E.beq_var_sym.
  rewrite P.beq_path_sym.
  reflexivity.
Qed.
Hint Immediate beq_ue_sym.

Lemma beq_ue_eq:
  forall u u',
    beq_ue u u' = true ->
    u = u'.
Proof.
  induction u; induction u'; try solve [crush].
  unfold beq_ue.
  fold beq_ue.
  intros.
  apply andb_true_iff in H.
  inversion H.
  apply E.beq_var_eq in H0.
  apply P.beq_path_eq in H1.
  subst.
  reflexivity.
Qed.
Hint Resolve beq_ue_eq.

Lemma beq_ue_trans:
  forall u u0 u1,
    beq_ue u u0 = true ->
    beq_ue u0 u1 = true ->
    beq_ue u u1 = true.
Proof.
  intros.
  pose proof H as H'.
  pose proof H0 as H0'.
  apply beq_ue_eq in H.
  apply beq_ue_eq in H0.
  subst.
  apply beq_ue_refl.
Qed.

Lemma beq_ue_neq:
  forall u u',
    beq_ue u u' = false ->
    u <> u'.
Proof.
  induction u; induction u'; try solve [crush].
  unfold beq_ue.
  fold beq_ue.
  intros.
  apply andb_false_iff in H.
  inversion H.
  apply E.beq_var_neq in H0.
  crush.
  apply P.beq_path_neq in H0.
  crush.
Qed.
Hint Resolve beq_ue_eq.

Definition beq_t_refl := beq_ue_refl.
Definition beq_t_sym := beq_ue_sym.
Definition beq_t_trans := beq_ue_trans.

Definition beq_t_eq := beq_ue_eq.
Definition beq_t_neq := beq_ue_neq.
End EVarPathModule.


Require Import List.

Require Import String.
Open Scope string_scope.

Inductive folDecl :=
    | functionSymbol: string -> nat -> folDecl (* nat is arity *)
    | predicateSymbol: string -> nat -> folDecl
    | folIndSymbol: string -> folDecl.

Definition folSignature := list folDecl.

Definition folVariable := string.
Inductive folTerm : Set :=
  | fromVar: folVariable -> folTerm
  | folIndRef: string -> folTerm
  | folFunctionApp: string -> list folTerm -> folTerm.

Inductive folFormula : Set :=
    | folForall: folVariable -> folFormula -> folFormula
    | folExists: folVariable -> folFormula -> folFormula
    | folBiimpl: folFormula -> folFormula -> folFormula
    | folImpl: folFormula -> folFormula -> folFormula
    | folDisjunction: folFormula -> folFormula -> folFormula
    | folConjunction: folFormula -> folFormula -> folFormula
    | folEq: folTerm -> folTerm -> folFormula
    | folApp: folFormula -> folTerm -> folFormula
    | folLam: (folTerm -> folFormula) -> folFormula
    | folPredicateRef: string -> folFormula.

Definition var_to_term := fun (v: string) => fromVar v.
Coercion var_to_term : string >-> folTerm.

Definition folTheory := list folFormula.

Definition folSystem := (folSignature * folTheory)%type.
Definition folQuery := (folSystem * folFormula)%type.

Fixpoint normalizeFormula (formula: folFormula): folFormula := match formula with
| folForall      v f => folForall v    (normalizeFormula f)
| folExists      v f => folExists v    (normalizeFormula f)
| folBiimpl      f g => folBiimpl      (normalizeFormula f) (normalizeFormula g)
| folImpl        f g => folImpl        (normalizeFormula f) (normalizeFormula g)
| folDisjunction f g => folDisjunction (normalizeFormula f) (normalizeFormula g)
| folConjunction f g => folConjunction (normalizeFormula f) (normalizeFormula g)
| folEq s t          => folEq s t
| folApp (folLam f) arg => f arg
| folApp f arg => folApp (normalizeFormula f) arg
| x => x
end.

Definition normalizeTheory (thy: folTheory): folTheory := map normalizeFormula thy.
Definition normalizeSystem (sys: folSystem): folSystem := match sys with
| (sig, thy) => (sig, normalizeTheory thy)
end.

Require Import Coq.Program.Basics.
Fixpoint nth_power {X: Type} (f: X -> X) (n: nat): X -> X := match n with
| 0 => id
| S n' => compose f (nth_power f n')
end.

Definition normalizeSystemFull := nth_power normalizeSystem 15.

Definition dummyFormula := folForall "x" (folEq "todo" "todo").


(** Calculation for arithmetic + exceptions + local state. *)

Require Import List.
Require Import Tactics.

(** * Syntax *)

Inductive Expr : Set :=
| Val : nat -> Expr
| Add : Expr -> Expr -> Expr
| Throw : Expr
| Catch : Expr -> Expr -> Expr
| Get : Expr
| Put : Expr -> Expr -> Expr.

(** * Semantics *)

Definition State := nat.

Fixpoint eval (x: Expr) (q : State) : option (nat * State) :=
  match x with
    | Val n => Some (n , q)
    | Add x1 x2 => match eval x1 q with
                   | Some (n, q') => match eval x2 q' with
                                     | Some (m, q'') => Some ((n + m), q'')
                                     | None => None
                                     end
                   | None => None
                   end
    | Throw => None
    | Catch x1 x2 => match eval x1 q with
                     | Some (n, q') => Some (n, q')
                     | None => eval x2 q
                     end
    | Get => Some (q, q)
    | Put x1 x2 => match eval x1 q with
                   | Some (n, q') => eval x2 n
                   | None => None
                   end
  end.

(** * Compiler *)

Inductive Code : Set :=
| HALT : Code
| PUSH : nat -> Code -> Code
| ADD : Code -> Code
| FAIL : Code
| MARK : Code -> Code -> Code
| UNMARK : Code -> Code
| LOAD : Code -> Code
| SAVE : Code -> Code
.

Fixpoint comp' (x : Expr) (c : Code) : Code :=
  match x with
    | Val n => PUSH n c
    | Add x1 x2 => comp' x1 (comp' x2 (ADD c))
    | Throw => FAIL
    | Catch x1 x2 => MARK (comp' x2 c) (comp' x1 (UNMARK c))
    | Get => LOAD c
    | Put x1 x2 => comp' x1 (SAVE (comp' x2 c))
  end.

Definition comp (x : Expr) : Code := comp' x HALT.

(** * Virtual Machine *)

Inductive Elem : Set :=
| VAL : nat -> Elem
| HAN : Code -> State -> Elem
.
Definition Stack : Set := list Elem.

Inductive Conf : Set :=
| conf : Code -> Stack -> State -> Conf
| fail : Stack -> Conf.

Notation "⟨ c , s , q ⟩" := (conf c s q).
Notation "⟪ s ⟫" := (fail s ).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : Conf -> Conf -> Prop :=
| vm_push n c s q : ⟨PUSH n c, s, q⟩ ==> ⟨ c , VAL n :: s, q ⟩
| vm_add c s q m n : ⟨ADD c, VAL m :: VAL n :: s, q⟩ ==> ⟨c, VAL (n + m) :: s, q⟩
| vm_fail s q : ⟨ FAIL, s, q⟩ ==> ⟪s⟫
| vm_mark c h s q : ⟨MARK h c, s, q⟩ ==> ⟨c, HAN h q :: s, q⟩
| vm_unmark c n h s q q' : ⟨UNMARK c, VAL n :: HAN h q' :: s, q⟩ ==> ⟨c, VAL n :: s, q⟩
| vm_load c s q : ⟨LOAD c, s, q⟩ ==> ⟨c, VAL q :: s, q⟩
| vm_save c n s q : ⟨SAVE c, VAL n :: s, q⟩ ==> ⟨c, s, n⟩
| vm_fail_val n s : ⟪VAL n :: s ⟫ ==> ⟪s⟫
| vm_fail_han c s q : ⟪HAN c q :: s ⟫ ==> ⟨c, s, q⟩
where "x ==> y" := (VM x y).

Hint Constructors VM : core.

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module VM <: Preorder.
Definition Conf := Conf.
Definition VM := VM.
End VM.
Module VMCalc := Calculation VM.
Import VMCalc.

(** Specification of the compiler *)

Theorem spec x c s q : ⟨comp' x c, s, q⟩
                       =>> match eval x q with
                            | Some (n, q') => ⟨c , VAL n :: s, q'⟩
                            | None => ⟪s⟫
                           end.

(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  generalize dependent s.
  generalize dependent q.
  induction x;intros.

(** Calculation of the compiler *)

(** - [x = Val n]: *)

  begin
  ⟨c, VAL n :: s, q⟩.
  <== { apply vm_push }
  ⟨PUSH n c, s, q⟩.
  [].

(** - [x = Add x1 x2]: *)

  begin
   (match eval x1 q with
     | Some (m, q') => match eval x2 q' with
                         | Some (n, q'') => ⟨ c, VAL (m + n) :: s, q'' ⟩
                         | None => ⟪ s ⟫
                  end
     | None => ⟪ s ⟫
     end).
  <<= { apply vm_add }
   (match eval x1 q with
     | Some (m, q') => match eval x2 q' with
                         | Some (n, q'') => ⟨ ADD c, VAL n :: VAL m :: s, q'' ⟩
                         | None => ⟪ s ⟫
                  end
     | None => ⟪ s ⟫
     end).
  <<= { apply vm_fail_val }
   (match eval x1 q with
     | Some (m, q') => match eval x2 q' with
                         | Some (n, q'') => ⟨ ADD c, VAL n :: VAL m :: s, q'' ⟩
                         | None => ⟪ VAL m :: s ⟫
                  end
     | None => ⟪ s ⟫
     end).
  <<= { apply IHx2 }
   (match eval x1 q with
     | Some (m, q') =>  ⟨ comp' x2 (ADD c), VAL m :: s, q' ⟩
     | None => ⟪ s ⟫
     end).
  <<= { apply IHx1 }
      ⟨ comp' x1 (comp' x2 (ADD c)), s, q ⟩.
  [].

(** - [x = Throw]: *)

  begin
    ⟪s⟫.
  <== { apply vm_fail }
    ⟨ FAIL, s, q⟩.
  [].

(** - [x = Catch x1 x2]: *)

  begin
    (match eval x1 q with
         | Some (m, q') => ⟨ c, VAL m :: s, q'⟩
         | None => match eval x2 q with
                     | Some (n, q'') => ⟨c, VAL n :: s, q''⟩
                     | None => ⟪s⟫
                   end
    end).
   <<= { apply IHx2 }
    (match eval x1 q with
         | Some (m, q') => ⟨ c, VAL m :: s, q'⟩
         | None => ⟨comp' x2 c, s, q⟩
    end).
   <<= { apply vm_fail_han }
    (match eval x1 q with
         | Some (m, q') => ⟨ c, VAL m :: s, q'⟩
         | None => ⟪ HAN (comp' x2 c) q :: s⟫
    end).
   <<= { apply vm_unmark }
    (match eval x1 q with
         | Some (m, q') => ⟨ UNMARK c, VAL m :: HAN (comp' x2 c) q :: s, q'⟩
         | None => ⟪ HAN (comp' x2 c) q :: s⟫
    end).
   <<= { apply IHx1 }
       ⟨ comp' x1 (UNMARK c), HAN (comp' x2 c) q :: s, q⟩.
   <<= { apply vm_mark }
       ⟨ MARK (comp' x2 c) (comp' x1 (UNMARK c)),  s, q⟩.
   [].

(** - [x = Get]: *)

   begin
     ⟨ c, VAL q :: s, q⟩.
   <== { apply vm_load }
     ⟨ LOAD c, s, q⟩.
   [].

(** - [x = Put x1 x2]: *)

   begin
     (match eval x1 q with
          | Some (n, q') => match eval x2 n with
                                | Some (m, q'') => ⟨c, VAL m :: s, q''⟩
                                | None => ⟪s⟫
                            end
          | None => ⟪s⟫
      end).
   <<= { apply IHx2 }
       (match eval x1 q with
          | Some (n, q') => ⟨comp' x2 c, s, n⟩
          | None => ⟪s⟫
        end).
   <<= { apply vm_save }
       (match eval x1 q with
          | Some (n, q') => ⟨SAVE (comp' x2 c), VAL n :: s, q'⟩
          | None => ⟪s⟫
        end).
   <<= { apply IHx1 }
       ⟨comp' x1 (SAVE (comp' x2 c)), s, q⟩.
   [].
Qed.

(** * Soundness *)

(** Since the VM is defined as a small step operational semantics, we
have to prove that the VM is deterministic and does not get stuck in
order to derive soundness from the above theorem. *)

Lemma determ_vm : determ VM.
  intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity.
Qed.

Lemma term_vm x :  ~ (exists C, match x with
                             | Some (n, q) => ⟨HALT , VAL n :: nil, q⟩
                             | None =>  ⟪nil⟫
                           end  ==> C).
Proof.
  destruct x; try destruct p; intro Contra; destruct Contra; subst; inversion H.
Qed.

Theorem sound x C q : ⟨comp x, nil, q⟩ =>>! C -> C = match eval x q with
                                                  | Some (n, q') => ⟨HALT , VAL n :: nil, q'⟩
                                                  | None =>  ⟪nil⟫
                                                end.
Proof.
  intros.
  pose (spec x HALT nil) as H'. unfold comp in *. pose (determ_trc determ_vm) as D.
  unfold determ in D. eapply D. apply H. split. apply H'. apply term_vm.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*           [*] Affiliation Univ. Lorraine - CNRS - LORIA    *)
(*           [+] Affiliation VERIMAG - Univ. Grenoble Alpes   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*        CeCILL v2.1 FREE SOFTWARE LICENSE AGREEMENT         *)
(**************************************************************)

From Coq Require Import Utf8.

Section functional_relations_properties.

  Variables (X Y : Type).

  Definition functional₀ (P : Y → Prop) := ∀ y₁ y₂, P y₁ → P y₂ → y₁ = y₂.
  Definition functional₁ (R : X → Y → Prop) := ∀x, functional₀ (R x).

End functional_relations_properties.

Arguments functional₀ {_} _ /.
Arguments functional₁ {_ _} _/.

Notation functional := functional₁.

Definition rel_subst {X Y} (P : X → Prop) (R : X → Y → Prop) y := ∃x, P x ∧ R x y.
Notation "R '⋄' P" := (rel_subst P R) (at level 1, no associativity, format "R  ⋄  P").

Fact rel_subst_fun {X Y} (P : X → Prop) (R : X → Y → Prop) :
      functional₀ P → functional R → functional₀ (R ⋄ P).
Proof.
  intros HP HR y1 y2 (x1 & H1 & H2) (x2 & H3 & H4).
  revert H2 H4.
  rewrite (HP _ _ H1 H3).
  apply HR.
Qed.

Section included.

  Variables (X Y : Type).

  Definition included₀ (P Q : Prop) := P → Q.
  Definition included₁ (P Q : Y → Prop) := ∀y, P y → Q y.
  Definition included₂ (P Q : X → Y → Prop) := ∀x y, P x y → Q x y.

End included.

Arguments included₀ _ _ /.
Arguments included₁ {_} _ _ /.
Arguments included₂ {_ _} _ _ /.

Infix "⊆₀" := included₀ (at level 70, no associativity).
Infix "⊆₁" := included₁ (at level 70, no associativity).
Infix "⊆₂" := included₂ (at level 70, no associativity).

Fact included₁_refl {X} (P : X → Prop) : P ⊆₁ P.
Proof. now intro. Qed.

(* Left-recursive notation for tuples of proofs of propositions for logical conjunctions
   the ₚ suffix is here to remind that tuple are proof of [P]roposition and distinguish
   with the tuple notation for vectors *)
Notation "⟨ a , b , .. , c ⟩ₚ" := (conj .. (conj a b) .. c) (at level 0, format "⟨ a , b , .. , c ⟩ₚ").

Definition and₁ {X : Type} (P Q : X → Prop) := λ x, P x ∧ Q x.

Infix "∧₁" := and₁ (at level 68, right associativity).

Section facts.
  Context {X : Type}.
  Variables (P Q : X → Prop).

  Fact and₁_intro Q' : (P ⊆₁ Q) → (P ⊆₁ Q') → (P ⊆₁ Q ∧₁ Q').
  Proof. intros ? ? ? ?. red. intuition. Qed.

  Fact and₁_monotonic P' Q' : (P ⊆₁ P') → (Q ⊆₁ Q') → (P ∧₁ Q ⊆₁ P' ∧₁ Q').
  Proof. cbv; intros pp qq x; specialize (pp x); specialize (qq x); intuition. Qed.

End facts.


Require Export euclidean__axioms.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export logic.
Definition lemma__doublereverse : forall A B C D, (euclidean__axioms.Cong A B C D) -> ((euclidean__axioms.Cong D C B A) /\ (euclidean__axioms.Cong B A D C)).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
assert (* Cut *) (euclidean__axioms.Cong C D D C) as H0.
- apply (@euclidean__axioms.cn__equalityreverse C D).
- assert (* Cut *) (euclidean__axioms.Cong A B D C) as H1.
-- apply (@lemma__congruencetransitive.lemma__congruencetransitive A B C D D C H H0).
-- assert (* Cut *) (euclidean__axioms.Cong B A A B) as H2.
--- apply (@euclidean__axioms.cn__equalityreverse B A).
--- assert (* Cut *) (euclidean__axioms.Cong B A D C) as H3.
---- apply (@lemma__congruencetransitive.lemma__congruencetransitive B A A B D C H2 H1).
---- assert (* Cut *) (euclidean__axioms.Cong D C B A) as H4.
----- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric D B A C H3).
----- split.
------ exact H4.
------ exact H3.
Qed.


Set Implicit Arguments.
Require Import List Lia.
Import ListNotations.

Lemma list_decompose k {X} (A: list X):
  k <= length A -> exists A1 A2, A = A1 ++ A2 /\ length A1 = k.
Proof.
  induction A in k |-*; intros.
  - exists nil. exists nil; cbn. destruct k; intuition.
  - destruct k.
    + exists nil; exists (a :: A); intuition.
    + cbn in *; assert (k <= length A) by lia. destruct (IHA _ H0) as (A1 & A2 & ?).
      intuition. exists (a :: A1). exists A2. subst.
      intuition.
Qed.

Lemma list_decompose_alt k {X} (A: list X):
  k <= length A -> exists A1 A2, A = A1 ++ A2 /\ length A2 = k.
Proof.
  intros H.
  assert (length A - k <= length A) by lia.
  destruct (list_decompose _ H0) as (A1 & A2 & ?).
  intuition. exists A1. exists A2. intuition.
  specialize (app_length A1 A2) as H4.
  rewrite <-H2 in H4. rewrite H4 in H3. lia.
Qed.

Lemma list_decompose_end {X} (A: list X):
  A = nil \/ exists a' A', A = A' ++ [a'].
Proof.
  induction A; intuition; subst.
  all: right; try destruct IH as (a' & A' & ?).
  + exists a. exists nil. reflexivity.
  + destruct H as (a' & A' & ?); subst.
    exists a'. exists (a :: A'). reflexivity.
Qed.

Lemma list_decompose_strong Y k (A: list Y):
  k <= length A -> { A1 & { A2 | A = A1 ++ A2 /\ length A1 = k}}.
Proof.
  induction A in k |-*; intros H.
  - exists nil. exists nil. intuition.
  - destruct k.
    + exists nil. exists (a :: A). intuition.
    + cbn in H; eapply le_S_n in H.
      destruct (IHA _ H) as (A1 & A2 & H1 & H2); subst.
      exists (a :: A1). exists A2. intuition.
Qed.

Lemma list_pointwise_eq X (A B: list X):
  (forall x, nth_error A x = nth_error B x) -> A = B.
Proof.
  induction A in B |-*; cbn; destruct B as [| b B]; eauto.
  - intros H; specialize (H 0); discriminate.
  - intros H; specialize (H 0); discriminate.
  - intros H.
    specialize (H 0) as H'; injection H' as ->.
    f_equal; eapply IHA.
    intros x; exact (H (S x)).
Qed.

Lemma list_end_ind:
  forall (A : Type) (P : list A -> Prop),
    P [] ->
    (forall (a : A) (l : list A), P l -> P (l ++ [a])) -> forall l : list A, P l.
Proof.
  intros A P H IH l.
  specialize (rev_list_ind P H) as Ind.
  rewrite <-rev_involutive. eapply Ind.
  intros; cbn; now apply IH.
Qed.

Lemma app_injective {X} (A B C D: list X):
  length A = length C -> A ++ B = C ++ D -> A = C /\ B = D.
Proof.
  induction A in C |-*; destruct C; try discriminate.
  cbn; intuition.
  injection 1 as ?. injection 1 as ?.
  subst. edestruct IHA; eauto; subst; intuition.
Qed.

Lemma app_injective_right Y (A1 A2 B1 B2 : list Y):
  length A2 = length B2 -> A1 ++ A2 = B1 ++ B2 -> A1 = B1 /\ A2 = B2.
Proof.
  intros H; induction A1 in B1 |-*; destruct B1; cbn; eauto.
  1 - 2: intros; subst; cbn in H; autorewrite with list in H; lia.
  intros [= -> ? % IHA1]; intuition; now subst.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Reflection : Basic Operations on Booleans                               *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibOperation.

(* ********************************************************************** *)
(** * Boolean type *)

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

(** From the Prelude:

  Inductive bool : Type :=
    | true : bool
    | false : bool.

*)

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

Instance Inhab_bool : Inhab bool.
Proof using. constructor. apply (Inhab_of_val true). Qed.

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

(** See [LibReflect] for extensionality of booleans. *)

(* ********************************************************************** *)
(** * Boolean Operations *)

(** ** Comparison *)

Definition eqb (x y:bool) : bool :=
  match x, y with
  | true, true => true
  | false, false => true
  | _, _ => false
  end.

(** Negation *)

Definition neg (x:bool) : bool :=
  match x with
  | true => false
  | false => true
  end.

(** Conjunction *)

Definition and (x y:bool) : bool :=
  match x, y with
  | true, true => true
  | _, _ => false
  end.

(** Disjunction *)

Definition or (x y:bool) : bool :=
  match x, y with
  | false, false => false
  | _, _ => true
  end.

(** Implication *)

Definition impl (x y:bool) : bool :=
  or x (neg y).

(** Exclusive or *)

Definition xor (x y:bool) : bool :=
  neg (eqb x y).

(** Notations *)

Bind Scope Bool_scope with bool.
Open Scope Bool_scope.

Notation "! x" := (neg x)
  (at level 35, right associativity) : Bool_scope.
Infix "&&" := and
  (at level 40, left associativity) : Bool_scope.
Infix "||" := or
  (at level 50, left associativity) : Bool_scope.

Notation "! x" := (neg x)
  (at level 35, right associativity) : Bool_scope.
Infix "&&" := and
  (at level 40, left associativity) : Bool_scope.
Infix "||" := or
  (at level 50, left associativity) : Bool_scope.

(* ********************************************************************** *)
(** * Boolean Decision Procedure : tactic working by exponential case
      analysis on all variables of type bool. *)

(* ---------------------------------------------------------------------- *)
(** ** Tactic [tautob] *)

(** [tautob] introduces all variables that it can, performs a
    case analysis on all the boolean variables, then splits
    all subgoals and attempts resolution using intuition *)

Ltac tautob_post tt :=
  simpls; try split; intros; try discriminate;
  try solve [ intuition auto_false ].

Ltac tautob_core tt :=
  let rec aux tt :=
    (try intros_all); match goal with
    | b : bool |- _ => destruct b; clear b; aux tt
    | _ => tautob_post tt
    end in
  aux tt.

Tactic Notation "tautob" :=
  tautob_core tt.

(* ********************************************************************** *)
(** * Properties of boolean operators *)

(* ---------------------------------------------------------------------- *)
(** ** Properties of [eqb] *)

Lemma eqb_same : forall x,
  eqb x x = true.
Proof using. tautob. Qed.

Lemma eqb_true_l : neutral_l eqb true.
(* forall x, eqb true x = x. *)
Proof using. tautob. Qed.

Lemma eqb_true_r : neutral_r eqb true.
Proof using. tautob. Qed.

Lemma eqb_false_l : forall x,
  eqb false x = neg x.
Proof using. tautob. Qed.

Lemma eqb_false_r : forall x,
  eqb x false = neg x.
Proof using. tautob. Qed.

Lemma eqb_comm : comm eqb.
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties of [and] *)

Lemma and_same : idempotent2 and.
Proof using. tautob. Qed.

Lemma and_true_l : neutral_l and true.
Proof using. tautob. Qed.

Lemma and_true_r : neutral_r and true.
Proof using. tautob. Qed.

Lemma and_false_l : absorb_l and false.
Proof using. tautob. Qed.

Lemma and_false_r : absorb_r and false.
Proof using. tautob. Qed.

Lemma and_comm : comm and.
Proof using. tautob. Qed.

Lemma and_assoc : assoc and.
Proof using. tautob. Qed.

Lemma and_or_l : distrib_r and or.
(* forall x y z, (x || y) && z = x && z ||| y && z. *)
Proof using. tautob. Qed.

Lemma and_or_r : distrib_l and or.
(* forall x y z, x && (y ||| z) = x && y ||| x && z. *)
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties of [or] *)

Lemma or_same : idempotent2 or.
Proof using. tautob. Qed.

Lemma or_false_l : neutral_l or false.
Proof using. tautob. Qed.

Lemma or_false_r : neutral_r or false.
Proof using. tautob. Qed.

Lemma or_true_l : absorb_l or true.
Proof using. tautob. Qed.

Lemma or_true_r : absorb_r or true.
Proof using. tautob. Qed.

Lemma or_comm : comm or.
Proof using. tautob. Qed.

Lemma or_assoc : assoc or.
Proof using. tautob. Qed.

Lemma or_and_l : distrib_r or and.
(* forall x y z, (x && y) || z = (x || z) && (y || z). *)
Proof using. tautob. Qed.

Lemma or_and_r : distrib_l or and.
(* forall x y z, x || (y && z) = (x || y) && (x || z). *)
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties of [neg] *)

Lemma neg_false : ! false = true.
Proof using. auto. Qed.

Lemma neg_true : ! true = false.
Proof using. auto. Qed.

(* --LATER: fix coq display of goals below *)

Lemma neg_and : automorphism neg and or.
(* forall x y, ! (x && y) = (! x) || (! y) *)
Proof using. tautob. Qed.

Lemma neg_or : automorphism neg or and.
(* forall x y, ! (x || y) = (! x) && (! y) *)
Proof using. tautob. Qed.

Lemma neg_neg : involutive neg.
(* forall x, ! (! b) = b *)
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties of [if then else] *)

Section PropertiesIf.
Implicit Types x y z : bool.

Lemma if_true : forall x y,
  (if true then x else y) = x.
Proof using. auto. Qed.

Lemma if_false : forall x y,
  (if false then x else y) = y.
Proof using. auto. Qed.

Lemma if_then_else_same : forall x y,
  (if x then y else y) = y.
Proof using. tautob. Qed.

Lemma if_then_true_else_false : forall x,
  (if x then true else false) = x.
Proof using. tautob. Qed.

Lemma if_then_false_else_true : forall x,
  (if x then false else true) = !x.
Proof using. tautob. Qed.

Lemma if_then_true : forall x y,
  (if x then true else y) = x || y.
Proof using. tautob. Qed.

Lemma if_then_false : forall x y,
  (if x then false else y) = (!x) && y.
Proof using. tautob. Qed.

Lemma if_else_false : forall x y,
  (if x then y else false) = x && y.
Proof using. tautob. Qed.

Lemma if_else_true : forall x y,
  (if x then y else true) = (!x) || y.
Proof using. tautob. Qed.

End PropertiesIf.

(* ---------------------------------------------------------------------- *)
(** ** Properties of [impl] and [xor] *)

(** We do not provide lemmas for [impl] and [xor]
   because these functions can be easily expressed
   in terms of the other operators. *)

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

Opaque eqb neg and or.

(* ********************************************************************** *)
(** * Tactics *)

(* ---------------------------------------------------------------------- *)
(** ** Tactic [rew_neg_neg] *)

(** [rew_neg_neg] is a tactic that simplifies all double negations
    of booleans, i.e. replaces [!!b] with [b]. *)

Hint Rewrite neg_neg : rew_neg_neg.

Tactic Notation "rew_neg_neg" :=
  autorewrite with rew_neg_neg.
Tactic Notation "rew_neg_neg" "~" :=
  rew_neg_neg; auto_tilde.
Tactic Notation "rew_neg_neg" "*" :=
  rew_neg_neg; auto_star.
Tactic Notation "rew_neg_neg" "in" hyp(H) :=
  autorewrite with rew_neg_neg in H.
Tactic Notation "rew_neg_neg" "~" "in" hyp(H) :=
  rew_neg_neg in H; auto_tilde.
Tactic Notation "rew_neg_neg" "*" "in" hyp(H) :=
  rew_neg_neg in H; auto_star.
Tactic Notation "rew_neg_neg" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_neg_neg).
  (* autorewrite with rew_neg_neg in *. *)
Tactic Notation "rew_neg_neg" "~" "in" "*" :=
  rew_neg_neg in *; auto_tilde.
Tactic Notation "rew_neg_neg" "*" "in" "*" :=
  rew_neg_neg in *; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Tactic [rew_bool] *)

(** [rew_bool] simplifies boolean expressions, using rewriting
    lemmas in the database [rew_bool] defined below. *)

Hint Rewrite
  eqb_same eqb_true_l eqb_true_r eqb_false_l eqb_false_r
  neg_false neg_true neg_neg neg_and neg_or
  and_true_l and_true_r and_false_l and_false_r
  or_false_l or_false_r or_true_l or_true_r
  if_true if_false if_then_else_same
  if_then_true_else_false if_then_false_else_true
  if_then_true if_else_false
  if_then_false if_else_true
  : rew_bool.

Tactic Notation "rew_bool" :=
  autorewrite with rew_bool.
Tactic Notation "rew_bool" "~" :=
  rew_bool; auto_tilde.
Tactic Notation "rew_bool" "*" :=
  rew_bool; auto_star.
Tactic Notation "rew_bool" "in" hyp(H) :=
  autorewrite with rew_bool in H.
Tactic Notation "rew_bool" "~" "in" hyp(H) :=
  rew_bool in H; auto_tilde.
Tactic Notation "rew_bool" "*" "in" hyp(H) :=
  rew_bool in H; auto_star.
Tactic Notation "rew_bool" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_bool).
  (* autorewrite with rew_bool in *. *)
Tactic Notation "rew_bool" "~" "in" "*" :=
  rew_bool in *; auto_tilde.
Tactic Notation "rew_bool" "*" "in" "*" :=
  rew_bool in *; auto_star.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf1 : lst) (x : lst) : natural := Succ (len (append x x)).


(** * 6.822 Formal Reasoning About Programs, Spring 2020 - Pset 8 *)

Require Import Frap.

(* Authors:
 * Joonwon Choi (joonwonc@csail.mit.edu)
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

Set Implicit Arguments.

(** * Hoare Logic with Input/Output Traces *)

(* Hoare logic as covered in lecture is only the beginning, so far as
 * programming features that can be supported. In this problem set, we
 * will implement one of variant, a Hoare logic that deals with
 * input/output traces.
 *
 * Behaviors of a program can be defined as sequences of communications with
 * the outside world. Hoare logic certainly can be used for proving properties
 * about program behaviors. Besides valuation and heap, we will need to keep
 * track of traces of a program to ensure the properties we want, sometimes by
 * proving invariants in the middle of the program.
 *
 * The problem set consists of 4 tasks; basically we ask you to formally prove
 * the correctness of some programs using Hoare logic:
 * 1) To design a big-step operational semantics of the given language.
 * 2) To define a Hoare logic for the language, and to prove the consistency
 *    between the semantics and the logic.
 * 3) To verify three example programs we provide, using Hoare logic.
 * 4) To design your own program and to verify it.
 *)

(** * Language syntax *)

(* There is nothing special with the definitions of [exp] and [bexp]; they are
 * exactly same as we've seen in the lecture.
 *)
Inductive exp :=
| Const (n : nat)
| Var (x : string)
| Read (e1 : exp)
| Plus (e1 e2 : exp)
| Minus (e1 e2 : exp)
| Mult (e1 e2 : exp).

Inductive bexp :=
| Equal (e1 e2 : exp)
| Less (e1 e2 : exp).

(* [heap] and [valuation] are also as usual. *)
Definition heap := fmap nat nat.
Definition valuation := fmap var nat.

(* Besides [heap] and [valuation], we have one more component to verify using
 * Hoare logic, called [io]. We keep track of inputs and outputs of a certain
 * program, regarding them as meaningful communication with the outside world.
 * When a program is executed, it generates [trace], which is a list of [io]s,
 * meaning inputs and outputs that occurred during the execution. Traces are
 * also called behaviors of a program.
 *)
Inductive io := In (v : nat) | Out (v : nat).
Definition trace := list io.

(* We now have two types of assertions: [iassertion] is used only for asserting
 * properties of internal states. [assertion] can be used for asserting
 * properties of [trace]s as well as internal states.
 *)
Definition iassertion := heap -> valuation -> Prop.
Definition assertion := trace -> heap -> valuation -> Prop.

(* [cmd] has more constructors than what we've seen.  The new ones are called
 * [Input] and [Output]. As expected, semantically they generates [io]s,
 * eventually forming a [trace] of a program.
 *)
Inductive cmd :=
| Skip
| Assign (x : var) (e : exp)
| Write (e1 e2 : exp)
| Seq (c1 c2 : cmd)
| If_ (be : bexp) (then_ else_ : cmd)
| While_ (inv : assertion) (be : bexp) (body : cmd)

| Assert (a : iassertion) (* Note that we are using [iassertion], not
                           * [assertion], for [Assert]. While [valuation] and
                           * [heap] are internal states directly manipulated by
                           * a program, [trace] is rather an abstract notion for
                           * defining a behavior of a program.
                           *)

(* The new constructors are below! *)
| Input (x : var) (* [Input] takes an input from the external world and assigns
                   * the value to the local variable [x].
                   *)
| Output (e : exp). (* [Output] prints the value of [e]. *)

(** We here provide fancy notations for our language. *)

Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
Notation "*[ e ]" := (Read e) : cmd_scope.
Infix "+" := Plus : cmd_scope.
Infix "-" := Minus : cmd_scope.
Infix "*" := Mult : cmd_scope.
Infix "=" := Equal : cmd_scope.
Infix "<" := Less : cmd_scope.
Definition set (dst src : exp) : cmd :=
  match dst with
  | Read dst' => Write dst' src
  | Var dst' => Assign dst' src
  | _ => Assign "Bad LHS" 0
  end.
Infix "<-" := set (no associativity, at level 70) : cmd_scope.
Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
Notation "'when' b 'then' then_ 'else' else_ 'done'" :=
  (If_ b then_ else_) (at level 75, b at level 0) : cmd_scope.
Notation "{{ I }} 'while' b 'loop' body 'done'" := (While_ I b body) (at level 75) : cmd_scope.
Notation "'assert' {{ I }}" := (Assert I) (at level 75) : cmd_scope.
Notation "x '<--' 'input'" := (Input x) (at level 75) : cmd_scope.
Notation "'output' e" := (Output e) (at level 75) : cmd_scope.
Delimit Scope cmd_scope with cmd.

Infix "+" := plus : reset_scope.
Infix "-" := Init.Nat.sub : reset_scope.
Infix "*" := mult : reset_scope.
Infix "=" := eq : reset_scope.
Infix "<" := lt : reset_scope.
Delimit Scope reset_scope with reset.
Open Scope reset_scope.

(** * Task 1: A big-step operational semantics for commands *)

(* Your first task is to define a big-step operational semantics for commands.
 * While it should be very similar to what we've seen in class, it should
 * also represent something about [io]s (or [trace]). Make sure the semantics
 * captures the effects of [Input]/[Output] on [trace]s. The most
 * recent event should appear at the *front* of the list in the trace.
 *
 * We provide the signature of the big-step semantics below. Replace the
 * [Axiom] below with your own definition of the semantics.
 * The first three arguments are the trace, heap, and valuation before execution,
 * and the final three arguments are the trace, heap, and valuation after execution.

 * Again, the task for this pset is to *extend* the framework from
 * frap/HoareLogic.v, not to reinvent it. In particular, if you are
 * having trouble with a construct other than input or output, the
 * basic version should be able to help you out.
 *)

(** * Define your semantics here! *)

Axiom exec : trace -> heap -> valuation -> cmd ->
             trace -> heap -> valuation -> Prop.

(** * Task 2 : Hoare logic *)

(* We also ask you to define a Hoare logic for our language. The logic should
 * derive triples of the form {{ P }} c {{ Q }}, where "P" and "Q" have type
 * [assertion] and "c" has type [cmd]. It should be also very similar to the
 * Hoare logic we've defined in class.
 *)

(* The logic should be consistent with the semantics you defined, so we
 * also ask you to prove a soundness relation between your Hoare logic and your
 * semantics.  You will need this consistency to prove the correctness of
 * example programs we will provide soon.
 *)

(** Task 2-1: Define your Hoare logic here! *)

Axiom hoare_triple : assertion -> cmd -> assertion -> Prop.

Notation "[[ tr , h , v ]] ~> e" := (fun tr h v => e%reset) (at level 90).
Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c%cmd Q) (at level 90, c at next level).

(** Task 2-2: Prove the consistency theorem. *)

Theorem hoare_triple_big_step :
  forall pre c post,
    hoare_triple pre c post ->
    forall tr h v tr' h' v',
      exec tr h v c tr' h' v' ->
      pre tr h v -> post tr' h' v'.
Proof.
Admitted.

(** * Task 3: Verification of some example programs *)

(* Now it's time to verify programs using the Hoare logic you've just defined!
 * We provide three example programs and three corresponding correctness
 * theorems. You are required to prove the theorems stated below using Hoare
 * logic.
 *)

(** Task 3-1: adding two inputs -- prove [add_two_inputs_ok] *)

Example add_two_inputs :=
  ("x" <-- input;;
   "y" <-- input;;
   output ("x" + "y"))%cmd.

Theorem add_two_inputs_ok:
  forall tr h v tr' h' v',
    exec tr h v add_two_inputs tr' h' v' ->
    tr = nil ->
    exists vx vy, tr' = [Out (vx + vy); In vy; In vx].
Proof.
Admitted.

(** Task 3-2: finding the maximum of three numbers -- prove [max3_ok] *)

Example max3 :=
  ("x" <-- input;;
   "y" <-- input;;
   "z" <-- input;;
   when "x" < "y" then
     when "y" < "z" then
       output "z"
     else
       output "y"
     done
   else
     when "x" < "z" then
       output "z"
     else
       output "x"
     done
   done)%cmd.

Inductive max3_spec : trace -> Prop :=
| M3s: forall x y z mx,
    mx >= x ->
    mx >= y ->
    mx >= z ->
    (mx = x \/ mx = y \/ mx = z) ->
    max3_spec [Out mx; In z; In y; In x].

Theorem max3_ok:
  forall tr h v tr' h' v',
    exec tr h v max3 tr' h' v' ->
    tr = nil ->
    max3_spec tr'.
Proof.
Admitted.

(** Task 3-3: Fibonacci sequence -- prove [fibonacci_ok] *)

Inductive fibonacci_spec : trace -> Prop :=
| Fs0: fibonacci_spec nil
| Fs1: fibonacci_spec [Out 1]
| Fs2: fibonacci_spec [Out 1; Out 1]
| Fsn:
    forall x y tr,
      fibonacci_spec (Out y :: Out x :: tr) ->
      fibonacci_spec (Out (x + y) :: Out y :: Out x :: tr).

Example fibonacci (n: nat) :=
  ("cnt" <- 0;;
   "x" <- 0;;
   "y" <- 1;;
   output "y";;
   {{ fun _ _ _ => True }} (* You may change this loop invariant to make your
                            * proof easier! *)
   while "cnt" < n loop
     "tmp" <- "y";;
     "y" <- "x" + "y";;
     "x" <- "tmp";;
     "cnt" <- "cnt" + 1;;
     output "y"
   done)%cmd.

Theorem fibonacci_ok (n: nat):
  forall tr h v tr' h' v',
    exec tr h v (fibonacci n) tr' h' v' ->
    tr = nil ->
    fibonacci_spec tr'.
Proof.
Admitted.

(** * Task 4-1: please estimate the time you have spent on this pset so far:

  space for work provided here (not graded):

*)

(** * Task 4-2: please subtract the answer of 4-1 from 8 hours:
   (8 hours is our target time when designing these psets):

  space for work provided here (not graded):

*)

(** * Task 4-3: Implement your own program to verify. *)

(* The last task is to implement your own program and to verify its correctness
 * using Hoare logic. Note that the three examples we provided above had nothing
 * to do with [heap]s. Design a program that uses the heap and that is more
 * complicated than the first example above, and prove it correct. Please take
 * care to estimate the difficulty of the verification task you are about to
 * undertake, and consider it in the context of the last two answers.
 * We are not expecting this program to use a noteworthy data structure or
 * algorithm. However, your program should at least either read or write the
 * heap, and either accept input or produce output, and the relationship
 * between these two interactions should be verified. There is no extra credit
 * for doing more, but feel free to prove to your heart's content -- we won't
 * take off any points either, and we'll help you in office hours if we can.
 *)

(** Define your own program and prove its correctness here! *)


Require Import Omega.
Require Import RelationClasses.
Require Import Coq.Lists.ListDec Decidable.

Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import DenseOrder.
Require Import Loc.

Require Import Time.

Set Implicit Arguments.

(** * Timemap and View *)

(** Timemap is defined in [TimeMap] module and View is defined in [View] module. *)

Lemma time_decidable: decidable_eq Time.t.
Proof.
  ii. destruct (Time.eq_dec x y); [left|right]; eauto.
Qed.

Definition loc_ts_eq_dec (lhs rhs:Loc.t * Time.t):
  {(fst lhs) = (fst rhs) /\ (snd lhs) = (snd rhs)} +
  {(fst lhs) <> (fst rhs) \/ (snd lhs) <> (snd rhs)}.
Proof.
  destruct lhs, rhs.
  destruct (Loc.eq_dec t t1), (Time.eq_dec t0 t2); subst; auto.
Defined.
Global Opaque loc_ts_eq_dec.

Lemma loc_time_decidable: decidable_eq (Loc.t * Time.t).
Proof.
  ii. destruct x, y.
  destruct (loc_ts_eq_dec (t, t0) (t1, t2)); ss.
  - left. des. subst. ss.
  - right. ii. inv H. des; ss.
Qed.

(** ** Timemap *)
(** Timemap is defined as a total mapping from location to timestamp.
    It is defined as (TimeMap) in Figure 8 in paper *)
Module TimeMap <: JoinableType.
  Definition t := Loc.t -> Time.t.

  Definition eq := @eq t.

  Definition le (lhs rhs:t): Prop :=
    forall loc, Time.le (lhs loc) (rhs loc).

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation. ii. refl. Qed.
  Next Obligation. ii. etrans; eauto. Qed.
  Hint Resolve le_PreOrder_obligation_2.

  Definition bot: t := fun _ => Time.bot.

  Lemma bot_spec (tm:t): le bot tm.
  Proof. ii. apply Time.bot_spec. Qed.

  Definition get (loc:Loc.t) (c:t) := c loc.

  Definition add (l:Loc.t) (ts:Time.t) (tm:t): t :=
    fun l' =>
      if Loc.eq_dec l' l
      then ts
      else get l' tm.

  Definition add_spec l' l ts tm:
    get l' (add l ts tm) =
    if Loc.eq_dec l' l
    then ts
    else get l' tm.
  Proof. auto. Qed.

  Lemma add_spec_eq l ts tm:
    get l (add l ts tm) = ts.
  Proof.
    rewrite add_spec.
    destruct (Loc.eq_dec l l); auto.
    congruence.
  Qed.

  Lemma add_spec_neq l' l ts tm (NEQ: l' <> l):
    get l' (add l ts tm) = get l' tm.
  Proof.
    rewrite add_spec.
    destruct (Loc.eq_dec l' l); auto.
    congruence.
  Qed.

  Definition join (lhs rhs:t): t :=
    fun loc => Time.join (lhs loc) (rhs loc).

  Lemma join_comm lhs rhs: join lhs rhs = join rhs lhs.
  Proof. apply LocFun.ext. i. apply Time.join_comm. Qed.

  Lemma join_assoc a b c: join (join a b) c = join a (join b c).
  Proof.
    apply LocFun.ext. i. apply Time.join_assoc.
  Qed.

  Lemma join_l lhs rhs: le lhs (join lhs rhs).
  Proof. ii. apply Time.join_l. Qed.

  Lemma join_r lhs rhs: le rhs (join lhs rhs).
  Proof. ii. apply Time.join_r. Qed.

  Lemma join_spec lhs rhs o
        (LHS: le lhs o)
        (RHS: le rhs o):
    le (join lhs rhs) o.
  Proof. unfold join. ii. apply Time.join_spec; auto. Qed.

  Definition singleton loc ts :=
    LocFun.add loc ts (LocFun.init Time.bot).

  Lemma singleton_spec loc ts c
        (LOC: Time.le ts (c loc)):
    le (singleton loc ts) c.
  Proof.
    ii. unfold singleton, LocFun.add, LocFun.find.
    condtac; subst; ss. apply Time.bot_spec.
  Qed.

  Lemma singleton_inv loc ts c
        (LE: le (singleton loc ts) c):
    Time.le ts (c loc).
  Proof.
    generalize (LE loc). unfold singleton, LocFun.add, LocFun.find.
    condtac; [|congr]. auto.
  Qed.

  Lemma le_join_l l r
        (LE: le r l):
    join l r = l.
  Proof.
    apply LocFun.ext. i.
    unfold join, Time.join, LocFun.find. condtac; auto.
    apply TimeFacts.antisym; auto.
  Qed.

  Lemma le_join_r l r
        (LE: le l r):
    join l r = r.
  Proof.
    apply LocFun.ext. i.
    unfold join, Time.join, LocFun.find. condtac; auto.
    exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt; eauto.
  Qed.

  Lemma antisym l r
        (LR: le l r)
        (RL: le r l):
    l = r.
  Proof.
    extensionality loc. apply TimeFacts.antisym; auto.
  Qed.

  Lemma time_le_TimeMap_join_l ts l r loc
        (L: Time.le ts (l loc)):
    Time.le ts (join l r loc).
  Proof.
    unfold join.
    unfold Time.join.
    condtac; eauto.
  Qed.

  Lemma time_le_TimeMap_join_r ts l r loc
        (L: Time.le ts (r loc)):
    Time.le ts (join l r loc).
  Proof.
    rewrite join_comm.
    eapply time_le_TimeMap_join_l; eauto.
  Qed.

  Lemma join_bot l:
    join l bot = l.
  Proof.
    eapply le_join_l.
    eapply bot_spec.
  Qed.
End TimeMap.

(** ** View *)
(** It is a pair of timemaps, one for non-atomic view and the other for the relaxed view.
    It is defined as (View) in Figure 5 in paper *)
Module View <: JoinableType.
  Structure t_ := mk {
    pln: TimeMap.t;
    rlx: TimeMap.t;
  }.
  Definition t := t_.

  Inductive wf (view:t): Prop :=
  | wf_intro
      (PLN_RLX: TimeMap.le (pln view) (rlx view))
  .
  Hint Constructors wf.

  Inductive opt_wf: forall (view:option View.t), Prop :=
  | opt_wf_some
      view
      (WF: wf view):
      opt_wf (Some view)
  | opt_wf_none:
      opt_wf None
  .
  Hint Constructors opt_wf.

  Definition eq := @eq t.

  Inductive le_ (lhs rhs:t): Prop :=
  | le_intro
      (PLN: TimeMap.le (pln lhs) (pln rhs))
      (RLX: TimeMap.le (rlx lhs) (rlx rhs))
  .
  Definition le := le_.

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation.
    ii. econs; refl.
  Qed.
  Next Obligation.
    ii. inv H. inv H0. econs; etrans; eauto.
  Qed.
  Hint Resolve le_PreOrder_obligation_2.

  Inductive opt_le: forall (lhs rhs:option t), Prop :=
  | opt_le_none
      rhs:
      opt_le None rhs
  | opt_le_some
      lhs rhs
      (LE: le lhs rhs):
      opt_le (Some lhs) (Some rhs)
  .
  Hint Constructors opt_le.

  Global Program Instance opt_le_PreOrder: PreOrder opt_le.
  Next Obligation.
    ii. destruct x; econs. refl.
  Qed.
  Next Obligation.
    ii. inv H; inv H0; econs. etrans; eauto.
  Qed.
  Hint Resolve opt_le_PreOrder_obligation_2.

  Lemma ext l r
        (PLN: (pln l) = (pln r))
        (RLX: (rlx l) = (rlx r))
    : l = r.
  Proof.
    destruct l, r. f_equal; auto.
  Qed.

  Definition bot: t := mk TimeMap.bot TimeMap.bot.

  Lemma bot_wf: wf bot.
  Proof. econs; refl. Qed.

  Lemma bot_spec (c:t): le bot c.
  Proof. econs; apply TimeMap.bot_spec. Qed.

  Definition join (lhs rhs:t): t :=
    mk (TimeMap.join (pln lhs) (pln rhs))
       (TimeMap.join (rlx lhs) (rlx rhs)).

  Lemma join_comm lhs rhs: join lhs rhs = join rhs lhs.
  Proof. unfold join. f_equal; apply TimeMap.join_comm. Qed.

  Lemma join_assoc a b c: join (join a b) c = join a (join b c).
  Proof.
    unfold join. ss. f_equal.
    - apply TimeMap.join_assoc.
    - apply TimeMap.join_assoc.
  Qed.

  Lemma join_l lhs rhs: le lhs (join lhs rhs).
  Proof. econs; apply TimeMap.join_l. Qed.

  Lemma join_r lhs rhs: le rhs (join lhs rhs).
  Proof. econs; apply TimeMap.join_r. Qed.

  Lemma join_spec lhs rhs o
        (LHS: le lhs o)
        (RHS: le rhs o):
    le (join lhs rhs) o.
  Proof.
    inv LHS. inv RHS.
    econs; apply TimeMap.join_spec; eauto.
  Qed.

  Lemma join_wf
        lhs rhs
        (LHS: wf lhs)
        (RHS: wf rhs):
    wf (join lhs rhs).
  Proof.
    econs.
    - apply TimeMap.join_spec.
      + etrans; [apply LHS|]. apply TimeMap.join_l.
      + etrans; [apply RHS|]. apply TimeMap.join_r.
  Qed.

  Definition bot_unless (cond:bool) (c:t): t :=
    if cond then c else bot.

  Lemma bot_unless_wf
        cond c
        (WF: wf c):
    wf (bot_unless cond c).
  Proof.
    destruct cond; ss. apply bot_wf.
  Qed.

  Definition singleton_ur loc ts :=
    mk (TimeMap.singleton loc ts)
       (TimeMap.singleton loc ts).

  Lemma singleton_ur_wf
        loc ts:
    wf (singleton_ur loc ts).
  Proof.
    econs; ss; refl.
  Qed.

  Lemma singleton_ur_spec loc ts c
        (WF: wf c)
        (TS: Time.le ts ((pln c) loc)):
    le (singleton_ur loc ts) c.
  Proof.
    econs; s;
      try apply TimeMap.bot_spec;
      try apply TimeMap.singleton_spec; auto.
    - etrans; eauto. apply WF.
  Qed.

  Lemma singleton_ur_inv loc ts c
        (LE: le (singleton_ur loc ts) c):
    Time.le ts ((pln c) loc).
  Proof.
    apply TimeMap.singleton_inv. apply LE.
  Qed.

  Definition singleton_rw loc ts :=
    mk TimeMap.bot
       (TimeMap.singleton loc ts).

  Lemma singleton_rw_wf
        loc ts:
    wf (singleton_rw loc ts).
  Proof.
    econs; ss; try refl. apply TimeMap.bot_spec.
  Qed.

  Lemma singleton_rw_spec loc ts c
        (WF: wf c)
        (TS: Time.le ts ((rlx c) loc)):
    le (singleton_rw loc ts) c.
  Proof.
    econs; s;
      try apply TimeMap.bot_spec;
      try apply TimeMap.singleton_spec; auto.
  Qed.

  Lemma singleton_rw_inv loc ts c
        (LE: le (singleton_rw loc ts) c):
    Time.le ts ((rlx c) loc).
  Proof.
    apply TimeMap.singleton_inv. apply LE.
  Qed.

  Definition singleton_ur_if (cond:bool) loc ts :=
    (if cond then singleton_ur else singleton_rw) loc ts.

  Lemma singleton_ur_if_wf
        cond loc ts:
    wf (singleton_ur_if cond loc ts).
  Proof.
    destruct cond; ss.
    - apply singleton_ur_wf.
    - apply singleton_rw_wf.
  Qed.

  Lemma singleton_ur_if_spec (cond:bool) loc ts c
        (WF: wf c)
        (TS: Time.le ts ((if cond then (pln c) else (rlx c)) loc)):
    le (singleton_ur_if cond loc ts) c.
  Proof.
    destruct cond; ss.
    - apply singleton_ur_spec; ss.
    - apply singleton_rw_spec; ss.
  Qed.

  Lemma singleton_ur_if_inv cond loc ts c
        (LE: le (singleton_ur_if cond loc ts) c):
    Time.le ts ((if cond then (pln c) else (rlx c)) loc).
  Proof.
    destruct cond; ss.
    - apply singleton_ur_inv. ss.
    - apply singleton_rw_inv. ss.
  Qed.

  Lemma le_join_l l r
        (LE: le r l):
    join l r = l.
  Proof.
    unfold join. destruct l. ss.
    f_equal; apply TimeMap.le_join_l; apply LE.
  Qed.

  Lemma le_join_r l r
        (LE: le l r):
    join l r = r.
  Proof.
    unfold join. destruct r. ss.
    f_equal; apply TimeMap.le_join_r; apply LE.
  Qed.

  Lemma antisym l r
        (LR: le l r)
        (RL: le r l):
    l = r.
  Proof.
    destruct l, r. inv LR. inv RL. ss. f_equal.
    - apply TimeMap.antisym; auto.
    - apply TimeMap.antisym; auto.
  Qed.

  Lemma opt_antisym l r
        (LR: opt_le l r)
        (RL: opt_le r l):
    l = r.
  Proof.
    inv LR; inv RL; ss. f_equal.
    apply antisym; ss.
  Qed.

  Lemma timemap_le_le tm1 tm2
        (LE: TimeMap.le tm1 tm2):
    le (mk tm1 tm1) (mk tm2 tm2).
  Proof. econs; eauto. Qed.

  Definition unwrap (view:option t): t :=
    match view with
    | Some view => view
    | None => bot
    end.

  Lemma unwrap_opt_wf
        view
        (WF: opt_wf view):
    wf (unwrap view).
  Proof.
    inv WF; ss. apply bot_wf.
  Qed.

  Lemma unwrap_opt_le
        view1 view2
        (WF: opt_le view1 view2):
    le (unwrap view1) (unwrap view2).
  Proof.
    inv WF; ss. apply bot_spec.
  Qed.

  Lemma opt_None_spec rhs:
    opt_le None rhs.
  Proof. econs. Qed.

  Lemma join_bot_l rhs:
    join bot rhs = rhs.
  Proof.
    apply antisym.
    - apply join_spec.
      + apply bot_spec.
      + refl.
    - apply join_r.
  Qed.

  Lemma join_bot_r lhs:
    join lhs bot = lhs.
  Proof.
    rewrite join_comm.
    apply join_bot_l.
  Qed.

  Lemma join_le
        v1 v2 w1 w2
        (LE1: le v1 w1)
        (LE2: le v2 w2):
    le (join v1 v2) (join w1 w2).
  Proof. eauto using join_spec, join_l, join_r. Qed.

  Lemma opt_le_ts
        v1 v2 loc
        (LE: opt_le v1 v2):
    Time.le ((rlx (unwrap v1)) loc) ((rlx (unwrap v2)) loc).
  Proof.
    inv LE; ss.
    - unfold TimeMap.bot. apply Time.bot_spec.
    - inv LE0. ss.
  Qed.

  (* supplemental lemmas *)
  Lemma le_r_join
        v1 v2 w
        (LE: le v1 v2):
    le v1 (join v2 w).
  Proof.
    rewrite <- join_bot_r with (lhs := v1).
    eapply join_le; eauto.
    eapply bot_spec.
  Qed.
End View.


(* 元論文 https://www2.math.su.se/reports/2001/11/ *)
(* 元記事 https://qiita.com/lotz/items/60c20189f931dd8e5e9f *)

(*
 * Ring の構造を真似て作る ?
 * https://coq.inria.fr/distrib/8.5beta3/stdlib/Coq.setoid_ring.Ring.html#
 * https://coq.inria.fr/distrib/8.5beta3/stdlib/Coq.setoid_ring.Ring_theory.html#
 *)

(* 可換モノイド https://github.com/palmskog/monoid-ssreflect *)

(*
 * 型クラスによる表現 https://m-hiyama.hatenablog.com/entry/20150124/1422063926
 * アンバンドル方式での半環 https://m-hiyama.hatenablog.com/entry/20150125/1422174390
 *)

From mathcomp Require Import ssreflect ssrnat.

Section Wheel.

Class BinOp (H: Set) := bin_op : H -> H -> H.

Definition Associative {H: Set} (op: BinOp H) :=
  forall(x y z: H), op x (op y z) = op (op x y) z.

Definition UnitLeft {H: Set} (op: BinOp H) (u: H) :=
  forall(x: H), op u x = x.

Definition UnitRight {H: Set} (op: BinOp H) (u: H) :=
  forall(x: H), op x u  = x.

Definition Commutative {H: Set} (op: BinOp H) :=
  forall(x y: H), op x y = op y x.

Definition Inv (H: Set) := H -> H.

Definition Involutive {H: Set} (f: Inv H) :=
  forall(x: H), f (f x) = x.

Definition AntiInvolutive {H: Set} (f: Inv H) (op: BinOp H) :=
  forall(x y: H), f (op x y) = op (f y) (f x).

Class CommutativeMonoid {H: Set} (unit: H) (op: BinOp H) := {
  assoc: Associative op;
  unit_l: UnitLeft op unit;
  unit_r: UnitRight op unit;
  comm: Commutative op
}.

Class CommutativeInvolutionMonoid {H: Set} (unit: H) (op: BinOp H) (inv: Inv H) := {
  commutative_monoid :> CommutativeMonoid unit op;

  involution: Involutive inv;
  anti_involution: AntiInvolutive inv op
}.

Class Add (H: Set) := add_op :> BinOp H.
Class Mul (H: Set) := mul_op :> BinOp H.

(* クラス定義中の中置演算子使用 https://stackoverflow.com/questions/48394056/using-implicit-type-class-parameters-in-coq-notation *)
(* 前置演算子を扱う方法はちょっとわからない *)

Delimit Scope wheel_scope with wheel.
Infix "+" := add_op: wheel_scope.
Infix "*" := mul_op: wheel_scope.

Open Scope wheel_scope.

Class Wheel {H: Set} (zero: H) (one: H) (add: Add H) (mul: Mul H) (inv: Inv H) := {
  wheel_add__commutative_monoid :> CommutativeMonoid zero add; (* 1 *)
  wheel_mul_commutative_involution_monoid :> CommutativeInvolutionMonoid one mul inv; (* 2 *)

  (* Distributivity *)
  wheel_distrib_l: forall(x y z: H), (x + y) * z + zero * z = x * z + y * z; (* 3 *)
  wheel_distrib_4: forall(x y z: H), x * inv y + z + zero * y = (x + y * z) * inv y; (* 4 *)

  (* Rules for zero-terms *)
  wheel_zero_idemponent: zero * zero = zero; (* 5 *)
  wheel_zero_6: forall(x y z: H), (x + zero * y) * z = x * z + zero * y; (* 6 *)
  wheel_zero_7: forall(x y: H), inv (x + zero * y) = inv x + zero * y; (* 7 *)
  wheel_zero_8: forall(x: H), x + zero * inv zero = zero * inv zero; (* 8 *)
}.

(* 実装 *)

Inductive nat_w : Set :=
| W : nat -> nat -> nat_w.

Definition zero := W 0 1.
Definition one := W 1 1.
Definition add n m :=
  match n, m with
  | W x y, W x' y' => W (x * y' + x' * y) (y * y')
  end.
Definition mul n m :=
  match n, m with
  | W x y, W x' y' => W (x * x') (y * y')
  end.
Definition inv n :=
  match n with
  | W x y => W y x
  end.

(* 証明: 上記の台集合よおび演算の構成がWheelを成すことを示す *)

Delimit Scope nat_wheel_scope with wheel.
Infix "+" := add: nat_wheel_scope.
Infix "*" := mul: nat_wheel_scope.

Open Scope nat_wheel_scope.

Lemma natWheel_assoc_add : Associative add.
Proof.
  rewrite /Associative.
  intros x y z.
  case x => a b; case y => c d; case z => e f.
  rewrite /=.
  rewrite !mulnDl.
  rewrite !mulnA.
  rewrite !addnA.
  rewrite -!mulnA.
  rewrite (_ : muln f b = muln b f). (* 演算子を使うと nat_w のスコープなのでパタンマッチに失敗する *)
  rewrite (_ : muln d b = muln b d).
  by [].
  by rewrite mulnC.
  by rewrite mulnC.
Qed.

Lemma natWheel_unit_l_add_zero : UnitLeft add zero.
Proof.
  rewrite /UnitLeft.
  intros x.
  case x => a b.
  rewrite /zero.
  rewrite /=.
  by rewrite mul0n add0n muln1 mul1n.
Qed.

Lemma natWheel_unit_r_add_zero : UnitRight add zero.
Proof.
  rewrite /UnitRight.
  intros x.
  case x => a b.
  rewrite /zero.
  rewrite /=.
  by rewrite muln1 mul0n addn0 muln1.
Qed.

Lemma natWheel_comm_add : Commutative add.
Proof.
  rewrite /Commutative.
  intros x y.
  case x => a b; case y => c d.
  rewrite /=.
  rewrite addnC.
  rewrite (_ : muln b d = muln d b).
  by [].
  by rewrite mulnC.
Qed.

Theorem natWheel_1 : CommutativeMonoid zero add.
Proof.
  split.
  apply natWheel_assoc_add.
  apply natWheel_unit_l_add_zero.
  apply natWheel_unit_r_add_zero.
  apply natWheel_comm_add.
Qed.

Lemma natWheel_assoc_mul : Associative mul.
Proof.
  rewrite /Associative.
  intros x y z.
  case x => a b; case y => c d; case z => e f.
  rewrite /=.
  by rewrite !mulnA.
Qed.

Lemma natWheel_unit_l_mul_one : UnitLeft mul one.
Proof.
  rewrite /UnitLeft.
  intros x.
  case x => a b.
  rewrite /zero.
  rewrite /=.
  by rewrite !mul1n.
Qed.

Lemma natWheel_unit_r_mul_one : UnitRight mul one.
Proof.
  rewrite /UnitRight.
  intros x.
  case x => a b.
  rewrite /zero.
  rewrite /=.
  by rewrite !muln1.
Qed.

Lemma natWheel_comm_mul : Commutative mul.
Proof.
  rewrite /Commutative.
  intros x y.
  case x => a b; case y => c d.
  rewrite /=.
  rewrite (_ : muln a c = muln c a).
  rewrite (_ : muln b d = muln d b).
  by [].
  by rewrite mulnC.
  by rewrite mulnC.
Qed.

Lemma natWheel_inv : Involutive inv.
Proof.
  rewrite /Involutive.
  intro x.
  case x => a b.
  by rewrite /=.
Qed.

Lemma natWheel_anti_inv : AntiInvolutive inv mul.
Proof.
  rewrite /AntiInvolutive.
  intros x y.
  case x => a b; case y => c d.
  rewrite /=.
  rewrite (_ : muln a c = muln c a).
  rewrite (_ : muln b d = muln d b).
  by [].
  by rewrite mulnC.
  by rewrite mulnC.
Qed.

Theorem natWheel_2 : CommutativeInvolutionMonoid one mul inv.
Proof.
  split.
  split.
  apply natWheel_assoc_mul.
  apply natWheel_unit_l_mul_one.
  apply natWheel_unit_r_mul_one.
  apply natWheel_comm_mul.
  apply natWheel_inv.
  apply natWheel_anti_inv.
Qed.

Theorem natWheel_3 : forall x y z : nat_w, (x + y) * z + zero * z = x * z + y * z.
Proof.
  intros.
  case x => a b; case y => c d; case z => e f.
  rewrite /=.
  rewrite mul1n 2!mul0n addn0 !mulnDl -!mulnA.
  rewrite (_ : muln d (mult e f) = muln e (mult d f)).
  rewrite (_ : muln b (mult e f) = muln e (mult b f)).
  rewrite (_ : muln d (mult f f) = muln f (mult d f)).
  by [].
  by rewrite mulnCA.
  by rewrite mulnCA.
  by rewrite mulnCA.
Qed.

Theorem natWheel_4 : forall x y z : nat_w, x * inv y + z + zero * y = (x + y * z) * inv y.
Proof.
  intros.
  case x => a b; case y => c d; case z => e f.
  rewrite /=.
  rewrite mul1n 2!mul0n addn0 !mulnDl -!mulnA.
  rewrite (_ : muln b (mult c d) = muln c (mult b d)).
  rewrite (_ : muln e (mult c (mult b d)) = muln c (mult e (mult b d))).
  rewrite (_ : muln c (mult f d) = muln d (mult f c)).
  by [].
  rewrite !mulnA mulnC -mulnA.
  rewrite (_ : muln c f = muln f c).
  by [].
  by rewrite mulnC.
  by rewrite mulnCA.
  rewrite !mulnA.
  rewrite (_ : muln b c = muln c b).
  by [].
  by rewrite mulnC.
Qed.

Theorem natWheel_5 : zero * zero = zero.
Proof.
  rewrite /=.
  rewrite mul0n mul1n.
  by rewrite /zero.
Qed.

Theorem natWheel_6 : forall x y z : nat_w, (x + zero * y) * z = x * z + zero * y.
Proof.
  intros.
  case x => a b; case y => c d; case z => e f.
  rewrite /=.
  rewrite !mul1n !mul0n !addn0 -!mulnA.
  rewrite (_ : muln d e = muln e d).
  rewrite (_ : muln d f = muln f d).
  by [].
  by rewrite mulnC.
  by rewrite mulnC.
Qed.

Theorem natWheel_7 : forall x y : nat_w, inv (x + zero * y) = inv x + zero * y.
Proof.
  intros.
  case x => a b; case y => c d.
  rewrite /=.
  rewrite !mul1n !mul0n !addn0.
  by [].
Qed.

Theorem natWheel_8 : forall x : nat_w, x + zero * inv zero = zero * inv zero.
Proof.
  intros.
  case x => a b.
  rewrite /=.
  rewrite !mul1n !mul0n !addn0 !muln0.
  by [].
Qed.

Instance natWheel : Wheel zero one add mul inv.
Proof.
  split.
  apply natWheel_1.
  apply natWheel_2.
  apply natWheel_3.
  apply natWheel_4.
  apply natWheel_5.
  apply natWheel_6.
  apply natWheel_7.
  apply natWheel_8.
Qed.

Definition fromNat n := W n 1.

(* Example example_1_2: forall(x y z: natWheel), ((x + 4 + 0 * y) * (2 + 0 * z) + (0 * x)) * (2 + 0 * z) = (x + 4) * 2 * 2 + 0 * x + 0 * y + 0 * z + 0 * z. *)

End Wheel.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import Basics Types.
Require Import NullHomotopy.
Require Import Homotopy.Suspension.
Require Import Pointed.
Require Import Truncations.
Require Import Spaces.Circle Spaces.TwoSphere.

(** * The spheres, in all dimensions. *)

Local Open Scope pointed_scope.
Local Open Scope trunc_scope.
Local Open Scope path_scope.

Generalizable Variables X A B f g n.

(** ** Definition, by iterated suspension. *)

(** To match the usual indexing for spheres, we have to pad the sequence with a dummy term [Sphere -2]. *)
Fixpoint Sphere (n : trunc_index)
  := match n return Type with
       | -2 => Empty
       | -1 => Empty
       | n'.+1 => Susp (Sphere n')
     end.

(** ** Pointed sphere for non-negative dimensions *)
Fixpoint psphere (n : nat) : pType
  := match n with
      | O => psusp Empty
      | S n' => psusp (psphere n')
     end.

Arguments Sphere : simpl never.
Arguments psphere : simpl never.

(** ** Explicit equivalences in low dimensions  *)

(** *** [Sphere 0] *)
Definition S0_to_Bool : (Sphere 0) -> Bool.
Proof.
  simpl. apply (Susp_rec true false). intros [].
Defined.

Definition Bool_to_S0 : Bool -> (Sphere 0).
Proof.
  exact (fun b => if b then North else South).
Defined.

Global Instance isequiv_S0_to_Bool : IsEquiv (S0_to_Bool) | 0.
Proof.
  apply isequiv_adjointify with Bool_to_S0.
  - intros [ | ]; exact 1.
  - refine (Susp_ind _ 1 1 _). intros [].
Defined.

Definition equiv_S0_Bool : Sphere 0 <~> Bool
  := Build_Equiv _ _ _ isequiv_S0_to_Bool.

(** *** [Sphere 1] *)
Definition S1_to_Circle : (Sphere 1) -> Circle.
Proof.
  apply (Susp_rec Circle.base Circle.base).
  exact (fun x => if (S0_to_Bool x) then loop else 1).
Defined.

Definition Circle_to_S1 : Circle -> (Sphere 1).
Proof.
  apply (Circle_rec _ North).
  exact (merid North @ (merid South)^).
Defined.

Global Instance isequiv_S1_to_Circle : IsEquiv (S1_to_Circle) | 0.
Proof.
  apply isequiv_adjointify with Circle_to_S1.
  - refine (Circle_ind _ 1 _).
    refine ((transport_paths_FFlr _ _) @ _).
    unfold Circle_to_S1; rewrite Circle_rec_beta_loop.
    rewrite ap_pp, ap_V.
    unfold S1_to_Circle. simpl. rewrite 2 Susp_rec_beta_merid. simpl.
    hott_simpl.
  - refine (Susp_ind (fun x => Circle_to_S1 (S1_to_Circle x) = x)
                     1 (merid South) _); intros x.
    refine ((transport_paths_FFlr _ _) @ _).
    unfold S1_to_Circle; rewrite (Susp_rec_beta_merid x).
    revert x. change (Susp Empty) with (Sphere 0).
    apply (equiv_ind (S0_to_Bool ^-1)); intros x.
    case x; simpl.
    2: apply concat_1p.
    unfold Circle_to_S1; rewrite Circle_rec_beta_loop.
    refine (whiskerR (concat_p1 _) _ @ _).
    apply moveR_Vp. hott_simpl.
Defined.

Definition equiv_S1_Circle : Sphere 1 <~> Circle
  := Build_Equiv _ _ _ isequiv_S1_to_Circle.

Definition pequiv_S1_Circle : psphere 1 <~>* [Circle, _].
Proof.
  srapply Build_pEquiv'.
  1: apply equiv_S1_Circle.
  reflexivity.
Defined.

(** *** [Sphere 2] *)
Definition S2_to_TwoSphere : (Sphere 2) -> TwoSphere.
Proof.
  apply (Susp_rec base base).
  apply (Susp_rec (idpath base) (idpath base)).
  apply (Susp_rec surf (idpath (idpath base))).
  apply Empty_rec.
Defined.

Definition TwoSphere_to_S2 : TwoSphere -> (Sphere 2).
Proof.
  apply (TwoSphere_rec (Sphere 2) North).
  refine (transport (fun x => x = x) (concat_pV (merid North)) _).
  refine (((ap (fun u => merid u @ (merid North)^)
               (merid North @ (merid South)^)))).
Defined.

Definition issect_TwoSphere_to_S2 : S2_to_TwoSphere o TwoSphere_to_S2 == idmap.
Proof.
  refine (TwoSphere_ind _ 1 _).
  refine (_ @ (concat_p1 _)).
  refine (_ @ (@concat_Ap (base = base) _ _
                          (fun p => (p^ @ ap S2_to_TwoSphere (ap TwoSphere_to_S2 p))^)
                          (fun x =>
                             (transport_paths_FFlr x 1)
                               @ ap (fun u => u @ x) (concat_p1 _)
                               @ ap (fun w => _ @ w) (inv_V x)^
                               @ (inv_pp _ _)^)
                          1 1 surf)^).
  refine (_ @ (concat_1p _)^).
  refine (_ @ (ap_compose (fun p => p^ @ ap S2_to_TwoSphere (ap TwoSphere_to_S2 p))
                          inverse
                          surf)^).
  refine (@ap _ _ (ap inverse) 1 _ _).
  refine (_ @ (concat2_ap_ap _ _ _)).
  refine (_ @ (ap (fun w => inverse2 surf @@ w)
                  (ap_compose (ap TwoSphere_to_S2) (ap S2_to_TwoSphere) surf))^).
  refine ((concat_Vp_inverse2 _ _ surf)^ @ _).
  refine ((concat_p1 _) @ _).
  refine (ap (fun p : 1 = 1 => inverse2 surf @@ p) _).

  symmetry. refine ((ap (ap (ap S2_to_TwoSphere))
                        (TwoSphere_rec_beta_surf (Sphere 2) North _)) @ _).
  refine ((ap_transport (concat_pV (merid North))
                        (fun z => @ap _ _ _ z z)
                        (ap (fun u => merid u @ (merid North)^)
                            (merid North @ (merid South)^))) @ _).

  refine ((ap (transport (fun z => ap S2_to_TwoSphere z = ap S2_to_TwoSphere z)
                         (concat_pV (merid North)))
              (ap_compose (fun u => merid u @ (merid North)^) (ap S2_to_TwoSphere)
                          (merid North @ (merid South)^))^) @ _).
  refine ((transport_paths_FlFr _ _) @ _). rewrite_moveR_Vp_p.
  refine ((ap (fun w => _ @ w)
              (ap_pp_concat_pV S2_to_TwoSphere (merid North))^) @ _).
  refine ((ap (fun w => _ @ (_ @ (_ @ w)))
              (concat_pV_inverse2 (ap S2_to_TwoSphere (merid North))
                                  _
                                  (Susp_rec_beta_merid North))^) @ _).
  refine ((@concat_Ap (Sphere 1) _
                      (fun x => ap S2_to_TwoSphere (merid x @ (merid North)^))
                      (fun x => Susp_rec 1 1
                                (Susp_rec surf 1
                                Empty_rec) x
                                @ 1)
                      (fun x => ap_pp S2_to_TwoSphere (merid x) (merid North)^
                                @ ((1 @@ ap_V S2_to_TwoSphere (merid North))
                                @ ((Susp_rec_beta_merid x
                                   @@ inverse2 (Susp_rec_beta_merid North))
                                @ 1)))
                      North North (merid North @ (merid South)^)) @ _). f_ap.
  { refine (_ @ (ap_pp_concat_pV _ _)).
    refine (ap (fun w => _ @ (_ @ w)) (concat_pV_inverse2 _ _ _)). }
  refine ((concat2_ap_ap (Susp_rec 1 1 (Susp_rec surf 1
                                         Empty_rec))
                         (fun _ => 1)
                         (merid North @ (merid South)^))^ @ _).
  refine ((ap (fun w => _ @@ w) (ap_const _ _)) @ _).
  refine ((concat2_p1 _) @ _). refine ((whiskerR_p1_1 _) @ _).
  refine ((ap_pp _ (merid North) (merid South)^) @ _).
  refine (_ @ (concat_p1 _)). f_ap.
  - refine (Susp_rec_beta_merid North).
  - refine (ap_V _ _ @ _). refine (@inverse2 _ _ _ _ 1 _).
    refine (Susp_rec_beta_merid South).
Defined.

Definition issect_S2_to_TwoSphere : TwoSphere_to_S2 o S2_to_TwoSphere == idmap.
Proof.
  intro x.
  refine ((Susp_rec_eta_homot (TwoSphere_to_S2 o S2_to_TwoSphere) x) @ _). symmetry.
  generalize dependent x.
  refine (Susp_ind _ 1 (merid North)^ _).
  intro x.
  refine ((transport_paths_FlFr (f := fun y => y) _ _) @ _).
  rewrite_moveR_Vp_p. refine ((concat_1p _) @ _).
  refine (_ @ (ap (fun w => w @ _) (ap_idmap _)^)).
  refine ((Susp_rec_beta_merid _) @ _).
  path_via (ap TwoSphere_to_S2 (ap S2_to_TwoSphere (merid x))).
  { apply (ap_compose S2_to_TwoSphere TwoSphere_to_S2 (merid x)). }
  path_via (ap TwoSphere_to_S2
               (Susp_rec 1 1 (Susp_rec surf 1 Empty_rec) x)).
  { repeat f_ap. apply Susp_rec_beta_merid. }
  symmetry. generalize dependent x.

  simple refine (Susp_ind _ (concat_pV (merid North)) _ _).
  - refine (_ @ (concat_pV (merid North))).
    apply (ap (fun w => merid w @ (merid North)^) (merid South)^).
  - intro x.
    refine ((transport_paths_FlFr (merid x) (concat_pV (merid North))) @ _).
    rewrite_moveR_Vp_p. symmetry. refine ((dpath_path_lr _ _ _)^-1 _).
    refine ((ap (transport _ _) (ap_pp _ (merid x) (merid South)^)^) @ _).
    refine (_ @ (ap_compose (Susp_rec 1 1
                              (Susp_rec surf 1
                                Empty_rec))
                            (ap TwoSphere_to_S2) (merid x))^).
    refine (_ @ (ap (ap02 TwoSphere_to_S2) (Susp_rec_beta_merid _)^)).
    symmetry. generalize dependent x.

    simple refine (Susp_ind _ _ _ _).
    + refine (TwoSphere_rec_beta_surf _ _ _).
    + refine (_ @ (ap (fun w => transport _ _ (ap _ w))
                      (concat_pV (merid South))^)).
      refine (_ @ (transport_paths_lr _ _)^).
      refine (_ @ (ap (fun w => w @ _) (concat_p1 _)^)).
      refine (concat_Vp _)^.
    + apply Empty_ind.
Defined.

Global Instance isequiv_S2_to_TwoSphere : IsEquiv (S2_to_TwoSphere) | 0.
Proof.
  apply isequiv_adjointify with TwoSphere_to_S2.
  - apply issect_TwoSphere_to_S2.
  - apply issect_S2_to_TwoSphere.
Defined.

Definition equiv_S2_TwoSphere : Sphere 2 <~> TwoSphere
  := Build_Equiv _ _ _ isequiv_S2_to_TwoSphere.

(** ** Truncation and connectedness of spheres. *)

(** S0 is 0-truncated. *)
Global Instance istrunc_s0 : IsHSet (Sphere 0).
Proof.
  srapply (istrunc_isequiv_istrunc _ S0_to_Bool^-1).
Defined.

(** S1 is 1-truncated. *)
Global Instance istrunc_s1 `{Univalence} : IsTrunc 1 (Sphere 1).
Proof.
  srapply (istrunc_isequiv_istrunc _ S1_to_Circle^-1).
Defined.

Global Instance isconnected_sn n : IsConnected n.+1 (Sphere n.+2).
Proof.
  induction n.
  { srapply contr_inhabited_hprop.
    apply tr, North. }
  apply isconnected_susp.
Defined.

(** ** Truncatedness via spheres  *)

(** We show here that a type is n-truncated if and only if every map from the (n+1)-sphere into it is null-homotopic.  (One direction of this is of course the assertion that the (n+1)-sphere is n-connected.) *)

(** TODO: re-type these lemmas in terms of truncation. *)

Fixpoint allnullhomot_trunc {n : trunc_index} {X : Type} `{IsTrunc n X}
  (f : Sphere n.+1 -> X) {struct n}
: NullHomotopy f.
Proof.
  destruct n as [ | n'].
  - exists (center X). intros [].
  - apply nullhomot_susp_from_paths.
    rapply allnullhomot_trunc.
Defined.

Fixpoint istrunc_allnullhomot {n : trunc_index} {X : Type}
  (HX : forall (f : Sphere n.+2 -> X), NullHomotopy f) {struct n}
: IsTrunc n.+1 X.
Proof.
  destruct n as [ | n'].
  - (* n = -2 *) apply hprop_allpath.
    intros x0 x1. set (f := (fun b => if (S0_to_Bool b) then x0 else x1)).
    set (n := HX f). exact (n.2 North @ (n.2 South)^).
  - (* n ≥ -1 *) intros x0 x1.
    apply (istrunc_allnullhomot n').
    intro f. apply nullhomot_paths_from_susp, HX.
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable ltA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable isosceles_ : Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable deftriangle_1 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_2 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable lemma_NCorder_3 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable lemma_congruencesymmetric_4 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable defisosceles_5 : (forall A B C : Universe, (isosceles_ A B C -> (triangle_ A B C /\ cong_ A B A C))).
Variable defisosceles2_6 : (forall A B C : Universe, ((triangle_ A B C /\ cong_ A B A C) -> isosceles_ A B C)).
Variable proposition_05_7 : (forall A B C : Universe, (isosceles_ A B C -> congA_ A B C A C B)).
Variable lemma_equalanglessymmetric_8 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_ABCequalsCBA_9 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_equalanglestransitive_10 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_angleorderrespectscongruence_11 : (forall A B C D E F P Q R : Universe, ((ltA_ A B C D E F /\ congA_ P Q R D E F) -> ltA_ A B C P Q R)).
Variable lemma_angletrichotomy_12 : (forall A B C D E F : Universe, (ltA_ A B C D E F -> ~(ltA_ D E F A B C))).
Variable proposition_18_13 : (forall A B C : Universe, ((triangle_ A B C /\ lt_ A B A C) -> ltA_ B C A A B C)).
Variable lemma_angleorderrespectscongruence2_14 : (forall A B C D E F Xa Xb Xc : Universe, ((ltA_ A B C D E F /\ congA_ Xa Xb Xc A B C) -> ltA_ Xa Xb Xc D E F)).
Variable lemma_equalanglesreflexive_15 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C A B C)).
Variable lemma_angledistinct_16 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> (A <> B /\ (B <> C /\ (A <> C /\ (Xa <> Xb /\ (Xb <> Xc /\ Xa <> Xc))))))).
Variable lemma_trichotomy1_17 : (forall A B C D : Universe, ((~(lt_ A B C D) /\ (~(lt_ C D A B) /\ (A <> B /\ C <> D))) -> cong_ A B C D)).

Theorem proposition_19_18 : (forall A B C : Universe, ((triangle_ A B C /\ ltA_ B C A A B C) -> lt_ A B A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Arith.
Require Import List.

Inductive tree:=
|NULL:tree
|Tree:nat->tree->tree->tree.

Fixpoint eval_nodes (t:tree):nat:=
  match t with
  |NULL=>O
  |Tree _ l r=>S ((eval_nodes l)+(eval_nodes r))
  end.

Fixpoint insert (e:nat) (t:tree):tree:=
  match t with
  |NULL=>Tree e NULL NULL
  |Tree x l r=>if leb e x then Tree x (insert e l) r
               else Tree x l (insert e r)
  end.

Fixpoint insert_from_list (t:tree) (l:list nat):tree:=
  match l with
  |nil=>t
  |x::l'=>insert_from_list (insert x t) l'
  end.

Fixpoint locate (t:tree) (e:nat):nat:=
  match t with
  |NULL=>0
  |Tree x l r=>if beq_nat x e then S ((locate l e)+(locate r e))
               else (locate l 2)+(locate r e)
  end.

Eval vm_compute in locate (Tree 1 NULL NULL) 2.


Require Export seasons.
Require Export month.

Definition month_season (m:month) : season :=
  match m with
  | January | February | March => Winter
  | April  | May  | June => Spring
  | July  | August | September => Summer
  | October | November | December => Autumn
  end.

Definition month_season' :=
 month_rec (fun _ => season)
           Winter Winter Winter
           Spring Spring Spring
           Summer Summer Summer
           Autumn Autumn Autumn.

Lemma  month_season_convertible : month_season = month_season'.
Proof refl_equal month_season.


Require Import Utf8.
Require AST.
Import Coqlib.
Import AST.

Section MIN_LIST.

Definition min_name_below (n: ident) (ns: list ident) : ident :=
  fold_left Pos.min ns n.

Definition min_name (ns: list ident) : option ident :=
  match ns with
  | nil => None
  | n :: ns => Some (min_name_below n ns)
  end.

Lemma min_name_below_iff n ns :
  (n = min_name_below n ns ∨ In (min_name_below n ns) ns) ∧
  (min_name_below n ns <= n)%positive ∧
  (∀ x, In x ns → min_name_below n ns <= x)%positive.
Proof.
  revert n. elim ns; clear.
  simpl. intuition.
  intros n' ns IH n.
  specialize (IH (Pos.min n n')).
  destruct IH as (IH & IH' & IH'').
  split. clear -IH. simpl.
  destruct IH as [ IH | IH ]. 2: intuition.
  generalize (Pos.min_spec n n'). intros [(_ & H) | (_ & H)].
  left. congruence. right; left. simpl. congruence.
  clear IH. split.
  simpl. etransitivity. apply IH'. Psatz.lia.
  intros x [ -> | IN ].
  simpl. etransitivity. apply IH'. Psatz.lia.
  exact (IH'' _ IN).
Qed.

Lemma min_name_iff ns :
  match min_name ns with
  | None => ns = nil
  | Some n => In n ns ∧ ∀ x, In x ns → n <= x
  end%positive.
Proof.
  destruct ns as [ | n ns ]. reflexivity.
  generalize (min_name_below_iff n ns). simpl.
  intuition; subst; Psatz.lia.
Qed.

End MIN_LIST.

Section MAP.

  Context {A B: Type} (f: A → B).

  Lemma map_eq_cons b bs m :
    b :: bs = map f m →
    ∃ a m', m = a :: m' ∧ b = f a ∧ bs = map f m'.
  Proof.
    destruct m as [ | a m ]; intros H; inversion H; clear H. subst. eauto.
  Qed.

  Lemma map_eq_app ma mbL mbR :
    map f ma = mbL ++ mbR →
    ∃ maL maR,
      ma = maL ++ maR ∧
      map f maL = mbL ∧
      map f maR = mbR.
  Proof.
    revert mbL mbR. elim ma; clear.
    intros [ | ? ? ]. 2: discriminate.
    intros [ | ? ? ]. 2: discriminate.
    intros _. exists nil, nil. simpl. eauto.
    intros a ma IH [ | b mbL].
    intros [ | b mbR ]. discriminate. simpl.
    intros H. inv H. specialize (IH nil _ eq_refl). destruct IH as (maL & maR & -> & N & IH).
    apply map_eq_nil in N. subst maL.
    exists nil, (a :: maR). simpl in *. eauto.
    intros mbR H; inv H. edestruct IH as (maL & maR & -> & IHL & IHR). eassumption.
    clear IH.
    exists (a :: maL), maR. apply (conj eq_refl). simpl. intuition congruence.
  Qed.

  Lemma map_eq_forall2 {C} (g: C → B) ma mb :
    map f ma = map g mb ↔ Forall2 (λ a b, f a = g b) ma mb.
  Proof.
    revert mb; elim ma; clear.
    - intros mb; split; intros H.
      + symmetry in H. apply map_eq_nil in H. rewrite H. left.
      + inv H. reflexivity.
    - intros a ma IH mb; split; intros H.
      + destruct mb. discriminate. inv H. right. assumption. apply IH. assumption.
      + inv H. simpl. f_equal. assumption. apply IH. assumption.
  Qed.

End MAP.

Module FOR_ALL_BYTE.
Section FOR_ALL_BYTE.

Coercion is_true : bool >-> Sortclass.

Fixpoint forallb {A} (f: A → bool) (m: list A) : bool :=
  match m with
  | nil => true
  | a :: m' => if f a then forallb f m' else false
  end.

Fixpoint forallb_forall {A} (f: A → bool) (m: list A) :
  forallb f m → ∀ a, In a m → f a = true.
Proof.
  destruct m as [ | a m ]. intros _ a ().
  simpl.
  intros H a' [ -> | IN ].
  destruct (f a'); auto.
  destruct (f a); auto.
  apply (forallb_forall A f m H a' IN).
  congruence.
Qed.

Lemma In_seq x y z :
  (x ≤ y → y < x + z → In y (seq x z))%nat.
Proof.
  revert x y. induction z as [ | z IH ].
  intros. zify. Psatz.lia.
  intros x y H H0. simpl.
  assert (x = y ∨ S x ≤ y)%nat as K by (Psatz.lia).
  destruct K; auto.
  right. apply IH; auto. Psatz.lia.
Qed.

Import Integers.
Definition all_the_bytes_def : list byte :=
  List.map (λ n, Byte.repr (Z.of_nat n)) (seq 0 256)%nat.

Definition all_the_bytes : list byte :=
  Eval vm_compute in all_the_bytes_def.

Definition for_all_byte (f: byte → bool) : bool :=
  forallb f all_the_bytes.

Lemma for_all_byte_correct f :
  for_all_byte f → ∀ b : byte, f b.
Proof.
  unfold for_all_byte.
  intros H b.
  apply (forallb_forall _ _ H).
  change (In b all_the_bytes_def).
  apply in_map_iff.
  exists (Z.to_nat (Byte.unsigned b)).
  pose proof (Byte.unsigned_range b) as R.
  change Byte.modulus with 256%Z in R.
  rewrite Z2Nat.id, Byte.repr_unsigned.
  split. easy.
  apply In_seq; zify; try Psatz.lia.
  rewrite Z2Nat.id; Psatz.lia.
  Psatz.lia.
Qed.

End FOR_ALL_BYTE.
End FOR_ALL_BYTE.


Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma prime174550993 : prime 174550993.
Proof.
 apply (Pocklington_refl
         (Pock_certif 174550993 5 ((11, 1)::(3, 1)::(2,4)::nil) 34)
        ((Proof_certif 11 prime11) ::
         (Proof_certif 3 prime3) ::
         (Proof_certif 2 prime2) ::
          nil)).
 vm_cast_no_check (refl_equal true).
Qed.

Lemma prime4567890123456789012345689: prime  4567890123456789012345689.
apply (Pocklington_refl

(SPock_certif
4567890123456789012345689
2
((570986265432098626543211, 1)::nil))
(
(Ell_certif
570986265432098626543211
4566
((125051744509636077691,1)::nil)
570986265432098626449131
9834496
0
3136)
::
(Ell_certif
125051744509636077691
138775
((901111472016823,1)::nil)
0
192
4
16)
::
(SPock_certif
901111472016823
2
((174550993, 1)::nil))
:: (Proof_certif 174550993 prime174550993) :: nil)).
vm_cast_no_check (refl_equal true).
Time Qed.


From mathcomp Require Import ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import Coq.Logic.Classical.
Require Import Coq.Logic.Decidable.

Section Logic_Pred_Theories.
  Variable U:Type.
  Variable a0:U.

  Lemma forall_bound_variable_and_dist_iff:
    forall (A B:U->Prop), ((forall (x:U), A x) /\ (forall (x:U), B x)) <-> forall (x:U), A x /\ B x.
  Proof.
    move => A B.
    rewrite /iff.
    split.
    (* forall (A B:U->Prop), ((forall (x:U), A x) /\ (forall (x:U), B x)) -> forall (x:U), A x /\ B x. *)
    move => H x.
    split.
    inversion H.
    apply H0.
    inversion H.
    apply H1.
    (* forall (A B:U->Prop), (forall (x:U), A x /\ B x) -> (forall (x:U), A x /\ forall (x:U), B x). *)
    move => H.
    split; apply H.
  Qed.

  Lemma forall_bound_variable_and_dist_iff_2:
    forall (A B:U->U->Prop), ((forall (x y:U), A x y) /\ (forall (x y:U), B x y)) <-> forall (x y:U), A x y /\ B x y.
  Proof.
    move => A B.
    rewrite /iff.
    split.
    case => H0 H1 x y.
    split.
    apply H0.
    apply H1.
    move => H.
    split; apply H.
  Qed.

  Lemma forall_bound_variable_or_dist:
    forall (A B:U->Prop), (forall (x:U), A x) \/ (forall (x:U), B x) -> forall (x:U), A x \/ B x.
  Proof.
    move => A B H x.
    inversion H.
    left.
    apply H0.
    right.
    apply H0.
  Qed.

  Lemma forall_bound_variable_and_out:
    forall (A:U->Prop) (C:Prop), (C /\ forall (x:U), A x) <-> forall (x:U), C /\ A x.
  Proof.
    move => A.
    rewrite /iff.
    split.
    case => HC.
    move => HA x.
    split.
    apply HC.
    apply HA.
    move => H.
    suff: C /\ A a0.
    case => HC HA.
    split.
    apply HC.
    apply H.
    apply H.
  Qed.

  Lemma forall_bound_variable_or_out:
    forall (A:U->Prop) (C:Prop), (C \/ forall (x:U), A x) <-> (forall (x:U), C \/ A x).
  Proof.
    move => A.
    rewrite /iff.
    split.
    (* (C \/ forall (x:U), A x) -> (forall (x:U), C \/ A x) *)
    case.
    move => HC x.
    left.
    apply HC.
    move => H x.
    right.
    apply H.
    (* (forall (x:U), C \/ A x) -> (C \/ forall (x:U), A x)  *)
    move => H.
    apply imp_not_l.
    apply classic.
    move => H0.
    move => x.
    move: H0.
    apply imp_not_l.
    apply classic.
    apply H.
  Qed.

  Lemma forall_bound_variable_and_out_2:
    forall (A B:U->Prop), ((forall (x:U), A x) /\ (forall (y:U), B y)) <-> (forall (x y:U), A x /\ B y).
  Proof.
    +move => A B.
     rewrite /iff.
     split.
     ++case => HA HB x y.
       split.
       apply HA.
       apply HB.
     ++move => H.
       split.
       move => x.
       apply H.
       apply x.
       move => y.
       apply H.
       apply y.
  Qed.

  Lemma forall_bound_or_dist_2:
    forall (A B:U -> Prop), (forall (t s:U), ((A t) \/ (B s))) -> (forall (t:U), (A t)) \/ (forall (s:U), (B s)).
  Proof.
    move => A B H.
    apply imp_not_l.
    apply classic.
    move => H0 s.
    move: H0.
    apply imp_not_l.
    apply classic.
    apply or_comm.
    apply forall_bound_variable_or_out.
    move => t.
    apply or_comm.
    apply H.
  Qed.

End Logic_Pred_Theories.


Require Import Ssreflect.ssreflect.

Lemma Nikov A (P : A -> A -> Prop):
  (exists !x, exists y, P x y) ->
  (exists !x, exists y, P y x) ->
  (exists !x, exists !y, P x y).
Proof.
case=>x1[[y1 Pxy1]] G1[x2[[y2 Pxy2]] G2]; exists y2; split.
- by exists x2; split=>// x0 Pxy0; apply: G2; exists y2.
move=>x'. move:(G1 x')=>E G3.
rewrite -E; last by case: G3=>y'; case=> Z _; exists y'.
by apply/eq_sym; apply: G1; exists x2.
Qed.

Require Import Ssreflect.eqtype Ssreflect.ssrbool.

Definition Q x y : Prop :=
  (x == true) && (y == true) || (x == false).

Lemma qlm : (exists !x, exists !y, Q x y).
Proof.
exists true; split; first by exists true; split=> //; case=>//.
case=>//; rewrite /Q; case; case=>/=; case=>_ G.
- by move:(G false (eqxx false)).
by move:(G true (eqxx true)).
Qed.

Lemma Nikov2 :
  (forall A (P : A -> A -> Prop),
   (exists !x, exists !y, P x y) ->
   (exists !x, exists y, P x y) /\ (exists !x, exists y, P y x)) ->
  False.
Proof.
move/(_ _ _ qlm); rewrite /Q/=; case=> H1 H2.
case: H1; case; case; case; case=> //= _.
- move=>G1; move:(G1 false)=>/=G2.
  by suff: true = false by []; last by apply: G2; exists true.
- move=>G1; move:(G1 true)=>/=G2.
  by suff: false = true by []; last by apply: G2; exists true.
- move=>G1; move:(G1 true)=>/=G2.
  by suff: false = true by []; last by apply: G2; exists true.
Qed.


From Ssreflect Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype.
From MathComp Require Import div finfun bigop finset.

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

Print set_type.
Set Printing All.
Print set_type.
Unset Printing All.

Goal FinSet [ffun x : 'I_3 => true] = setT.
apply/setP => /= x.
rewrite {1}SetDef.pred_of_setE /=.
rewrite {1}/in_mem.
rewrite {1}/mem.
rewrite /=.
rewrite ffunE.
rewrite in_setT.
done.
Qed.

Section finset_example.

Variable T : finType.
Variables A B C : {set T}.

(* use setP *)
Lemma exo38 : (A :&: B) :|: C = (A :|: C) :&: (B :|: C).
(* (A \cup B) \cap C = (A \cap C) \cup (B \cap C) *)
Proof.
Abort.

Variables f : nat -> {set T}.

Lemma exo39 : A :&: \bigcup_(i : 'I_3) f i = \bigcup_(i : 'I_3) (A :&: f i).
Proof.
Abort.

Variable U : finType.

Lemma exo40 (h : {ffun T -> U}) :
  injective h -> #| T | <= #| U |.
Proof.
Abort.

End finset_example.