(** * TAL-0 Typed Assembly Language *)

(** Based on paper by Greg Morrisett , TAL-0 is the design of a RISC-style typed assembly language which focuses on control-flow safety. This post provides a mechanized metatheory, particularly a machine checked proof of soundness of the TAL-0 type system as proposed by the author in section 4.2.10 of the book Advanced Topics in Types and Programming Languages.  *)

(** The TAL-0 language runs on an abstract machine which is represented by 3 components :

1. A heap H which is a finite, partial map from labels to heap values

2. a register file R which is a total map from registers to values, and

3. a current instruction sequence I.
 *)

Require Import Bool Arith Vector LibTactics.
Require Import Maps.

Definition registers := total_map nat.
Definition empty_regs : registers := t_empty 0.

Inductive val : Type :=
| ANum : nat -> val
| AReg : nat -> val
| ALab : nat -> val.

(** We denote addresses of instructions stored in the heap as labels. Unlike a typical machine where labels are resolved to some machine address, which are integers, we maintain a distinction between labels and arbit integers, as this complies with our goal to state and prove the control-flow safety i.e. we can only branch to a valid label, and not to any arbit integer. This will ensure that the machine never gets stuck while trying to do some invalid operation. *)
(*define relations for aeval , ieval*)
Fixpoint aeval (a : val) (R : registers) : nat :=
  match a with
  | ANum n => n
  | AReg d => R (Id d)
  | ALab l => l
  end.

Inductive instr : Type :=
| IMov : forall d : nat,
    val -> instr
| IAdd : forall d s : nat,
    instr
| ISub : forall d v : nat,
    instr
| IIf : forall d : nat,
    val -> instr.

Inductive instr_seq : Type :=
| ISeq : instr -> instr_seq -> instr_seq
| IJmp : val -> instr_seq.

(** Simple Notations are chosen for the sake of clarity while writing programs.*)
Notation "'R(' d ')' ':=' a" :=
  (IMov d (ANum a)) (at level 60).
Notation "'R(' d ')' '+:=' 'R(' s ')'" :=
  (IAdd d s) (at level 60).
Notation "'R(' s ')' '-:=' v" :=
  (ISub s v) (at level 60).
Notation "i1 ;; i2" :=
  (ISeq i1 i2) (at level 80, right associativity).
Notation "'JIF' 'R(' d ')' v" :=
  (IIf d (ANum v)) (at level 70).
Notation "'JMP' v" :=
  (IJmp (ALab v)) (at level 80).
Notation "'JMP' 'R(' r ')'" :=
  (IJmp (AReg r)) (at level 80).

Check JIF R(1) 2.
Check R(1) := 10.
Check R(2) +:= R(1).
Check R(2) -:= 1.
Check R(2) +:= R(1) ;; R(2) -:= 1 ;; JMP 2.
Check JMP 2.
Check JMP R(2).

Definition heaps := partial_map instr_seq.
Definition empty_heap : heaps := empty.

(* Machine State *)
Inductive st : Type :=
| St : heaps -> registers -> instr_seq -> st.

(** Evaluation of instructions is supposed to change the Machine State and thus some of its components H, R or I. These changes are posed as relations between initial and final state of the machine. *)
Inductive ieval : st -> st -> Prop :=
| R_IMov : forall H R I d a,
    ieval (St H R (R(d) := a ;; I)) (St H (t_update R (Id d) a) I)
| R_IAdd : forall H R I d s,
    ieval (St H R (R(d) +:= R(s) ;; I)) (St H (t_update R (Id d) (aeval (AReg d) R + aeval (AReg s) R)) I)
| R_ISub : forall H R I d v,
    ieval (St H R (R(d) -:= v ;; I)) (St H (t_update R (Id d) (aeval (AReg d) R - aeval (ANum v) R)) I)
| R_IJmp_Succ : forall H R I' a l,
    l = (aeval a R) -> H (Id l) = Some I' -> ieval (St H R (JMP l)) (St H R I')
| R_IJmpR_Succ : forall H R I' r,
    H (Id (R (Id r))) = Some I' -> ieval (St H R (JMP R(r))) (St H R I')
| R_IJmp_Fail : forall H R I a,
    H (Id (aeval a R)) = None -> ieval (St H R I) (St H R I)
| R_IIf_EQ : forall H R I I2 r v,
    aeval (AReg r) R = 0 -> (H (Id v)) = Some I2 -> ieval (St H R (JIF R(r) v ;; I)) (St H R I2)
| R_IIf_NEQ : forall H R I r v,
    aeval (AReg r) R <> 0 -> ieval (St H R (JIF R(r) v ;; I)) (St H R I)
| R_ISeq : forall st st' st'',
    ieval st st' -> ieval st' st'' -> ieval st st''.

(** Example of a program fragment that multiplies 2 numbers stored in registers 1 and 2 and stores their product in register 3, before finally looping in its final state register 4. *)
Definition init_heap := update (update (update empty_heap (Id 1) (R(3) := 0 ;; JMP 2)) (Id 2) (JIF R(1) 3 ;; R(2) +:= R(3) ;; R(1) -:= 1 ;; JMP 2) ) (Id 3) (JMP R(4)).

Definition init_regs : registers :=  (t_update (t_update  (t_update (t_update (t_update empty_regs (Id 5) 1) (Id 6) 2) (Id 7) 3) (Id 1) 1) (Id 2) 2).
Definition final_regs : registers := (t_update (t_update (t_update  (t_update (t_update (t_update empty_regs (Id 5) 1) (Id 6) 2) (Id 4) 1) (Id 1) 0) (Id 2) 2) (Id 3) 2).

Eval compute in init_heap (Id (init_regs (Id 6))).

(* jump to a label proof *)
Example ieval_example1 : ieval (St init_heap init_regs
                                   (R(3) := 0 ;; JMP 2))
                               (St init_heap (t_update init_regs (Id 3) 0)
                                   (JIF R(1) 3 ;; R(2) +:= R(3) ;; R(1) -:= 1 ;; JMP 2)).
Proof.
  apply R_ISeq with (St init_heap (t_update init_regs (Id 3) 0) (IJmp (ALab 2))).
  apply R_IMov.
  apply R_IJmp_Succ with (a := ALab 2).
  simpl.
  reflexivity.
  unfold init_heap.
  rewrite update_neq.
  rewrite update_eq.
  reflexivity.
  rewrite <- beq_id_false_iff; trivial.
Qed.

(** The types consist of
1. int -> represents arbit integer stored in a register

2. reg -> a type constructor. Takes as input, the type of the register, to which this register is pointing.

3. code -> takes as input a typing context Γ, and gives type (code Γ) which is the type of an instruction sequence that expects type of the Register file to be Γ before it begins execution

4. arrow -> represents type of a single instruction (excluding JMP), which expects register file of type Γ1 before execution, and changes it to Γ2 after it has executed.

5. T -> It is the super type. It is used to represent the type of a register in R, which contains the label of the instruction currently executing. Because in such a case, we have the equation : Γ (r) = code Γ, which in the absence of subtyping or polymorphic types can't be solved. Hence T is assigned the type for such a register as it subsumes all types including itself. When we jump through a register of type T, we forget the type assigned to it, and reassign T to it.
Morrisett's paper uses the polymorphic type for due to some more benefits it affords. However we have used T type for its simplicity.
 *)

Inductive ty : Type :=
| int : ty
| reg : ty -> ty
| code : partial_map ty -> ty
| arrow : partial_map ty -> partial_map ty -> ty
| True : ty.

Definition context := partial_map ty.

(* register file types *)
Definition empty_Gamma : context := empty.

(* heap types *)
Definition empty_Psi : context := empty.

(** The Typing Rules *)
(** Ψ is a partial map containing types of instruction sequences. As all instruction sequences end in a JMP statement, all valid values in Ψ are Some (code Γ) where Γ is the initial type state of register expected by that instruction sequence. Now, typing rules may require presence of either both Ψ and Γ, or only Ψ or neither. Hence, we introduce a combined context structure, that handles all the 3 cases. *)
Inductive cmbnd_ctx :=
| EmptyCtx : cmbnd_ctx
| PsiCtx : context -> cmbnd_ctx
| PsiGammaCtx : context -> context -> cmbnd_ctx.

(** Typing rules for arithmetic expressions *)
Inductive ahas_type : cmbnd_ctx -> val -> ty -> Prop :=
| S_Int : forall Ψ n,
    ahas_type (PsiCtx Ψ) (ANum n) int
| S_Lab : forall Ψ Γ l v R,
    Ψ (Id l) = Some (code Γ) -> l = aeval (ALab v) R -> ahas_type (PsiCtx Ψ) (ALab v) (code Γ)
| S_Reg : forall Ψ Γ r,
    Γ (Id r) = Some (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int)
| S_RegV : forall Ψ Γ r,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg (code Γ))
| S_RegT : forall Ψ Γ r,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg r) True
| S_Val : forall Ψ Γ a tau,
    ahas_type (PsiCtx Ψ) a tau -> ahas_type (PsiGammaCtx Ψ Γ) a tau.

Hint Constructors ahas_type.

(** Typing rules for instructions *)
Inductive ihas_type : cmbnd_ctx -> instr -> ty -> Prop :=
| S_Mov : forall Ψ Γ R d a tau,
    ahas_type (PsiGammaCtx Ψ Γ) a tau -> ahas_type (PsiGammaCtx Ψ Γ) (AReg d) (reg tau) -> (update Γ (Id d) (reg tau)) = Γ -> ihas_type (PsiCtx Ψ) (R(d) := aeval a R) (arrow Γ Γ)
| S_Add : forall Ψ Γ d s,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg s) (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (AReg d) (reg int) -> update Γ (Id d) (reg int) = Γ -> ihas_type (PsiCtx Ψ) (R(d) +:= R(s)) (arrow Γ Γ)
| S_Sub : forall Ψ Γ s a v,
    ahas_type (PsiGammaCtx Ψ Γ) a int -> ahas_type (PsiGammaCtx Ψ Γ) (AReg s) (reg int) -> a = ANum v -> ihas_type (PsiCtx Ψ) (R(s) -:= v) (arrow Γ Γ)
| S_If :  forall Ψ Γ r v,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int) -> ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) -> ihas_type (PsiCtx Ψ) (JIF R(r) v) (arrow Γ Γ).
Hint Constructors ihas_type.

Inductive iseq_has_type : cmbnd_ctx -> instr_seq -> ty -> Prop :=
| S_Jmp :  forall Ψ Γ v,
    ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) -> iseq_has_type (PsiCtx Ψ) (JMP v) (code Γ)
| S_JmpT :  forall Ψ Γ v,
    ahas_type (PsiGammaCtx Ψ Γ) (AReg v) True -> iseq_has_type (PsiCtx Ψ) (JMP R(v)) (code Γ)
| S_Seq :  forall Ψ i1 i2 Γ Γ2,
    ihas_type (PsiCtx Ψ) i1 (arrow Γ Γ2) -> iseq_has_type (PsiCtx Ψ) i2 (code Γ2) -> iseq_has_type (PsiCtx Ψ) (ISeq i1 i2) (code Γ).                                           Hint Constructors iseq_has_type.

Definition init_Gamma : context := update (update (update (update empty_Gamma (Id 1) (reg int)) (Id 2) (reg int)) (Id 3) (reg int)) (Id 4) True.
Check init_Gamma.
Hint Unfold init_Gamma.

Definition init_Psi : context := update (update (update empty_Psi (Id 1) (code init_Gamma))(Id 3) (code init_Gamma)) (Id 2) (code init_Gamma).
Hint Unfold init_Psi.

Ltac match_map := repeat (try rewrite update_neq; try rewrite update_eq; try reflexivity).
Ltac inequality := (rewrite <- beq_id_false_iff; trivial).
Ltac crush_map := match_map ; inequality; try reflexivity.

Ltac rewrite_hyp :=
  match goal with
  | [ H : ?n = _ |- context[?n] ] => rewrite H
  end.

Ltac crush_generic :=
  repeat match goal with
         | [ H : ?T |- ?T    ] => exact T
         | [ |- ?T = ?T ] => reflexivity
         | [ |- True         ] => constructor
         | [ |- _ /\ _       ] => constructor
         | [ |- _ /\ _ -> _  ] => intro
         | [ H : _ /\ _ |- _ ] => destruct H
         | [ |- nat -> _     ] => intro
         | _ => rewrite_hyp || eauto || jauto
         end.

Ltac crush :=
  repeat (crush_generic; match goal with
                         | [ |- update _ _ _ _ = _ ] => crush_map
                         | [ |- init_Gamma _ = _ ] => unfold init_Gamma
                         | [ |- init_Psi _ = _ ] => unfold init_Psi
                         | [ |- ieval _ _ ] => constructor; auto
                         | [ |- ihas_type _ _ _] => constructor; auto
                         | [ |- ?T -> False  ]  => assert T
                         | _ => try subst; trivial
                         end).

Example heap_2_type : forall I (R : registers), (init_heap (Id 2)) = Some I -> iseq_has_type (PsiCtx init_Psi) I (code init_Gamma).
Proof.
  intros.
  unfold init_heap in H.
  rewrite update_neq in H.
  rewrite update_eq in H.
  symmetry in H.
  inversion H.
  apply S_Seq with (Γ2 := init_Gamma).
  crush.
  constructor; auto.
  apply S_Lab with (l := 3) (R := R).
  crush.
  trivial.
  apply S_Seq with (Γ2 := init_Gamma).
  constructor; auto.
  crush.
  apply update_same.
  crush.
  apply S_Seq with (Γ2 := init_Gamma).
  unfold init_Psi.
  apply S_Sub with (a := ANum 1).
  unfold init_Psi.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  apply S_Lab with (l := 2) (R := R).
  crush.
  trivial.
  trivial.
  rewrite <- beq_id_false_iff.
  trivial.
Qed.

(** Typing rule for register file *)
Inductive Rhas_type : cmbnd_ctx -> registers -> context -> Prop :=
| S_Regfile : forall Ψ Γ R r tau a,
    (Γ (Id r)) = Some tau -> aeval a R = R (Id r) -> ahas_type (PsiGammaCtx Ψ Γ) a tau -> Rhas_type (PsiCtx Ψ) R Γ.

Hint Constructors Rhas_type.

(** Typing rule for Heap *)
Inductive Hhas_type : cmbnd_ctx -> heaps -> context -> Prop :=
| S_Heap : forall Ψ H,
    (forall l tau, exists is, Ψ (Id l) = Some tau /\ H (Id l) = Some is /\ iseq_has_type (PsiCtx Ψ) is tau) -> Hhas_type EmptyCtx H Ψ.

Hint Constructors Hhas_type.

(** Typing rule for a valid Machine State *)
Inductive M_ok : cmbnd_ctx -> heaps -> registers -> instr_seq -> Prop :=
| S_Mach : forall H R Is Ψ Γ,
    Hhas_type EmptyCtx H Ψ -> Rhas_type (PsiCtx Ψ) R Γ -> iseq_has_type (PsiCtx Ψ) Is (code Γ) -> M_ok EmptyCtx H R Is.

Hint Constructors M_ok.

(** We will require some Canonical Values Lemmas in our proof of Soundness *)
Lemma Canonical_Values_Int : forall H Ψ Γ v tau,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) v tau -> tau = int -> exists n, v = ANum n.
Proof.
  intros.
  subst.
  inversion H1.
  inversion H6.
  exists n.
  crush.
Qed.

Lemma Canonical_Values_Reg :forall H Ψ Γ r R,
    Hhas_type EmptyCtx H Ψ -> Rhas_type (PsiCtx Ψ) R Γ -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) (reg int) -> exists (n : nat), R (Id r) = n.
Proof.
  intros.
  exists (R (Id r)).
  crush.
Qed.

Lemma Canonical_Values_label1 : forall H Ψ Γ v,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) (ALab v) (code Γ) ->  Ψ (Id v) = Some (code Γ) -> exists is, H (Id v) = Some is /\ iseq_has_type (PsiCtx Ψ) is (code Γ).
Proof.
  intros.
  inversion H0.
  inversion H1.
  inversion H7.
  simpl in H5.
  specialize H4 with ( l := v) (tau := code Γ).
  destruct H4 as [i G].
  exists i.
  crush.
Qed.

Lemma Canonical_Values_label2 : forall H Ψ Γ R r,
    Hhas_type EmptyCtx H Ψ -> ahas_type (PsiGammaCtx Ψ Γ) (AReg r) True -> exists is, H (Id (R (Id r))) = Some is /\ iseq_has_type (PsiCtx Ψ) is (code Γ).
Proof.
  intros.
  inversion H0.
  inversion H1.
  specialize H3 with ( l := R (Id r)) (tau := (code Γ)).
  destruct H3 as [i G].
  exists i.
  apply G.
  specialize H3 with ( l := R (Id r)) (tau := (code Γ)).
  destruct H3 as [i G].
  exists i.
  crush.
Qed.

(** Finally the proof of Soundness *)
Theorem Soundness : forall H R Is,
    M_ok EmptyCtx H R Is -> exists H' R' Is', ieval (St H R Is) (St H' R' Is') /\ M_ok EmptyCtx H' R' Is'.
Proof.
  intros.
  inversion H0 ; induction Is; inverts H4.
  induction i; inversion H12;
    try match goal with
        | [H : Γ = Γ2 |- _ ] => symmetry in H
        end;
    try subst.

  (* ISeq IMov I *)
  exists H (t_update R (Id d) (aeval a R1)) Is.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (r := d) (tau := reg tau) (a := AReg d).
  rewrite <- H16.
  rewrite update_eq.
  crush.
  crush.
  crush.
  crush.

  (* ISeq IAdd I *)
  exists H (t_update R (Id d) (aeval (AReg d) R + aeval (AReg s) R)) Is.
  split.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (a := AReg d) (r := d) (tau := reg int).
  rewrite <- H16; apply update_eq.
  crush.
  crush.
  crush.

  (* ISeq ISub I *)
  exists H (t_update R (Id d) (aeval (AReg d) R - aeval (ANum v) R)) Is.
  split.
  crush.
  apply S_Mach with (Ψ := Ψ) (Γ := Γ).
  crush.
  apply S_Regfile with (a := AReg d) (r := d) (tau := reg int).
  inversion H15.
  crush.
  crush.
  inversion H15.
  crush.
  inversion H7.
  trivial.
  crush.
  crush.

  (* ISeq IIf I *)
  inversion H12.
  inversion H9.
  inversion H18.
  subst.
  simpl in H22.

  remember (R (Id d)) as rd; destruct rd.
  pose proof Canonical_Values_label1 H Ψ Γ v0 H2 H9 H22 as CVL1.
  destruct CVL1 as [Is' G].
  exists H R Is'.
  crush.

  exists H R Is.

  split.
  apply R_IIf_NEQ.
  simpl.
  symmetry in Heqrd; rewrite Heqrd.
  apply beq_nat_false_iff.
  trivial.
  crush.

  (*IJmp*)
  inversion H11; inversion H12.
  simpl in H17.
  subst.
  pose proof Canonical_Values_label1 H Ψ Γ v0 H2 H11 H16 as CVL1.
  destruct CVL1 as [Is G].

  exists H R Is.
  crush.
  apply R_IJmp_Succ with (a := ALab v0).
  crush.
  crush.

  (*IJmpT*)
  pose proof Canonical_Values_label2 H Ψ Γ R v0 H2 H11 as CVL3.
  destruct CVL3 as [Is G].

  exists H R Is.
  crush.
Qed.


Require Import Coq.Lists.List.
Require Import Shallow.Imp Shallow.Embeddings.

Inductive aexp : Type :=
  | ANum (n : Z)
  | AId (X : var)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp)
  | ADiv (a1 a2 : aexp).

Module OptF.

Definition add {A : Type} (f g : A -> option Z) : A -> option Z :=
  fun st =>
    match f st, g st with
      | Some v1, Some v2 => Some (v1 + v2)
      | _, _ => None
    end.

Definition sub {A : Type} (f g : A -> option Z) : A -> option Z :=
  fun st =>
    match f st, g st with
      | Some v1, Some v2 => Some (v1 - v2)
      | _, _ => None
    end.

Definition mul {A : Type} (f g : A -> option Z) : A -> option Z :=
  fun st =>
    match f st, g st with
      | Some v1, Some v2 => Some (v1 * v2)
      | _, _ => None
    end.

Definition div {A : Type} (f g : A -> option Z) : A -> option Z :=
  fun st =>
    match f st, g st with
      | Some v1, Some v2 =>
          if Z.eq_dec v2 0 then None else Some (v1 / v2)
      | _, _ => None
    end.

End OptF.

Module Denote_Aexp.

Fixpoint aeval (a : aexp) : state -> option Z :=
  match a with
    | ANum n => fun _ => Some n
    | AId X => fun st => Some (st X)
    | APlus a1 a2 => OptF.add (aeval a1) (aeval a2)
    | AMinus a1 a2 => OptF.sub (aeval a1) (aeval a2)
    | AMult a1 a2 => OptF.mul (aeval a1) (aeval a2)
    | ADiv a1 a2 => OptF.div (aeval a1) (aeval a2)
  end.

End Denote_Aexp.

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Record bexp_denote : Type := {
  true_set : state -> Prop;
  false_set : state -> Prop;
  error_set : state -> Prop; }.

Definition opt_test (R: Z -> Z -> Prop) (X Y: state -> option Z): bexp_denote :=
  {|
    true_set := fun st =>
      match X st, Y st with
        | Some n1, Some n2 => R n1 n2
        | _, _ => False
      end;
    false_set := fun st =>
      match X st, Y st with
        | Some n1, Some n2 => ~R n1 n2
        | _, _ => False
      end;
    error_set := fun st =>
      match X st, Y st with
        | Some n1, Some n2 => False
        | _, _ => True
      end;
  |}.

Module Sets.

Definition union {A : Type} (X Y : A -> Prop) : A -> Prop :=
  fun a => X a \/ Y a.

Definition omega_union {A} (X : nat -> A -> Prop) : A -> Prop :=
  fun a => exists n, X n a.

End Sets.

Module Denote_Bexp.
Import Denote_Aexp.

Fixpoint beval (b : bexp) : bexp_denote :=
  match b with
  | BTrue =>
      {| true_set := Sets.full;
         false_set := Sets.empty;
         error_set := Sets.empty; |}
  | BFalse =>
      {| true_set := Sets.empty;
         false_set := Sets.full;
         error_set := Sets.empty; |}
  | BEq a1 a2 =>
      opt_test Z.eq (aeval a1) (aeval a2)
  | BLe a1 a2 =>
      opt_test Z.le (aeval a1) (aeval a2)
  | BNot b =>
      {| true_set := false_set (beval b);
         false_set := true_set (beval b);
         error_set := error_set (beval b); |}
  | BAnd b1 b2 =>
      {| true_set := Sets.intersect (true_set (beval b1)) (true_set (beval b2));
         false_set := Sets.union (false_set (beval b1))
                                 (Sets.intersect (true_set (beval b1))
                                                 (false_set (beval b2)));
         error_set := Sets.union (error_set (beval b1))
                                 (Sets.intersect (true_set (beval b1))
                                                 (error_set (beval b2))); |}
  end.

End Denote_Bexp.

Inductive com : Type :=
  | CSkip
  | CAss (X : var) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CFor (c1 c2 : com)
  | CBreak
  | CCont.

Record com_denote : Type := {
  com_normal : state -> state -> Prop;
  com_break : state -> state -> Prop;
  com_cont : state -> state -> Prop;
  com_error : state -> Prop }.

Module Denote_Com.
Import Denote_Aexp.
Import Denote_Bexp.

Definition skip_sem : com_denote := {|
  com_normal := fun st1 st2 => st1 = st2;
  com_break := fun st1 st2 => False;
  com_cont := fun st1 st2 => False;
  com_error := fun st => False; |}.

Definition asgn_sem (X : var) (DA : state -> option Z) : com_denote := {|
  com_normal := fun st1 st2 => (Some (st2 X) = DA st1) /\ (forall Y, Y <> X -> st2 Y = st1 Y);
  com_break := fun st1 st2 => False;
  com_cont := fun st1 st2 => False;
  com_error := fun st => DA st = None; |}.

Definition seq_sem (DC1 DC2 : com_denote) : com_denote := {|
  com_normal := fun st1 st2 =>
    exists st3, com_normal DC1 st1 st3 /\ com_normal DC2 st3 st2;
  com_break := fun st1 st2 =>
    (com_break DC1 st1 st2) \/
    (exists st3, com_normal DC1 st1 st3 /\ com_break DC2 st3 st2);
  com_cont := fun st1 st2 =>
    (com_cont DC1 st1 st2) \/
    (exists st3, com_normal DC1 st1 st3 /\ com_cont DC2 st3 st2);
  com_error := fun st =>
    (com_error DC1 st) \/ (exists st', com_normal DC1 st st' /\ com_error DC2 st'); |}.

Definition if_sem (DB : bexp_denote) (DC1 DC2 : com_denote) : com_denote := {|
  com_normal := fun st1 st2 =>
    (true_set DB st1 /\ com_normal DC1 st1 st2) \/
    (false_set DB st1 /\ com_normal DC2 st1 st2);
  com_break := fun st1 st2 =>
    (true_set DB st1 /\ com_break DC1 st1 st2) \/
    (false_set DB st1 /\ com_break DC2 st1 st2);
  com_cont := fun st1 st2 =>
    (true_set DB st1 /\ com_cont DC1 st1 st2) \/
    (false_set DB st1 /\ com_cont DC2 st1 st2);
  com_error := fun st =>
    (error_set DB st) \/
    (true_set DB st /\ com_error DC1 st) \/
    (false_set DB st /\ com_error DC2 st) |}.

Fixpoint iter_loop_body (DC1 DC2 : com_denote) (n : nat) : com_denote :=
  match n with
  | O => {|
      com_normal := fun st1 st2 =>
        (com_break DC1 st1 st2) \/
        (exists st3, com_normal DC1 st1 st3 /\ com_break DC2 st3 st2);
      com_break := fun st1 st2 => False;
      com_cont := fun st1 st2 => False;
      com_error := fun st =>
        (com_error DC1 st) \/
        (exists st', com_normal DC1 st st' /\ com_error DC2 st') |}
  | S n' => {|
      com_normal := fun st1 st2 => exists st3,
        ((com_normal (seq_sem DC1 DC2) st1 st3) \/ (com_cont (seq_sem DC1 DC2) st1 st3)) /\
        (com_normal (iter_loop_body DC1 DC2 n') st3 st2);
      com_break := fun st1 st2 => False;
      com_cont := fun st1 st2 => False;
      com_error := fun st => exists st',
        ((com_normal (seq_sem DC1 DC2) st st') \/ (com_cont (seq_sem DC1 DC2) st st')) /\
        (com_error (iter_loop_body DC1 DC2 n') st') |}
  end.

Definition for_sem (DC1 DC2 : com_denote) : com_denote := {|
  com_normal := fun st1 st2 =>
    exists n, com_normal (iter_loop_body DC1 DC2 n) st1 st2;
  com_break := fun st1 st2 => False;
  com_cont := fun st1 st2 => False;
  com_error := fun st =>
    exists n, com_error (iter_loop_body DC1 DC2 n) st |}.

Definition break_sem : com_denote := {|
  com_normal := fun st1 st2 => False;
  com_break := fun st1 st2 => st1 = st2;
  com_cont := fun st1 st2 => False;
  com_error := fun st => False |}.

Definition cont_sem : com_denote := {|
  com_normal := fun st1 st2 => False;
  com_break := fun st1 st2 => False;
  com_cont := fun st1 st2 => st1 = st2;
  com_error := fun st => False |}.

Fixpoint ceval (c : com) : com_denote :=
  match c with
  | CSkip => skip_sem
  | CAss X a => asgn_sem X (aeval a)
  | CSeq c1 c2 => seq_sem (ceval c1) (ceval c2)
  | CIf b c1 c2 => if_sem (beval b) (ceval c1) (ceval c2)
  | CFor c1 c2 => for_sem (ceval c1) (ceval c2)
  | CBreak => break_sem
  | CCont => cont_sem
  end.

End Denote_Com.

Module Assertion_Shallow.
Import Denote_Aexp.
Import Denote_Bexp.

Definition Assertion : Type := state -> Prop.

Definition Assertion_denote : state -> Assertion -> Prop :=
  fun st P => P st.

Definition andp : Assertion -> Assertion -> Assertion :=
  fun P Q st => P st /\ Q st.

Definition orp : Assertion -> Assertion -> Assertion :=
  fun P Q st => P st \/ Q st.

Definition negp : Assertion -> Assertion :=
  fun P st => ~ P st.

Definition falsep : Assertion :=
  fun st => False.

Definition inj : bexp -> Assertion :=
  fun b st => true_set (beval b) st.

Definition safea : aexp -> Assertion :=
  fun a st => ~ (aeval a) st = None.

Definition safeb : bexp -> Assertion :=
  fun b st => ~ error_set (beval b) st.

Definition derives : Assertion -> Assertion -> Prop :=
  fun P Q => forall st, P st -> Q st.

Definition state_update (st : state) (X : var) (v : option Z) : state :=
  match v with
  | Some n => fun Y => if (Nat.eq_dec X Y) then n else st Y
  | None => fun Y => 0
  end.

Definition subst_assertion (P : Assertion) (X : var) (v : state -> option Z) : Assertion :=
  fun st => P (state_update st X (v st)).

End Assertion_Shallow.

Module Denote_Embeddings.
Import Denote_Com.
Import Assertion_Shallow.

Definition com_term : com_denote -> state -> state -> Prop :=
  fun DC st1 st2 =>
    (com_normal DC st1 st2) \/ (com_break DC st1 st2) \/ (com_cont DC st1 st2).

Definition partial_valid (P : Assertion) (c : com) (Q R1 R2 : Assertion) : Prop :=
  forall st1 st2, Assertion_denote st1 P ->
    (~ com_error (ceval c) st1) /\
    ((com_normal (ceval c) st1 st2) -> Assertion_denote st2 Q) /\
    ((com_break (ceval c) st1 st2) -> Assertion_denote st2 R1) /\
    ((com_cont (ceval c) st1 st2) -> Assertion_denote st2 R2).

Definition total_valid (P : Assertion) (c : com) (Q R1 R2 : Assertion) : Prop :=
  (forall st1, Assertion_denote st1 P -> exists st2, com_term (ceval c) st1 st2) /\
  (partial_valid P c Q R1 R2).

End Denote_Embeddings.

Module rules_sound.
Import Denote_Com.
Import Denote_Embeddings.
Import Assertion_Shallow.

Definition WP (c : com) (Q R1 R2 : Assertion) : state -> Prop :=
  fun st =>
    (~ (com_error (ceval c) st)) /\
    (forall st',
      (com_normal (ceval c) st st' -> Assertion_denote st' Q) /\
      (com_break (ceval c) st st' -> Assertion_denote st' R1) /\
      (com_cont (ceval c) st st' -> Assertion_denote st' R2)).

Theorem seq_inv_sound_bigstep : forall P c1 c2 Q R1 R2,
  partial_valid P (CSeq c1 c2) Q R1 R2 ->
    (exists Q', partial_valid P c1 Q' R1 R2 /\ partial_valid Q' c2 Q R1 R2).
Proof.
  intros.
  exists (WP c2 Q R1 R2).
  remember (WP c2 Q R1 R2) as Q'.
  split.
  + (* partial_valid P c1 Q' R1 R2 *)
    unfold partial_valid in *.
    intros.
    split; try split; try split; intros.
    - specialize (H st1 st2 H0).
      destruct H as [HE [HN [HB HC]]].
      simpl in HE.
      unfold not in *; intros; apply HE; tauto.
    - subst Q'; unfold WP, Assertion_denote in *.
      split.
      { specialize (H st1 st2 H0).
        destruct H as [HE [HN [HB HC]]].
        unfold not in *.
        intros; apply HE.
        simpl; right; exists st2; tauto. }
      intros st3.
      specialize (H st1 st3 H0).
      destruct H as [HE [HN [HB HC]]].
      split; try split; intros;
        [apply HN | apply HB | apply HC]; simpl;
        [ | right | right]; exists st2; tauto.
    - specialize (H st1 st2 H0).
      destruct H as [HE [HN [HB HC]]].
      apply HB; simpl; tauto.
    - specialize (H st1 st2 H0).
      destruct H as [HE [HN [HB HC]]].
      apply HC; simpl; tauto.
  + unfold partial_valid; subst Q'; unfold WP, Assertion_denote.
    intros.
    destruct H0 as [HE ?].
    specialize (H0 st2); tauto.
Qed.

Theorem if_seq_sound_bigstep : forall P b c1 c2 c3 Q R1 R2,
  partial_valid P (CIf b (CSeq c1 c3) (CSeq c2 c3)) Q R1 R2 ->
  partial_valid P (CSeq (CIf b c1 c2) c3) Q R1 R2.
Proof.
  intros.
  unfold partial_valid in *.
  intros.
  specialize (H st1 st2 H0).
  destruct H as [HE [HN [HB HC]]].
  split; [| split;[| split]].
  + unfold not in *; intros; apply HE.
    simpl in H; simpl.
    destruct H; try tauto.
    destruct H as [st3 [? ?]].
    right; destruct H; [left | right]; split; try tauto;
      right; exists st3; try tauto.
  + intros; apply HN.
    simpl in H; simpl.
    destruct H as [st3 [[? | ?] ?]]; [left | right];
      split; try tauto; exists st3; tauto.
  + intros; apply HB.
    simpl in H; simpl.
    destruct H; try tauto.
    destruct H as [st3 [[? | ?] ?]]; [left | right];
      split; try tauto; right; exists st3; tauto.
  + intros; apply HC.
    simpl in H; simpl.
    destruct H; try tauto.
    destruct H as [st3 [[? | ?] ?]]; [left | right];
      split; try tauto; right; exists st3; tauto.
Qed.

Fixpoint nocontinue (c : com) : Prop :=
  match c with
  | CSkip         => True
  | CAss _ _      => True
  | CSeq c1 c2    => (nocontinue c1) /\ (nocontinue c2)
  | CIf b c1 c2   => (nocontinue c1) /\ (nocontinue c2)
  | CFor c1 c2    => True
  | CBreak        => True
  | CCont         => False
  end.

Lemma nocontinue_nocontexit : forall (c : com) st1,
  nocontinue c ->
  ~(exists st2, com_cont (ceval c) st1 st2).
Proof.
  intros; revert st1.
  induction c; unfold not; intros; destruct H0 as [st2 ?].
  + inversion H0.
  + inversion H0.
  + simpl in H; destruct H as [Hc1 Hc2].
    unfold not in *.
    simpl in H0; destruct H0.
    - specialize (IHc1 Hc1 st1).
      apply IHc1; exists st2; tauto.
    - destruct H as [st3 ?].
      specialize (IHc2 Hc2 st3).
      apply IHc2; exists st2; tauto.
  + simpl in H0; simpl in H; destruct H as [Hc1 Hc2]; destruct H0.
    - specialize (IHc1 Hc1 st1).
      unfold not in IHc1; apply IHc1.
      exists st2; tauto.
    - specialize (IHc2 Hc2 st1).
      unfold not in IHc2; apply IHc2.
      exists st2; tauto.
  + simpl in H0; tauto.
  + simpl in H0; tauto.
  + simpl in H; tauto.
Qed.

Theorem nocontinue_sound_bigstep : forall P c Q R1 R2 R2',
  nocontinue c ->
  partial_valid P c Q R1 R2 ->
  partial_valid P c Q R1 R2'.
Proof.
  intros.
  unfold partial_valid in *.
  intros.
  specialize (H0 st1 st2 H1).
  split; [tauto | split; [tauto | split; try tauto]].
  clear H0; intros.
  pose proof (nocontinue_nocontexit c st1 H).
  exfalso; unfold not in H2; apply H2.
  exists st2; tauto.
Qed.

Lemma loop_nocontinue_error : forall c1 c2 st1,
  com_error (ceval (CFor c1 c2)) st1 ->
  com_error (ceval (CFor (CSeq c1 c2) CSkip)) st1.
Proof.
  intros.
  simpl in *.
  destruct H as [n ?]; exists n.
  revert st1 H; induction n; intros.
  + simpl in *.
    destruct H; try tauto.
  + simpl in *.
    destruct H as [st2 [? ?]].
    exists st2; split.
    2:{ pose proof (IHn st2 H0); tauto. }
    destruct H.
    - destruct H as [st3 [? ?]].
      left. exists st2; split; try tauto.
      exists st3; tauto.
    - destruct H as [? | [st3 [? ?]]]; try tauto.
      right. left. right. exists st3; tauto.
Qed.

Lemma loop_nocontinue_normal : forall c1 c2 st1 st2,
  com_normal (ceval (CFor c1 c2)) st1 st2 ->
  com_normal (ceval (CFor (CSeq c1 c2) CSkip)) st1 st2.
Proof.
  intros.
  simpl in *.
  destruct H as [n ?]; exists n.
  revert st1 st2 H; induction n; intros.
  + simpl in *.
    destruct H; try tauto.
  + simpl in *.
    destruct H as [st3 [? ?]].
    exists st3; split.
    2:{ pose proof (IHn st3 st2 H0); tauto. }
    destruct H.
    - destruct H as [st4 ?].
      left. exists st3; split; try tauto; exists st4; tauto.
    - destruct H as [? | [st4 ?]]; try tauto.
      right. left. right. exists st4; tauto.
Qed.

Theorem loop_nocontinue_sound_bigstep : forall P c1 c2 Q R1 R2,
  nocontinue c1 ->
  nocontinue c2 ->
  partial_valid P (CFor (CSeq c1 c2) CSkip) Q R1 R2 ->
  partial_valid P (CFor c1 c2) Q R1 R2.
Proof.
  intros.
  unfold partial_valid in *.
  intros.
  specialize (H1 st1 st2 H2).
  destruct H1 as [HE [HN [HB HC]]].
  split; try split; try split.
  + unfold not in *; intros; apply HE.
    pose proof (loop_nocontinue_error c1 c2 st1); tauto.
  + intros; apply HN.
    pose proof (loop_nocontinue_normal c1 c2 st1 st2); tauto.
  + intros.
    simpl in H1. tauto.
  + intros.
    simpl in H1. tauto.
Qed.

End rules_sound.

Module basic_rules.
Import Denote_Aexp.
Import Denote_Bexp.
Import Denote_Com.
Import Denote_Embeddings.
Import Assertion_Shallow.

Theorem hoare_seq_sound : forall P Q R R1 R2 c1 c2,
  partial_valid P c1 Q R1 R2 ->
  partial_valid Q c2 R R1 R2 ->
  partial_valid P (CSeq c1 c2) R R1 R2.
Proof.
  intros.
  unfold partial_valid in *.
  intros.
  split; try split; try split.
  + unfold not; intros.
    simpl in H2.
    destruct H2.
    - specialize (H st1 st2 H1); tauto.
    - destruct H2 as  [st3 [? ?]].
      specialize (H st1 st3 H1).
      assert (Assertion_denote st3 Q). { tauto. }
      specialize (H0 st3 st2 H4); tauto.
  + intros.
    simpl in H2.
    destruct H2 as [st3 [? ?]].
    specialize (H st1 st3 H1).
    assert (Assertion_denote st3 Q). { tauto. }
    specialize (H0 st3 st2 H4). tauto.
  + intros.
    simpl in H2.
    destruct H2.
    - specialize (H st1 st2 H1); tauto.
    - destruct H2 as [st3 [? ?]].
      specialize (H st1 st3 H1).
      assert (Assertion_denote st3 Q). { tauto. }
      specialize (H0 st3 st2 H4). tauto.
  + intros.
    simpl in H2.
    destruct H2.
    - specialize (H st1 st2 H1); tauto.
    - destruct H2 as [st3 [? ?]].
      specialize (H st1 st3 H1).
      assert (Assertion_denote st3 Q). { tauto. }
      specialize (H0 st3 st2 H4). tauto.
Qed.

Theorem hoare_skip_sound : forall P,
  partial_valid P CSkip P falsep falsep.
Proof.
  intros.
  unfold partial_valid.
  intros.
  split; try split; try split.
  + unfold not; intros. inversion H0.
  + intros. simpl in H0; subst; tauto.
  + intros. inversion H0.
  + intros. inversion H0.
Qed.

Lemma true_notfalse : forall b st,
  true_set (beval b) st ->
  false_set (beval b) st -> False.
Proof.
  induction b; intros.
  + inversion H0.
  + inversion H.
  + simpl in *.
    destruct (aeval a1 st), (aeval a2 st); tauto.
  + simpl in *.
    destruct (aeval a1 st), (aeval a2 st); tauto.
  + simpl in *. apply (IHb st); tauto.
  + simpl in *.
    unfold Sets.intersect, Sets.union in *.
    specialize (IHb1 st); specialize (IHb2 st); tauto.
Qed.

Theorem hoare_if_sound : forall P Q R1 R2 b c1 c2,
  partial_valid (andp P (inj b)) c1 Q R1 R2 ->
  partial_valid (andp P (negp (inj b))) c2 Q R1 R2 ->
  partial_valid (andp P (safeb b)) (CIf b c1 c2) Q R1 R2.
Proof.
  unfold partial_valid in *.
  intros.
  unfold safeb, andp, inj, negp, Assertion_denote in *.
  split; try split; try split.
  + simpl. unfold not; intros.
    destruct H2 as [? | [? | ?]].
    - tauto.
    - specialize (H st1 st2); tauto.
    - specialize (H0 st1 st2).
      destruct H2.
      assert (~ true_set (beval b) st1).
      { unfold not; intros. apply (true_notfalse b st1); tauto. }
      tauto.
  + simpl; intros.
    destruct H2.
    - specialize (H st1 st2). tauto.
    - specialize (H0 st1 st2).
      assert (~ true_set (beval b) st1).
      { unfold not; intros. apply (true_notfalse b st1); tauto. }
      tauto.
  + simpl; intros.
    destruct H2.
    - specialize (H st1 st2). tauto.
    - specialize (H0 st1 st2).
      assert (~ true_set (beval b) st1).
      { unfold not; intros. apply (true_notfalse b st1); tauto. }
      tauto.
    + simpl; intros.
    destruct H2.
    - specialize (H st1 st2). tauto.
    - specialize (H0 st1 st2).
      assert (~ true_set (beval b) st1).
      { unfold not; intros. apply (true_notfalse b st1); tauto. }
      tauto.
Qed.

Theorem hoare_break_sound : forall P,
  partial_valid P CBreak falsep P falsep.
Proof.
  unfold partial_valid.
  intros.
  split; try split; try split.
  + unfold not; intros. inversion H0.
  + intros. inversion H0.
  + intros. inversion H0. subst. tauto.
  + intros. inversion H0.
Qed.

Theorem hoare_cont_sound : forall P,
  partial_valid P CCont falsep falsep P.
Proof.
  unfold partial_valid.
  intros.
  split; try split; try split.
  + unfold not; intros. inversion H0.
  + intros. inversion H0.
  + intros. inversion H0.
  + intros. inversion H0. subst. tauto.
Qed.

Theorem hoare_consequence_sound : forall P P' Q Q' R1 R1' R2 R2' c,
  derives P P' ->
  partial_valid P' c Q' R1' R2' ->
  derives Q' Q ->
  derives R1' R1 ->
  derives R2' R2 ->
  partial_valid P c Q R1 R2.
Proof.
  unfold derives, partial_valid, Assertion_denote in *.
  intros.
  specialize (H st1).
  specialize (H0 st1 st2).
  specialize (H1 st2).
  specialize (H2 st2).
  specialize (H3 st2).
  split; try split; try split; tauto.
Qed.

Theorem hoare_for_sound : forall I P c1 c2,
  partial_valid I (CSeq c1 c2) I P I ->
  partial_valid I (CFor c1 c2) (orp I P) falsep falsep.
Proof.
  unfold partial_valid, orp, falsep, Assertion_denote.
  intros.
  split; try split; try split; try tauto.
  + unfold not; intros.
    simpl in H1.
    destruct H1 as [n ?].
    revert st1 H1 H0; induction n; intros.
    - simpl in H1.
      specialize (H st1 st2 H0); destruct H.
      simpl in H. tauto.
    - simpl in H1.
      destruct H1 as [st3 [? ?]].
      specialize (IHn st3); apply IHn; try tauto.
      clear IHn H2.
      destruct H1 as [? | [? | ?]].
      * destruct H1 as [st4 [? ?]].
        specialize (H st1 st3 H0).
        assert (com_normal (ceval (CSeq c1 c2)) st1 st3).
        { simpl. exists st4; tauto. }
        tauto.
      * specialize (H st1 st3 H0).
        assert (com_cont (ceval (CSeq c1 c2)) st1 st3).
        { simpl. tauto. }
        tauto.
      * specialize (H st1 st3 H0).
        destruct H1 as [st4 [? ?]].
        assert (com_cont (ceval (CSeq c1 c2)) st1 st3).
        { simpl. right. exists st4; tauto. }
        tauto.
  + intros.
    simpl in H1.
    destruct H1 as [n ?].
    revert st1 st2 H0 H1; induction n; intros.
    - simpl in H1.
      destruct H1.
      * specialize (H st1 st2).
        assert (com_break (ceval (CSeq c1 c2)) st1 st2).
        { simpl. tauto. }
        tauto.
      * specialize (H st1 st2).
        assert (com_break (ceval (CSeq c1 c2)) st1 st2).
        { simpl. tauto. }
        tauto.
    - simpl in H1.
      destruct H1 as [st3 [? ?]].
      specialize (IHn st3 st2); apply IHn; try tauto.
      clear IHn H2.
      destruct H1 as [? | [? | ?]].
      * specialize (H st1 st3); tauto.
      * specialize (H st1 st3).
        assert (com_cont (ceval (CSeq c1 c2)) st1 st3).
        { simpl. tauto. }
        tauto.
      * specialize (H st1 st3).
        assert (com_cont (ceval (CSeq c1 c2)) st1 st3).
        { simpl. tauto. }
        tauto.
Qed.

Theorem hoare_asgn_sound : forall P (X : var) (E : aexp),
  partial_valid (andp (safea E) (subst_assertion P X (aeval E))) (CAss X E) P falsep falsep.
Proof.
  unfold partial_valid.
  intros.
  unfold Assertion_denote, andp, safea, subst_assertion in *.
  split; try split; try split.
  + unfold not; intros.
    simpl in *; tauto.
  + intros; simpl in *.
    destruct H, H0.
    remember (state_update st1 X (aeval E st1)) as st2'.
    assert (forall X, st2 X = st2' X).
    { intros.
      subst st2'.
      destruct (aeval E st1); try tauto.
      unfold state_update.
      destruct (Nat.eq_dec X X0).
      - subst. inversion H0. tauto.
      - specialize (H2 X0); auto. }
    assert (st2 = state_update st1 X (aeval E st1)).
    { eapply FunctionalExtensionality.functional_extensionality_dep.
      subst. tauto. }
    subst; tauto.
  + intros; simpl in *; tauto.
  + intros; simpl in *; tauto.
Qed.

End basic_rules.


Definition tautology : forall P : Prop, P -> P
  := fun P p => p.

Definition Modus_tollens : forall P Q : Prop, ~Q /\ (P -> Q) -> ~P
  := fun P Q H p => let (nQ, p_q) := H in nQ (p_q p).

Definition Disjunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q
  := fun P Q p_or_q n_p =>
  match p_or_q with
  | or_introl p => False_ind Q (n_p p)
  | or_intror q => q
  end.

Definition tautology_on_Set : forall A : Set, A -> A
  := fun A p => p.

Definition Modus_tollens_on_Set : forall A B : Set, (B -> Empty_set) * (A -> B) -> (A -> Empty_set)
  := fun A B H a => let (b_emp, a_b) := H in b_emp (a_b a).

Definition Disjunctive_syllogism_on_Set : forall A B : Set, (A + B) -> (A -> Empty_set) -> B
  := fun A B in_a_b a_emp =>
  match in_a_b with
  | inl a => Empty_set_rec (fun _ : Empty_set => B) (a_emp a)
  | inr b => b
  end.


(***********************************************************)
(*      This file contains the abstract term structure for *)
(*      the Fourier-Motzkin procedure                      *)
(***********************************************************)

Require Import ZArith.

Open Scope Z_scope.

Structure Fmodule: Type := {
   T: Type;
   injT: Z -> T;         (* injection of Z *)
   scalT: Z -> T -> T;   (* scalar multiplication *)
   opT: T -> T;          (* opposite *)
   plusT: T -> T -> T;   (* addition *)
   minusT: T -> T -> T;  (* subtraction *)
   leT: T -> T -> Prop;  (* comparison *)
   ltT: T -> T -> Prop   (* strict comparison *)
}.

Section Init.

Variable FT : Fmodule.

(* Unusal notation *)
Declare Scope F_scope.
Notation "x + y" := (plusT FT x y) : F_scope.
Notation "x - y" := (minusT FT x y) : F_scope.
Notation "x * y" := (scalT FT x y) : F_scope.
Notation "x <= y" := (leT FT x y) : F_scope.
Notation "x < y" := (ltT FT x y) : F_scope.

Let injT1: Z -> (T FT) := (injT FT).
Coercion injT1 : Z >-> T.
Open Scope F_scope.

(* Sets of axioms of the T type (not minimal!) *)
Structure Faxiom: Prop := {
 (* Arithmetic part *)
 injT_plus: forall z1 z2 : Z, (z1 + z2)%Z = z1 + z2 :> T _;
 scalT_plus_l: forall z1 z2 t, (z1 + z2) * t = z1 * t + z2 * t;
 scalT_mul: forall z1 z2 t, z1 * z2 * t = z1 * (z2 * t);
 injT_0_r: forall t, t + 0%Z = t :> T _;
 plusT_C: forall t1 t2, t1 + t2 = t2 + t1;
 plusT_A: forall t1 t2 t3, t1 + t2 + t3 = t1 + (t2 + t3);
 plusT_0: forall t1, t1 + (-1) * t1 = 0%Z;
 scalT_1: forall t, 1%Z * t = t;
 opT_def: forall t, opT _ t = (-1) * t;
 minusT_def: forall t1 t2, t1 - t2 = t1 + (-1) * t2;
 (* Inequality part *)
 leT_refl: forall x, x <= x;
 leT_compat: forall x y z t, x <= y -> z <= t -> x + z <= y + t;
 ltT_01: 0 < 1;
 ltT_compat: forall x y z t, x < y -> z <= t -> x + z < y + t;
 ltT_W: forall x y, x < y -> x <= y;
 leT_neg: forall x, (x < 0)%Z -> ~ 0 <= x;
 ltT_neg: forall x, (x <= 0)%Z -> ~ 0 < x
}.
Variable FA : Faxiom.

Let injT_plus := (injT_plus FA).
Let scalT_plus_l := (scalT_plus_l FA).
Let scalT_mul := (scalT_mul FA).
Let injT_0_r := (injT_0_r FA).
Let plusT_C := (plusT_C FA).
Let plusT_A := (plusT_A FA).
Let plusT_0 := (plusT_0 FA).
Let scalT_1 := (scalT_1 FA).
Let opT_def := (opT_def FA).
Let minusT_def := (minusT_def FA).
Let leT_refl := (leT_refl FA).
Let leT_compat := (leT_compat FA).
Let ltT_01 := (ltT_01 FA).
Let ltT_compat := (ltT_compat FA).
Let ltT_W := (ltT_W FA).
Let leT_neg := (leT_neg FA).

(************************************************************)
(*       Derived facts about the arithmetic fragment        *)
(************************************************************)

Lemma injT_0_l: forall t, 0%Z + t = t.
Proof.
intros t; rewrite plusT_C; auto; apply injT_0_r; auto.
Qed.

Lemma plusT_cancel: forall t t1 t2: T _, t + t1 = t + t2 -> t1 = t2.
intros t t1 t2 H.
Proof.
rewrite <- (injT_0_r t1); rewrite <- (plusT_0 t);
  rewrite <- plusT_A; rewrite (plusT_C t1);
  rewrite H; rewrite (plusT_C t); rewrite plusT_A;
  rewrite plusT_0; rewrite injT_0_r; trivial.
Qed.

Lemma scalT_0: forall t, 0%Z * t = 0%Z.
Proof.
intros t; rewrite <- (plusT_0 t).
pattern t at 2; rewrite <- (scalT_1 t).
rewrite <- scalT_plus_l; auto.
Qed.

Lemma scalT_m1: forall t, (-1) * ((-1) * t) = t.
Proof.
intros t; rewrite <- scalT_mul; rewrite scalT_1; auto.
Qed.

Lemma scalT_inj0: forall z, z * 0%Z = 0%Z.
Proof.
assert (Hp: forall p, (Zpos p) * 0 = 0).
intros p; induction p as [p Hrec | p Hrec |].
rewrite Zpos_xI; rewrite Zmult_comm;
  rewrite <- Zplus_diag_eq_mult_2.
repeat rewrite scalT_plus_l; rewrite Hrec.
rewrite injT_0_r; rewrite plusT_C; rewrite injT_0_r.
rewrite scalT_1; auto.
rewrite Zpos_xO; rewrite Zmult_comm;
  rewrite <- Zplus_diag_eq_mult_2.
repeat rewrite scalT_plus_l; rewrite Hrec.
rewrite injT_0_r; auto.
rewrite scalT_1; auto.
intros z; destruct z as [| p | p]; auto.
apply scalT_0; auto.
change (Zneg p) with ((-1) * (Zpos p))%Z.
rewrite scalT_mul; rewrite Hp.
apply plusT_cancel with (0:T _).
rewrite plusT_0; rewrite injT_0_r; auto.
Qed.

Lemma scalT_plus_r: forall z t1 t2, z * (t1 + t2)= z * t1 + z * t2.
Proof.
assert (Hp0: forall t1 t2, (-1) * (t1 + t2)= (-1) * t1 + (-1) * t2).
intros p1 p2.
apply plusT_cancel with (p1 + p2).
rewrite plusT_0.
rewrite (plusT_C p1); rewrite plusT_A; rewrite (plusT_C p2).
repeat rewrite <- plusT_A; rewrite plusT_0; rewrite injT_0_l.
rewrite plusT_C; rewrite plusT_0; auto.
assert (Hp: forall p t1 t2,
 (Zpos p) * (t1 + t2)= (Zpos p) * t1 + (Zpos p) * t2).
intros p; induction p as [p Hrec | p Hrec|]; intros t1 t2.
rewrite Zpos_xI; repeat rewrite scalT_plus_l.
repeat rewrite (Zmult_comm 2); rewrite <- Zplus_diag_eq_mult_2.
repeat rewrite scalT_plus_l; repeat rewrite scalT_1.
rewrite Hrec.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
rewrite Zpos_xO.
repeat rewrite (Zmult_comm 2); rewrite <- Zplus_diag_eq_mult_2.
repeat rewrite scalT_plus_l; repeat rewrite scalT_1.
rewrite Hrec.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
rewrite plusT_C.
repeat rewrite plusT_A; apply f_equal2 with (f := plusT FT); auto.
repeat rewrite scalT_1; auto.
intros z; destruct z as [|p | p]; intros t1 t2; auto.
  repeat rewrite scalT_0; rewrite injT_0_r; auto.
change (Zneg p) with ((-1) * (Zpos p))%Z.
repeat rewrite scalT_mul; rewrite Hp; rewrite Hp0; auto.
Qed.

Lemma injT_mul: forall z1 z2, (z1 * z2)%Z = z1 * z2 :> T _.
Proof.
assert (Hp: forall p z2, (Zpos p * z2)%Z = (Zpos p) * z2 :> T _).
intros p; induction p as [p Hrec | p Hrec|]; intros z2.
rewrite Zpos_xI.
replace ((2 * Zpos p + 1) * z2)%Z with (Zpos p * (2 * z2) + z2)%Z;
  try ring.
rewrite scalT_plus_l; rewrite injT_plus; rewrite Hrec.
rewrite Zmult_comm; rewrite <- Zplus_diag_eq_mult_2.
rewrite injT_plus; rewrite scalT_plus_r.
rewrite (Zmult_comm 2);
  rewrite <- Zplus_diag_eq_mult_2.
rewrite scalT_plus_l; rewrite scalT_1; auto.
rewrite Zpos_xO; rewrite (Zmult_comm 2); rewrite <- Zmult_assoc.
rewrite Hrec; rewrite scalT_mul.
replace (2 * z2)%Z with (z2 + z2)%Z; try ring.
change 2%Z with (1 + 1)%Z.
rewrite scalT_plus_l; rewrite injT_plus; rewrite scalT_1; auto.
rewrite scalT_1; rewrite Zmult_1_l; auto.
intros z1 z2; destruct z1 as [| p | p]; auto.
rewrite scalT_0; auto.
change (Zneg p) with ((-1) * (Zpos p))%Z.
rewrite <-Zmult_assoc. repeat rewrite scalT_mul; auto.
rewrite <- Hp.
apply plusT_cancel with (injT1 (Zpos p * z2)).
rewrite <- injT_plus; rewrite plusT_0.
apply f_equal with (f := injT1); ring.
Qed.

(*************************.***********************************)
(*       Derived facts about the comparison                 *)
(************************************************************)

Lemma ltT_cancel_l: forall x y z, x + y < x + z -> y < z.
Proof.
intros x y z H.
replace y with ((x + y) + (-1) * x).
replace z with ((x + z) + (-1) * x).
apply ltT_compat; auto.
rewrite (plusT_C x); rewrite plusT_A; rewrite plusT_0;
  rewrite injT_0_r; auto.
rewrite (plusT_C x); rewrite plusT_A; rewrite plusT_0;
  rewrite injT_0_r; auto.
Qed.

Lemma leT_cancel_l: forall x y z, x + y <= x + z -> y <= z.
Proof.
intros x y z H.
replace y with ((-1) * x + (x + y)).
replace z with ((-1) * x + (x + z)).
apply leT_compat; auto.
rewrite <- plusT_A; rewrite (fun z => plusT_C z x); rewrite plusT_0;
  rewrite injT_0_l; auto.
rewrite <- plusT_A; rewrite (fun z => plusT_C z x); rewrite plusT_0;
  rewrite injT_0_l; auto.
Qed.

Lemma leT_trans: forall x y z, x <= y -> y <= z -> x <= z.
Proof.
intros x y z H1 H2.
apply leT_cancel_l with y.
rewrite (plusT_C y).
apply leT_compat; auto.
Qed.

Lemma leT_opp: forall x y, x <= y -> (-1) * y <= (-1) * x.
Proof.
intros x y H.
apply leT_cancel_l with x.
rewrite plusT_0.
apply leT_cancel_l with y.
rewrite injT_0_r.
rewrite (plusT_C x); rewrite <- plusT_A; rewrite plusT_0;
  rewrite injT_0_l; auto.
Qed.

Lemma plusTss_pos: forall x y, 0 < x -> 0 < y -> 0 < x + y.
Proof.
intros x y Hx Hy.
rewrite <- (injT_0_r 0).
apply ltT_compat; auto; apply ltT_W; auto.
Qed.

Lemma plusT1s_pos: forall x y, 0 <= x -> 0 < y -> 0 < x + y.
Proof.
intros x y Hx Hy.
rewrite plusT_C; rewrite <- (injT_0_r 0).
apply ltT_compat; auto.
Qed.

Lemma plusTs1_pos: forall x y, 0 < x -> 0 <= y -> 0 < x + y.
Proof.
intros x y Hx Hy.
rewrite <- (injT_0_r 0).
apply ltT_compat; auto.
Qed.

Lemma plusT_pos: forall x y, 0 <= x -> 0 <= y -> 0 <= x + y.
Proof.
intros x y Hx Hy.
rewrite <- (injT_0_r 0).
apply leT_compat; auto.
Qed.

Lemma eqT_pos: forall x y, (0:T _) = x -> (0:T _) = y -> (0:T _) = x + y.
Proof.
intros x y Hx Hy; rewrite <- Hx; rewrite <- Hy; rewrite injT_0_r; auto.
Qed.

Lemma injT_pos: forall x, (0 <= x)%Z -> 0 <= x.
Proof.
apply natlike_ind.
apply leT_refl.
intros x Hx H1x.
unfold Z.succ; rewrite injT_plus.
apply plusT_pos; auto.
Qed.

Lemma injT_spos: forall x, (0 < x)%Z -> 0 < x.
Proof.
intros x; destruct x as [|p|p]; intros HH;
  try (discriminate HH).
change 0 with (0+0)%Z.
replace (Zpos p) with (1 + (Zpos p - 1))%Z.
repeat rewrite injT_plus.
apply ltT_compat.
apply ltT_01.
apply injT_pos; case p; intros; intros HH1; discriminate HH1.
ring.
Qed.

Lemma scalT_pos: forall x y, (0 <= x)%Z -> 0 <= y -> 0 <= x * y.
Proof.
intros x y Hx Hy.
generalize x Hx; apply natlike_ind; auto; clear x Hx.
rewrite scalT_0; apply leT_refl.
intros x Hx Hp.
unfold Z.succ; rewrite scalT_plus_l.
apply plusT_pos; auto; rewrite scalT_1; auto.
Qed.

Lemma scalT_spos: forall x y, (0 < x)%Z -> 0 < y -> 0 < x * y.
Proof.
intros x y Hx Hy.
destruct x as [|p|p]; try discriminate Hx.
change 0 with (0+0)%Z.
replace (Zpos p) with (1 + (Zpos p - 1))%Z.
repeat rewrite injT_plus.
rewrite scalT_plus_l; rewrite scalT_1.
apply ltT_compat; auto.
apply scalT_pos; auto.
case p; intros; intros HH1; discriminate HH1.
ring.
Qed.

Lemma scalT_eq: forall x y, 0 = y -> (0:T _) = x * y.
Proof.
intros x y Hy; rewrite <- Hy; rewrite scalT_inj0; auto.
Qed.

End Init.

(* Unusal notation *)
Declare Scope F_scope.
Notation "x + y" := (plusT _ x y) : F_scope.
Notation "x - y" := (minusT _ x y) : F_scope.
Notation "x * y" := (scalT _ x y) : F_scope.
Notation "x <= y" := (leT _ x y) : F_scope.
Notation "x < y" := (ltT _ x y) : F_scope.


Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

Require Import util.
Require Import Le.
Require Import Lt.
Require Import Rbase.
Require Import Plus.
Require Import Mult.
Require Import Arith.
Require Import Omega.
Require Import Div2.
Require Import Recdef.
Require Import Rbase.
Require Import Morphisms.

(* nat misc *)

Definition ltb (x y: nat): bool := negb (leb y x).
Definition geb (x y: nat): bool := leb y x.

Ltac subst_tac x y z := (* todo: rename *)
  match z with
  | x => y
  | ?l + ?r =>
      let l' := subst_tac x y l in
      let r' := subst_tac x y r in
        constr: (l' + r')
  | ?l * ?r =>
      let l' := subst_tac x y l in
      let r' := subst_tac x y r in
        constr: (l' * r')
  | _ => z
  end.

Ltac deep_le_trans h :=
  match type of h with
  | ?n <= ?u =>
    match goal with
    | |- ?l <= _ =>
      let q := subst_tac n u l
      in apply le_trans with q
    end
  end.

Instance Transitive_le: Transitive le := le_trans.

Lemma minus_plus_same (y x: nat): x <= x - y + y.
Proof. intros. omega. Qed.

Lemma ltb_complete m n: ltb m n = true -> m < n.
Proof with auto.
  unfold ltb.
  intros.
  apply leb_complete_conv.
  apply negb_inv...
Qed.

Lemma ltb_complete_conv m n: ltb m n = false -> n <= m.
Proof. unfold ltb. intros. apply leb_complete. apply negb_inv; auto. Qed.

Lemma lt_0_mult x y: 0 < x -> 0 < y -> 0 < x * y.
Proof with auto.
  destruct x.
    intros.
    inversion H.
  simpl.
  intros.
  apply lt_plus_trans...
Qed.

Lemma mult_ne_0 a b: (a <> 0 -> b <> 0 -> mult a b <> 0)%nat.
Proof with auto with arith.
  destruct a... destruct b...
  intros. simpl. discriminate.
Qed.

Lemma weak_lt_S_n n m: S n < m -> n < m.
Proof with auto with arith.
  intros.
  apply lt_S_n.
  apply lt_trans with m...
Qed.

Lemma le_exists_plus (x y: nat) (p: x <= y): exists d, y = x + d.
Proof with auto.
  induction p.
    exists 0...
  destruct IHp.
  exists (S x0).
  subst...
Qed.

Lemma lt_exists_plus (x y: nat) (p: x < y): exists d, y = S (x + d).
Proof.
  unfold lt in p.
  destruct (le_exists_plus p).
  exists x0.
  assumption.
Qed.

Lemma n_lt_n_plus_Sm n m: n < n + S m.
Proof. intros. omega. Qed.

Lemma ne_le_impl_lt x y: x <> y -> x <= y -> x < y.
Proof. auto with *. Qed.

Hint Rewrite plus_0_r : arith_norm.
Hint Rewrite mult_plus_distr_r mult_plus_distr_l plus_assoc : arith_norm.

Lemma beq_nat_false x y: x <> y -> beq_nat x y = false.
Proof with auto.
  intros.
  case_eq (beq_nat x y)...
  intros.
  elimtype False.
  apply H.
  apply beq_nat_eq...
Qed.

Lemma minus_lt_compat_l x y z: (y <= x -> z < y -> x - y < x - z)%nat.
Proof with auto.
  intros.
  omega.
Qed.

Lemma minus_eq_inv_r d x y: (x <= d -> y <= d -> (d - x = d - y) -> x = y)%nat.
Proof with auto with arith.
  revert x y.
  induction d.
    simpl.
    intros.
    destruct x...
    inversion H.
  simpl.
  intros.
  destruct x.
    destruct y...
    elimtype False.
    apply le_Sn_n with d...
    rewrite H1.
    apply le_minus.
  destruct y.
    elimtype False.
    apply le_Sn_n with d.
    rewrite <- H1.
    apply le_minus.
  apply eq_S.
  apply IHd...
Qed.

Lemma le_ne_lt x y: x <= y -> x <> y -> x < y.
Proof. intros. omega. Qed.

Lemma ne_nlt_lt x y: x <> y -> ~ x < y -> y < x.
Proof with auto.
  intros.
  destruct (le_gt_dec x y)...
  destruct (le_lt_eq_dec _ _ l)...
    elimtype False...
  elimtype False...
Qed.

Lemma lt_not_eq x y: (x < y -> x <> y)%nat.
Proof. intros. omega. Qed.

Lemma lt_not_eq_sym x y: (y < x -> x <> y)%nat.
Proof. intros. omega. Qed.

Hint Resolve lt_not_eq.
Hint Resolve lt_not_eq_sym.

(* sqrd *)

Definition sqrd n := n * n.

Lemma sqrd_S n: sqrd (S n) = sqrd n + n + n + 1.
Proof with auto with arith.
  induction n...
  rewrite IHn.
  clear IHn.
  unfold sqrd.
  ring.
Qed.

Lemma sqrd_plus x y: sqrd x + sqrd y <= sqrd (x + y).
Proof with auto with arith.
  intros.
  unfold sqrd.
  autorewrite with arith_norm...
Qed.

Lemma sqrd_le x y: x <= y -> sqrd x <= sqrd y.
  intros.
  unfold sqrd.
  apply mult_le_compat; auto.
Qed.

Hint Resolve sqrd_plus sqrd_le.

(* div2 properties *)

Lemma div2_preserves_le x y: x <= y -> div2 x <= div2 y.
Proof.
  rewrite !Nat.div2_div. now apply Nat.div_le_mono.
Qed.

Lemma Sdiv2_eq_div2SS x: S (div2 x) = div2 (S (S x)).
Proof. reflexivity. Qed.

Lemma div2S_le_Sdiv2 x: div2 (S x) <= S (div2 x).
Proof with auto with arith.
  destruct x...
  rewrite <- Sdiv2_eq_div2SS.
  apply -> Nat.succ_le_mono. apply div2_preserves_le...
Qed.

Lemma div2_x_plus_Sx b: div2 (b + S b) = b.
Proof with auto with arith.
  induction b...
  rewrite plus_Sn_m.
  rewrite <- plus_Snm_nSm.
  rewrite plus_Sn_m.
  simpl...
Qed.

Lemma div2_x_plus_2y a b: div2 (a + 2 * b) = div2 a + b.
Proof.
  rewrite !Nat.div2_div, Nat.mul_comm. now apply Nat.div_add.
Qed.

Lemma div2_sqrdSn n: div2 (sqrd n) + n <= div2 (sqrd (S n)).
Proof with auto with arith.
  intros.
  unfold sqrd.
  replace (S n * S n) with (n * n + 2 * n + 1) by ring.
  replace (div2 (n * n) + n) with (div2 (n * n + 2 * n)).
    apply div2_preserves_le...
  rewrite div2_x_plus_2y...
Qed.

Lemma le_div2 n: div2 n <= n.
Proof. apply Nat.div2_decr; auto with arith. Qed.

Lemma div2_lt_inv0 x y: div2 x < div2 y -> x < y.
Proof.
  rewrite !Nat.lt_nge. intros H H'. contradict H. now apply div2_preserves_le.
Qed.

Lemma div2_lt_inv x y: div2 x < div2 y -> x <= y.
Proof.
  intros. now apply Nat.lt_le_incl, div2_lt_inv0.
Qed.

Lemma div2_le_div2_inv x y: div2 x <= div2 y -> x <= S y.
Proof with auto with arith.
 destruct x as [|[|x]]...
 simpl. intros H. apply div2_lt_inv0 in H...
Qed.

Lemma div2_cancel n: div2 (2 * n) = n.
Proof with auto.
  induction n...
  simpl mult.
  rewrite <- plus_n_Sm.
  simpl in *...
Qed.

Lemma div2_le_inv x n: div2 x <= n -> x <= S (2 * n).
Proof. intros. rewrite <- (div2_cancel n) in H. apply (div2_le_div2_inv _ _ H). Qed.

(* pow *)

Fixpoint pow (b e: nat) {struct e}: nat :=
  match e with
  | 0 => 1
  | S e' => b * pow b e'
  end.

Lemma pow_S x y: pow x (S y) = x * pow x y.
Proof. auto. Qed.

Lemma pow_min x: x <> 0%nat -> forall y, 0 < pow x y.
Proof with auto with arith.
  intros H.
  induction y...
  simpl.
  apply lt_0_mult...
  destruct x...
Qed.

(* log2 *)

Function ceil_log2_S (n: nat) {wf lt n}: nat :=
  match n with
  | 0 => 0
  | S _ => S (ceil_log2_S (div2 n))
  end.
Proof.
  intros.
  apply lt_div2; auto with arith.
  apply lt_wf.
Defined.

Lemma ceil_log2_S_def n: ceil_log2_S n =
  match n with
  | 0 => 0
  | S _ => S (ceil_log2_S (div2 n))
  end.
Proof. functional induction (ceil_log2_S n); auto. Qed.

Definition log2ceil (n: nat): nat :=
  match n with
  | 0 => 0
  | S n' => ceil_log2_S n'
  end.

Function floor_log2_S (n: nat) {wf lt n}: nat :=
  match n with
  | 0 => 0
  | S n' => S (floor_log2_S (div2 n'))
  end.
Proof.
  intros.
  apply le_lt_trans with n'; auto with arith.
  apply le_div2.
  apply lt_wf.
Defined.

Lemma pow2_ceil_log2: forall n, S n <= pow 2 (ceil_log2_S n).
Proof with auto.
  intro.
  functional induction (ceil_log2_S n).
    simpl...
  rewrite pow_S.
  cset' (pow 2 (ceil_log2_S (div2 (S _x)))).
  destruct H.
    inversion IHn0.
  cset (le_S_n _ _ IHn0).
  cset (div2_le_inv (S _x) H0).
  omega.
Qed.

Lemma ceil_log2_Sn_le_n: forall n, ceil_log2_S n <= n.
Proof with auto with arith.
  intro.
  functional induction (ceil_log2_S n)...
  apply le_n_S.
  apply le_trans with (div2 (S _x))...
  apply lt_n_Sm_le.
  apply lt_div2...
Qed.

Lemma log2ceil_lt: forall n, 0 < n -> log2ceil n < n.
Proof with auto.
  destruct n...
  simpl.
  unfold lt.
  intros.
  apply le_n_S.
  apply ceil_log2_Sn_le_n.
Qed.

Lemma log2ceil_le: forall n, log2ceil n <= n.
Proof with auto with arith.
  destruct n...
  apply lt_le_weak.
  apply log2ceil_lt...
Qed.

Lemma log2ceil_S_preserves_le x y: x <= y -> ceil_log2_S x <= ceil_log2_S y.
Proof with auto with arith.
  revert y.
  functional induction (ceil_log2_S x)...
  intros.
  destruct y.
    inversion H.
  apply le_trans with (S (ceil_log2_S (div2 (S y)))).
    apply le_n_S...
    apply IHn.
    apply div2_preserves_le...
  rewrite (ceil_log2_S_def (S y))...
Qed.

Lemma log2ceil_preserves_le x y: x <= y -> log2ceil x <= log2ceil y.
Proof with auto with arith.
  destruct x.
    destruct y...
  destruct y.
    intros.
    inversion H.
  simpl.
  intros.
  apply log2ceil_S_preserves_le...
Qed.

(* INR comparisons *)

Lemma INR_S_ne_0 n: INR (S n) <> 0%R.
Proof. apply not_O_INR. discriminate. Qed.

Hint Resolve INR_S_ne_0.

Lemma O_le_inv_INR_S n: (0 <= / INR (S n))%R.
Proof. intros. apply Rlt_le. apply Rinv_0_lt_compat. apply lt_INR_0. auto with arith. Qed.

Hint Resolve O_le_inv_INR_S.

Lemma INR_0_inv n: INR n = 0%R -> n = 0.
Proof with auto.
  destruct n...
  intros.
  elimtype False.
  apply (INR_S_ne_0 _ H).
Qed.

Lemma O_lt_INR_S n: (0 < INR (S n))%R.
Proof. intros. apply lt_INR_0. auto with arith. Qed.

Hint Resolve O_lt_INR_S.

Require Import Fourier.

(* R misc *)

Ltac deep_Rle_trans h :=
  match type of h with
  | ?n <= ?u =>
    match goal with
    | |- (?l <= _)%R =>
      let q := subst_tac n u l
      in apply Rle_trans with q
    | _ => assert (False)
    end
  end.

Lemma Rmult_eq_compat_r (r r1 r2: R): (r1 = r2 -> r1 * r = r2 * r)%R.
Proof. intros. subst. reflexivity. Qed.

Lemma Rle_eq_trans x y z: (x <= y -> y = z -> x <= z)%R.
Proof. intros. fourier. Qed.

Lemma Req_ne_dec (x y: R): { x = y } + { x <> y }.
Proof with auto.
  intros.
  destruct (Rlt_le_dec x y).
    right. intro. subst. apply (Rlt_irrefl y)...
  destruct (Rle_lt_or_eq_dec _ _ r); [right | left]...
  intro. subst. apply (Rlt_irrefl y)...
Qed.

Lemma Rmult_0_inv (a b: R): (a * b)%R = 0%R -> (a = 0%R \/ b = 0%R).
Proof with auto with real.
  intros.
  destruct (Req_ne_dec a 0%R)...
    destruct (Req_ne_dec b 0%R).
    right...
  elimtype False.
  apply (prod_neq_R0 a b)...
Qed.

Lemma Req_le_trans x y z: x = y -> y <= z -> x <= z.
Proof. intros. subst. assumption. Qed.

Lemma Rle_plus_trans_l r a b c: a <= r -> r + b <= c -> a + b <= c.
Proof. intros. apply Rle_trans with (r + b); auto with real. Qed.

Lemma Rne_nlt_lt x y: x <> y -> ~ x < y -> y < x.
Proof with auto with real.
  intros.
  destruct (Rlt_le_dec x y)...
    elimtype False...
  destruct (Rle_lt_or_eq_dec y x r)...
  elimtype False...
Qed.

Lemma Rdiv_le_1 a b: 0 < a -> a <= b -> 1 <= b / a.
Proof with auto with real.
  intros.
  unfold Rdiv.
  rewrite <- (Rinv_r a)...
Qed.

Lemma Rdiv_lt_1 n m: 0 <= n -> n < m -> n / m < 1.
Proof with auto with real.
  unfold Rdiv.
  intros.
  rewrite <- (Rinv_r m)...
    apply Rmult_lt_compat_r...
    apply Rinv_0_lt_compat...
    fourier.
  intro.
  subst.
  apply (Rlt_not_le _ _ H0 H).
Qed.

Lemma zero_le_2_div_Sn n: 0 <= (2 * / INR (S n))%R.
Proof with auto with real.
  intros.
  unfold Rdiv...
  apply Rle_mult_inv_pos...
Qed.

Hint Resolve zero_le_2_div_Sn.

Definition bigO (f g: nat -> R): Prop := exists c, exists n, forall x, (n <= x)%nat -> f x <= c * g x.

Definition measured_bigO (X: Set) (m: X -> nat) (f: X -> R) (g: nat -> R): Prop
  := exists c, exists n, forall x, (n <= m x)%nat -> f x <= c * g (m x).

Notation "'over' m , f =O( g )" := (measured_bigO m f g).


(********** Translating Expressions in Time **********)

(* This module defines the operation [translateExp] on expressions,
which corresponds to the [Translate] constructs on contracts. In
contrast to [Translate], however, [translateExp] works on [Z] instead of
only on [nat]. *)

Require Import Denotational.
Require Import Tactics.
Require Import Typing.
Require Import FunctionalExtensionality.

Fixpoint translateExp (d : Z) (e : Exp) : Exp :=
  match e with
    | OpE op args => OpE op (map (translateExp d) args)
    | Obs l i => Obs l (d + i)
    | VarE a => VarE a
    | Acc f n z => Acc (translateExp d f) n (translateExp d z)
  end.

Lemma translateExp_ope d op args : translateExp d (OpE op args) = OpE op (map (translateExp d) args).
reflexivity. Qed.

Ltac rewr_assumption := idtac; match goal with
                          | [R:  _ |- _ ] => rewrite R
                        end.

Lemma translateExp_ext (env : Env) d (e : Exp) ext :
  E[|translateExp d e|] env ext = E[|e|] env (adv_ext d ext).
Proof.
  generalize dependent ext.   generalize dependent env.
  induction e using Exp_ind';intros;
  try solve [simpl; repeat rewr_assumption; reflexivity].
  rewrite translateExp_ope. simpl. rewrite map_map.
  eapply all_apply with (p:= env) in H.
  eapply all_apply with (p:= ext) in H.
  apply map_rewrite in H. rewrite H. reflexivity.

  generalize dependent ext.   generalize dependent env.
  simpl. unfold Fsem in *. induction d0; intros.
  - simpl. apply IHe2.
  - repeat rewrite adv_ext_step. simpl. rewrite IHd0.
    repeat rewrite adv_ext_iter. apply bind_equals.
    f_equal; try (f_equal; omega). f_equal.
    f_equal; try (f_equal;f_equal; omega). do 2 (apply functional_extensionality; intro).
    do 3 f_equal. apply functional_extensionality. intros. do 3 f_equal. omega. do 2 f_equal. omega.
    intros.    rewrite IHe1.
    repeat rewrite Zpos_P_of_succ_nat. do 2 f_equal. omega. rewrite <- adv_ext_0. f_equal.
    omega.
Qed.

Open Scope Z.

Lemma translateExp_ext_opp (env : Env) (d d' : Z) (e : Exp) (ext : ExtEnv):
  d' + d = 0 -> E[|translateExp d e|] env (adv_ext d' ext) = E[|e|] env ext.
Proof.
  intro H. rewrite translateExp_ext. rewrite adv_ext_opp; auto.
Qed.

Lemma translateExp_type g d e t : g |-E e ∶ t -> g |-E translateExp d e ∶ t.
Proof.
  intro T. generalize dependent g.  generalize dependent t.
  induction e using Exp_ind'; intros; simpl; inversion T; subst; auto.
  - econstructor. eassumption. eapply all_apply' in H. apply all_zip; eauto.
Qed.


Require Import QArith_base.
Require Import Qcanon.
Require Import Equalities.
Require Import Orders.
Require Import OrdersTac.

Local Open Scope Qc_scope.

Module Qc_as_DT <: DecidableTypeFull.
  Lemma  Qc_eq_bool_iff : forall x y, Qc_eq_bool x y = true <-> x = y.
  Proof.
  intros. split.
    apply Qc_eq_bool_correct.
    intro. unfold Qc_eq_bool. destruct (Qc_eq_dec x y). reflexivity. contradiction.
  Qed.

  Definition t := Qc.
  Definition eq := @eq Qc.
  Definition eq_equiv := @eq_equivalence Qc.
  Definition eqb := Qc_eq_bool.
  Definition eqb_eq := Qc_eq_bool_iff.

  Include BackportEq.
  Include HasEqBool2Dec.

End Qc_as_DT.

Module Qc_as_OT <: OrderedTypeFull.
  Lemma Qccompare_spec (x y : Qc) : CompareSpec (x=y) (x<y) (x>y) (x ?= y).
  Proof. now case_eq (x ?= y); constructor; [rewrite Qceq_alt | rewrite Qclt_alt | rewrite Qcgt_alt]. Qed.

  Include Qc_as_DT.
  Definition lt := Qclt.
  Definition le := Qcle.
  Definition compare := Qccompare.

  Instance lt_strorder : StrictOrder Qclt.
  Proof. split.
    intro. apply Qlt_irrefl.
    intros x y z. apply Qlt_trans.
  Qed.

  Instance lt_compat : Proper (eq==>eq==>iff) Qclt.
  Proof. intros x y Hxy z t Hzt. now rewrite Hxy, Hzt. Qed.

  Theorem le_lteq : forall x y : t, le x y <-> lt x y \/ eq x y.
  Proof.
  intros x y. unfold le,lt,eq. split; intro H.
    destruct (Qcle_lt_or_eq _ _ H). now left. right. assumption.
    destruct H. now apply Qlt_le_weak. subst. now apply Qcle_refl.
  Qed.
  Definition compare_spec (x y : Qc) := Qccompare_spec x y.

End Qc_as_OT.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Section Sets.
  Variable U : Type.

  Definition set := U -> Prop.

  Definition In (A:set) x : Prop := A x.

  Definition Set_included A B := forall x, In A x -> In B x.

  Inductive Set_inter (A B:set) : set :=
    Set_inter_intro : forall x, In A x -> In B x -> In (Set_inter A B) x.

  Inductive Set_union (A B:set) : set :=
    | Set_union_intro_l : forall x, In A x -> In (Set_union A B) x
    | Set_union_intro_r : forall x, In B x -> In (Set_union A B) x.

  Inductive Set_empty : set :=.

  Inductive Set_full : set :=
    | Set_full_intro : forall x, In Set_full x.

  Inductive Set_singleton (x:U) : set :=
    Set_singleton_intro : In (Set_singleton x) x.

  Inductive Set_couple (x y:U) : set :=
    | Set_couple_l : In (Set_couple x y) x
    | Set_couple_r : In (Set_couple x y) y.

  Inductive Set_triple (x y z:U) : set :=
    | Set_triple_l : In (Set_triple x y z) x
    | Set_triple_m : In (Set_triple x y z) y
    | Set_triple_r : In (Set_triple x y z) z.

  Definition Set_complement (A:set) : set := fun x:U => ~ In A x.

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

  Definition Set_subtract (B:set) (x:U) : set := Set_minus B (Set_singleton x).

  Inductive Set_disjoint (B C:set) : Prop :=
    Set_disjoint_intro : (forall x:U, ~ In (Set_inter B C) x) -> Set_disjoint B C.

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

  Definition Set_strict_included (B C:set) : Prop := Set_included B C /\ B <> C.

  Definition Set_same (B C:set) : Prop := Set_included B C /\ Set_included C B.

  Axiom Set_Extensionality : forall A B:set, Set_same A B -> A = B.
End Sets.

Arguments set {U}.
Arguments In {U} A x.
Arguments Set_included {U} A B.
Arguments Set_inter {U} A B _.
Arguments Set_union {U} A B _.
Arguments Set_empty {U} _.
Arguments Set_full {U} _.
Arguments Set_singleton {U} x _.
Arguments Set_couple {U} x y _.
Arguments Set_triple {U} x y z _.
Arguments Set_complement {U} A _.
Arguments Set_minus {U} B C _.
Arguments Set_subtract {U} B x _.
Arguments Set_disjoint {U} B C.
Arguments Set_inhabited {U} B.
Arguments Set_strict_included {U} B C.
Arguments Set_same {U} B C.
Arguments Set_Extensionality {U} A B _.


(*I will introduce you to how to operate with Coq
in the very basic steps

 Coq as a language is very raw and with not many
 in built structures.

 Instead, Coq allows for more control by the user
 (even the equalities are defined by the user!)

 Coq works with Inductive, Module, Definition and a
 proof mode.

 Already implemented Types are: nat naturals, bool booleans,
 Prop propositions, Set set.

 Let us work first on Prop.
*)

Check Prop. Check 2 = 1. Check True -> True.

Check False -> False. Eval compute in 10 + 10.

Eval compute in true. Compute false. Compute True -> True.

(* We enter proof mode by defining a goal/theorem
 about a proposition. the followint is the structure of a
 well written proof.*)

Goal forall (A:Prop), A -> A. (* Goal, definition of A, Prop.*)
Proof. (*Start of your proof.*)
  intros A. (*Introduces A as a given fact.*)
  intros Hypoth. (*Same as above*)
  (*We now know that A is a given fact because of Hypoth,
   and that we want to prove A.*)
  exact Hypoth. (* "Same as Hypoth"*)
  (*Now we can close our proof with Qed.*)
Qed.

Goal forall A B : Prop, (A -> A) /\ (B -> B).
Proof.
  intros. (*This command introduces everything automatically.*)
  (*Well, we met this: (A -> A) /\ (B -> B) which is "And".*)
  refine(conj _ _). (*This separates 1 goal into 2.*)
  (*In Coq, we always prove the topmost subgoals first.
  If you want to skip any of them for the time being, you
  can call the "admit." command, and it eliminates the
  topmost goal.*)
  admit.
  intro H.
  exact H.
  (*At this point, the following message displays:
  No more subgoals, but there are some goals you gave up:

  A -> A

  You need to go back and solve them.
  Let us end our proof and do it the right way.*)
  Admitted.
  (*The command Admitted. closes an entire proof under
  the assumption that it is an axiom/unfinished proof.*)

Goal forall A B : Prop, (A -> A) /\ (B -> B).
Proof.
  intros.
  refine(conj _ _).
  trivial.
  auto.
Qed.

Theorem n_equals_n : forall n:nat, n = n.
Proof.
  (*Whenever we have "forall", it is a good idea to
  introduce the variables/facts.*)
  intros.
  (*To prove this, you can use auto/trivial/intuition etc.
  The ideal argument instead is "reflexivity.". Let us use
  that.*)
  reflexivity.
Qed.

Goal forall n m:nat, n = n /\ m = m.
Proof.
  intros.
  refine(conj _ _).
  (*We can use flexibility again, but let use our recently
  proven theorem/lemma.*)
  apply n_equals_n.
  (*Or, we can introduce our lemma for later.*)
  pose proof n_equals_n as theorem.
  (* pose [args]. takes some arguments and generates a new
  fact object which we can use later.*)
  apply theorem.
Qed.

Goal true = true.
Proof.
  (*We could just use reflex. or apply a previous theorem,
  but let me show you another strategy.*)

  pose(x := true). (*Declares "obj" defined as "true".*)
  (*We can create facts which will be added as a subgoal,
  and we will need to prove such fact.*)
  assert(x = true). trivial.
  (*Now, we can rewrite our goal.*)
  rewrite <- H.
  pose proof n_equals_n as T.
  trivial.
Qed.

Goal 5 < 6.
Proof.
  intuition.
Qed.

Goal 5 <> 6. (* 5 not equal 6*)
Proof.
  (*reflexivity here fails. lets try unfolding this.*)
  unfold not. (*you can try autounfold.*)
  intro H.
  (*We ended up in false. It means one of our Props is
  false by nature, and we need to check which one.
  Thankfully, since the statement H is simple enough,
  we use discriminate.*)
  discriminate.
Qed.

Goal False -> False.
Proof.
  intro.
  (*One of our facts is false, let us use that.*)
  exact H.
Qed.

Goal forall a b:Prop, a -> b \/ a.
Proof.
  intros.
  pose (H0 := or_intror H : b \/ a).
  Check H0.
  (*We created a fact "b \/ a" with the argument H. Only
  demanding part was "or_intro(l/r)".*)
  exact H0.
Qed.

(*Here is a nice exercise:*)
Goal (forall A B : Prop, A -> (A->B) -> B).
Proof.
 intros A.
 intros B.
 intros proof_of_A.
 intros A_implies_B.
 pose (proof_of_B := A_implies_B proof_of_A).
 (*pose (proof_of_B := proof_of_A A_implies_B).
  this is the incorrect order.*)
 exact proof_of_B.
Qed.

Goal (forall A B : Prop, A\/B -> B\/A).
Proof.
  intros.
  case H.

    intro.
    refine(or_intror _).
    exact H0.

    intro.
    refine(or_introl _). (*this one is different from above*)
    exact H0.
Qed.

Goal forall (a b:Prop), exists x:Prop, x -> (a->b) -> b.
Proof.
  intros.
  (*We have an existence question. we can either prove it,
  with an example, prove it in a shady way, or disprove it.*)
  pose(example := a).
  (*We have our example, let us substitute in our goal.*)
  refine(ex_intro _ example _).
  (*refine(ex_intro function example _). more on documentation*)

  (*We eliminated the existencial condition. we proceed.*)
  intros.
  pose(H1 := H0 H).
  exact H1.
Qed.

(*We will need the following knowledge.*)
Goal True.
Proof. exact I. Qed.

(*Let us make a tiny exercise.*)
Lemma x_not_false_and_x_true : forall x:Prop, x <> False /\ x -> True.
Proof.
  intros.
  destruct H as [].
  exact I.
Qed.

(*Little challenge for you.*)
Theorem a_true_false : forall a:Prop, ((a->True)/\(a->False))->False.
Proof.
  (*Write proof here*)
Admitted.

Goal ~exists x:Prop,
  x <> False /\ x -> False.
Proof.
  intros.

  (*It may not tell you, but the negation of existence is
  for all. Let us use that.*)

  pose proof x_not_false_and_x_true as H.
  unfold not.

  intro.
  case H0.
  unfold not in H.
  (*Okay, now our lemma comes in place to help us.
  we will use the last two lemmas.*)

  intros.

  pose proof a_true_false as T. (*challenge lemma*)

  pose(s := ((x = False) -> False) /\ x). (*lets make a
  variable substitution.*)
  assert(s = (((x = False) -> False) /\ x)). intuition.
  (*do not forget that we need to prove both are equal.*)
  (*we are rewriting so that we get the shape that
  lemma T requires.*)

  rewrite <- H2 in H1.
  (*since our prior lemma is for all x, we need to specify
  one x.*)
  assert((((x = False) -> False) /\ x) -> True). apply H.

  rewrite <- H2 in H3.
  (*we make more asserts to finish with T*)
  assert((s -> True) /\ (s -> False)). intuition.
  assert(((s -> True) /\ (s -> False))->False). apply T.

  pose(finale := H5 H4).
  exact finale.
Qed.

(*Since the last proof was on the heavy end of a simple
  proof, we shall have a break to explore the nat set.*)

Print nat.

(*Inductive nat : Set :=
| O : nat
| S : nat -> nat.*)

(*We define nat as an inductive type, which constructors
  are O and S (uppercase O, not zero.*)

Eval compute in 5 - 3.

(*Every simple natural operation except division is defined.
  With subtraction there is a catch, 3 - 5 = 0.*)

Eval  compute in 3 - 5.

Lemma sub_in_nat_is_weird : 3 - 5 = 0.
Proof.
  simpl. (*This simplifies an expression.*)
  reflexivity.
Qed.

(*Proving in naturals function the same way as we did
  before.*)

(*We define 3 as S(S(S(O))).*)

Goal S(S(S(0))) = 3.
Proof.
  reflexivity. Qed.

(*let us define a function that detects a zero.*)

Definition is_zero (n:nat) := (*parameters*)
match n with (*works in a similar fashion of switch case*)
| O => true (*if base constructor (aka 0), then true*)
| S n' => false (* if it is a sucessor of any number, false*)
end.

Eval compute in is_zero 0. Compute is_zero 11.

(*Let us create a definition*)
Definition n_not_0 : forall n:nat, is_zero n = false -> n > 0.
Admitted.

Goal is_zero 0 = true.
Proof.
  simpl.
  reflexivity.
Qed.

(*We can define recursive functions.*)

Fixpoint evenb (n:nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
  end.

Eval compute in evenb 2. Compute evenb 4.

(*Let us define some facts.*)

Definition a0 : forall b:bool, negb b <> b.
Proof.
  intro b.
  autounfold.
  case b.
    simpl. intro. discriminate.
    simpl. intro. discriminate.
Qed.

Definition a0_1 : forall b:bool, b <> negb b.
Proof.
  intro b.
  autounfold.
  case b.
    simpl. intro. discriminate.
    simpl. intro. discriminate.
Qed.

Definition a1 : forall (n:nat),
  evenb n = evenb (n+2).
Proof.
  (*Can you prove it?*)
Admitted.

Definition a2 : forall (n:nat),
  evenb n = negb (evenb(n+1)).
Proof.
  (*Yet again another challenge.*)
Admitted.

Definition a2_1 : forall (n:nat), evenb n <> evenb(n+1).
Proof.
  intro.
  pose proof a2 as a2.
  rewrite a2.
  pose proof a0 as a0.
  apply a0.
Qed.

Definition a2_2 : forall n:nat,
evenb n = negb (evenb (n + 1)) <-> evenb n <> evenb(n+1).
Proof.
  intro.
  unfold iff.
  refine(conj _ _).

    intro.
    rewrite H.
    pose proof a0 as a0.
    apply a0.

    intro.
    autounfold in H.
    (*                    did not work for me.
    destruct H as [].
    pose proof a2 as a2.
    rewrite a2.
    pose proof a0 as a0.

    pose(x := evenb(n+1)).
    assert(x = evenb(n+1)).
    auto.
    rewrite <- H.
    case x.
      simpl.
      assert(false <> true). intuition. discriminate.*)
    pose proof a2.
    apply H0.
Qed.

Goal 6 = 6.
Proof.
  assert(forall x:nat, x = x). reflexivity.
  pose(x := 6).
  assert(6 = x). trivial.
  rewrite H0.
  apply H.
Qed.

Goal evenb 4 = evenb 6.
Proof.
  pose proof a1 as hyp_1.
  apply hyp_1.
Qed.

Goal evenb 4 = evenb 820.
Proof.
  pose proof a1 as hyp_1.
  apply hyp_1.
Qed.

Goal evenb 4 <> evenb 5.
Proof.
  pose proof a2_1 as hyp_2.
  apply hyp_2.
Qed.

Goal evenb 7 = false.
Proof.
  simpl.
  reflexivity.
Qed.

(*Here we start the real theorems!*)
Theorem two_n_is_even : forall n:nat, evenb(2*n) = true.
Proof.
  intro.
  elim n. simpl. reflexivity.
    intros.
    pose proof a1.
    rewrite H0 in H.
    assert(2* S n0 = 2*n0 + 2). auto.
    rewrite H1.
    exact H.
Qed.

(*This one will be really complicated to follow through.*)
Theorem a3_1 : forall n:nat, evenb(2*n + 1) = false.
Proof.
  intro.
  pose proof two_n_is_even as lem1.
  pose proof a2 as lem2.

  assert(forall n : nat,
      evenb (2*n) = negb (evenb (2*n + 1))).
    intro.
    pose(x:=2*n0).
    assert(2*n0 = x). auto.
    rewrite H.
    apply lem2.

    assert(negb(evenb (2 * n + 1)) = true).
    rewrite <- H.
    apply lem1.

    assert(forall b:bool, negb b = true -> b = false).
    intro b.
    case b.
      auto.
      auto.

    pose(x:=2 * n + 1). assert(x = 2 * n + 1). auto.
    rewrite <- H2.
    assert(negb(evenb(x)) = true).
    rewrite H2.
    exact H0.
    apply H1.
    exact H3.
Qed.

(*If you could figure out what was happening there, please
  tell me!!*)

(*Let us stray away from evenb functions.*)

Require Import Arith.
(*We imported a library!*)

Compute 5 mod 3.

(*Now we can talk about notations. Let us define a notation.*)

Notation "x ! y" := (y mod x =0) (at level 35).

Compute 3 ! 7.

Goal 3 ! 6.
Proof.
  simpl.
  reflexivity.
Qed.

Goal ~ (3 ! 7).
Proof.
  simpl.
  unfold not.
  intro.
  discriminate.
Qed.

Goal forall (x:nat) (k:nat), x ! (k * x).
Proof.
  intros.
  elim k. simpl.
    assert(x * 0 = 0). intuition. admit.
    intros. simpl.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Require Export Iterator.
Require Import ZArith.
Require Export UList.
Open Scope Z_scope.

Theorem next_n_Z: forall n m,  next_n Z.succ n m = n + Z_of_nat m.
intros n m; generalize n; elim m; clear n m.
intros n; simpl; auto with zarith.
intros m H n.
replace (n + Z_of_nat (S m)) with (Z.succ n + Z_of_nat m); auto with zarith.
rewrite <- H; auto with zarith.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zprogression_end:
 forall n m,
  progression Z.succ n (S m) =
  app (progression Z.succ n m) (cons (n + Z_of_nat m) nil).
intros n m; generalize n; elim m; clear n m.
simpl; intros; apply f_equal2 with ( f := @cons Z ); auto with zarith.
intros m1 Hm1 n1.
apply trans_equal with (cons n1 (progression Z.succ (Z.succ n1) (S m1))); auto.
rewrite Hm1.
replace (Z.succ n1 + Z_of_nat m1) with (n1 + Z_of_nat (S m1)); auto with zarith.
replace (Z_of_nat (S m1)) with (1 + Z_of_nat m1); auto with zarith.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zprogression_pred_end:
 forall n m,
  progression Z.pred n (S m) =
  app (progression Z.pred n m) (cons (n - Z_of_nat m) nil).
intros n m; generalize n; elim m; clear n m.
simpl; intros; apply f_equal2 with ( f := @cons Z ); auto with zarith.
intros m1 Hm1 n1.
apply trans_equal with (cons n1 (progression Z.pred (Z.pred n1) (S m1))); auto.
rewrite Hm1.
replace (Z.pred n1 - Z_of_nat m1) with (n1 - Z_of_nat (S m1)); auto with zarith.
replace (Z_of_nat (S m1)) with (1 + Z_of_nat m1); auto with zarith.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zprogression_opp:
 forall n m,
  rev (progression Z.succ n m) = progression Z.pred (n + Z_of_nat (pred m)) m.
intros n m; generalize n; elim m; clear n m.
simpl; auto.
intros m Hm n.
rewrite (Zprogression_end n); auto.
rewrite distr_rev.
rewrite Hm; simpl; auto.
case m.
simpl; auto.
intros m1;
 replace (n + Z_of_nat (pred (S m1))) with (Z.pred (n + Z_of_nat (S m1))); auto.
rewrite inj_S; simpl; (unfold Z.pred; unfold Z.succ); auto with zarith.
Qed.

Theorem Zprogression_le_init:
 forall n m p, In p (progression Z.succ n m) ->  (n <= p).
intros n m; generalize n; elim m; clear n m; simpl; auto.
intros; contradiction.
intros m H n p [H1|H1]; auto with zarith.
generalize (H _ _ H1); auto with zarith.
Qed.

Theorem Zprogression_le_end:
 forall n m p, In p (progression Z.succ n m) ->  (p < n + Z_of_nat m).
intros n m; generalize n; elim m; clear n m; auto.
intros; contradiction.
intros m H n p H1; simpl in H1 |-; case H1; clear H1; intros H1;
 auto with zarith.
subst n; auto with zarith.
apply Z.le_lt_trans  with (p + 0); auto with zarith.
apply Zplus_lt_compat_l; red; simpl; auto with zarith.
apply Z.lt_le_trans with (Z.succ n + Z_of_nat m); auto with zarith.
rewrite inj_S; rewrite Zplus_succ_comm; auto with zarith.
Qed.

Theorem ulist_Zprogression: forall a n,  ulist (progression Z.succ a n).
intros a n; generalize a; elim n; clear a n; simpl; auto with zarith.
intros n H1 a; apply ulist_cons; auto.
intros H2; absurd (Z.succ a <= a); auto with zarith.
apply Zprogression_le_init with ( 1 := H2 ).
Qed.

Theorem in_Zprogression:
 forall a b n, ( a <= b < a + Z_of_nat n ) ->  In b (progression Z.succ a n).
intros a b n; generalize a b; elim n; clear a b n; auto with zarith.
simpl; auto with zarith.
intros n H a b.
replace (a + Z_of_nat (S n)) with (Z.succ a + Z_of_nat n); auto with zarith.
intros [H1 H2]; simpl; auto with zarith.
case (Zle_lt_or_eq _ _ H1); auto with zarith.
rewrite inj_S; auto with zarith.
Qed.


(* -*- mode: coq; mode: visual-line -*-  *)
(** * H-Sets *)

Require Import Basics.
Require Import Types.
Require Import HProp.

Local Open Scope path_scope.

(** A type is a set if and only if it satisfies Axiom K. *)

Definition axiomK A := forall (x : A) (p : x = x), p = idpath x.

Definition axiomK_hset {A} : IsHSet A -> axiomK A.
Proof.
  intros H x p.
  apply (H x x p (idpath x)).
Defined.

Definition hset_axiomK {A} `{axiomK A} : IsHSet A.
Proof.
  intros x y H.
  apply @hprop_allpath.
  intros p q.
  by induction p.
Defined.

Section AssumeFunext.
Context `{Funext}.

Theorem equiv_hset_axiomK {A} : IsHSet A <~> axiomK A.
Proof.
  apply (equiv_adjointify (@axiomK_hset A) (@hset_axiomK A)).
  - intros K. by_extensionality x. by_extensionality x'.
    cut (Contr (x=x)).
    + intro. eapply path_contr.
    + exists 1. intros. symmetry; apply K.
  - intro K. by_extensionality x. by_extensionality x'.
    eapply path_ishprop.
Defined.

Global Instance axiomK_isprop A : IsHProp (axiomK A) | 0.
Proof.
  apply (trunc_equiv _ equiv_hset_axiomK).
Defined.

Theorem hset_path2 {A} `{IsHSet A} {x y : A} (p q : x = y):
  p = q.
Proof.
  induction q.
  apply axiomK_hset; assumption.
Defined.

(** Recall that axiom K says that any self-path is homotopic to the
   identity path.  In particular, the identity path is homotopic to
   itself.  The following lemma says that the endo-homotopy of the
   identity path thus specified is in fact (homotopic to) its identity
   homotopy (whew!).  *)
(* TODO: What was the purpose of this lemma?  Do we need it at all?  It's actually fairly trivial. *)
Lemma axiomK_idpath {A} (x : A) (K : axiomK A) :
  K x (idpath x) = idpath (idpath x).
Proof.
  pose (T1A := @trunc_succ _ A (@hset_axiomK A K)).
  exact (@hset_path2 (x=x) (T1A x x) _ _ _ _).
Defined.

End AssumeFunext.

(** We prove that if [R] is a reflexive mere relation on [X] implying identity, then [X] is an hSet, and hence [R x y] is equivalent to [x = y]. *)
Lemma ishset_hrel_subpaths
      {X R}
      `{Reflexive X R}
      `{forall x y, IsHProp (R x y)}
      (f : forall x y, R x y -> x = y)
: IsHSet X.
Proof.
  apply @hset_axiomK.
  intros x p.
  refine (_ @ concat_Vp (f x x (transport (R x) p^ (reflexivity _)))).
  apply moveL_Vp.
  refine ((transport_paths_r _ _)^ @ _).
  refine ((transport_arrow _ _ _)^ @ _).
  refine ((ap10 (apD (f x) p) (@reflexivity X R _ x)) @ _).
  apply ap.
  apply path_ishprop.
Defined.

Global Instance isequiv_hrel_subpaths
       X R
       `{Reflexive X R}
       `{forall x y, IsHProp (R x y)}
       (f : forall x y, R x y -> x = y)
       x y
: IsEquiv (f x y) | 10000.
Proof.
  pose proof (ishset_hrel_subpaths f).
  refine (isequiv_adjointify
            (f x y)
            (fun p => transport (R x) p (reflexivity x))
            _
            _);
  intro;
  apply path_ishprop.
Defined.

(** We will now prove that for sets, monos and injections are equivalent.*)
Definition ismono {X Y} (f : X -> Y)
  := forall (Z : hSet),
     forall g h : Z -> X, f o g = f o h -> g = h.

Definition isinj {X Y} (f : X -> Y)
  := forall x0 x1 : X,
       f x0 = f x1 -> x0 = x1.

Lemma isinj_embedding {A B : Type} (m : A -> B) : IsEmbedding m -> isinj m.
Proof.
  intros ise x y p.
  pose (ise (m y)).
  assert (q : (x;p) = (y;1) :> hfiber m (m y)) by apply path_ishprop.
  exact (ap pr1 q).
Defined.

Lemma isembedding_isinj_hset {A B : Type} `{IsHSet B} (m : A -> B)
: isinj m -> IsEmbedding m.
Proof.
  intros isi b.
  apply hprop_allpath; intros [x p] [y q].
  apply path_sigma_hprop; simpl.
  exact (isi x y (p @ q^)).
Defined.

Lemma ismono_isinj `{Funext} {X Y} (f : X -> Y) : isinj f -> ismono f.
Proof.
  intros ? ? ? ? H'.
  apply path_forall.
  apply ap10 in H'.
  hnf in *.
  eauto.
Qed.

Definition isinj_ismono {X Y} (f : X -> Y)
           (H : ismono f)
: isinj f
  := fun x0 x1 H' =>
       ap10 (H (BuildhSet Unit)
               (fun _ => x0)
               (fun _ => x1)
               (ap (fun x => unit_name x) H'))
            tt.

Lemma ismono_isequiv `{Funext} X Y (f : X -> Y) `{IsEquiv _ _ f}
: ismono f.
Proof.
  intros ? g h H'.
  apply ap10 in H'.
  apply path_forall.
  intro x.
  transitivity (f^-1 (f (g x))).
  - by rewrite eissect.
  - transitivity (f^-1 (f (h x))).
    * apply ap. apply H'.
    * by rewrite eissect.
Qed.


Require Import While String.
Require Import ZArith.
Open Scope Z_scope.

Definition fac :=
  Seq
    (Assign "res" (Const 1))
    (Seq
       (While (Lt (Const 0) (Var "n"))
              (Seq
                 (Assign "res" (Binop Bmul (Var "res") (Var "n")))
                 (Assign "n" (Binop Bsub (Var "n") (Const 1)))
              )
       )
       (Output (Var "res"))
    ).