(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require HighOrd.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require list.List.
Require list.Length.
Require list.Mem.
Require map.Map.
Require bool.Bool.
Require list.Append.

(* Why3 assumption *)
Definition unit := unit.

Axiom map : forall (a:Type) (b:Type), Type.
Parameter map_WhyType : forall (a:Type) {a_WT:WhyType a}
  (b:Type) {b_WT:WhyType b}, WhyType (map a b).
Existing Instance map_WhyType.

Parameter get: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b.

Parameter set: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b -> (map a b).

Axiom Select_eq : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (m:(map a b)), forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) ->
  ((get (set m a1 b1) a2) = b1).

Axiom Select_neq : forall {a:Type} {a_WT:WhyType a}
  {b:Type} {b_WT:WhyType b}, forall (m:(map a b)), forall (a1:a) (a2:a),
  forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1) a2) = (get m a2)).

(* Why3 assumption *)
Inductive id :=
  | Id : Z -> id.
Axiom id_WhyType : WhyType id.
Existing Instance id_WhyType.

(* Why3 assumption *)
Definition state := (map id Z).

(* Why3 assumption *)
Inductive aexpr :=
  | Anum : Z -> aexpr
  | Avar : id -> aexpr
  | Aadd : aexpr -> aexpr -> aexpr
  | Asub : aexpr -> aexpr -> aexpr
  | Amul : aexpr -> aexpr -> aexpr.
Axiom aexpr_WhyType : WhyType aexpr.
Existing Instance aexpr_WhyType.

(* Why3 assumption *)
Inductive bexpr :=
  | Btrue : bexpr
  | Bfalse : bexpr
  | Band : bexpr -> bexpr -> bexpr
  | Bnot : bexpr -> bexpr
  | Beq : aexpr -> aexpr -> bexpr
  | Ble : aexpr -> aexpr -> bexpr.
Axiom bexpr_WhyType : WhyType bexpr.
Existing Instance bexpr_WhyType.

(* Why3 assumption *)
Inductive com :=
  | Cskip : com
  | Cassign : id -> aexpr -> com
  | Cseq : com -> com -> com
  | Cif : bexpr -> com -> com -> com
  | Cwhile : bexpr -> com -> com.
Axiom com_WhyType : WhyType com.
Existing Instance com_WhyType.

(* Why3 assumption *)
Fixpoint aeval (st:(map id Z)) (e:aexpr) {struct e}: Z :=
  match e with
  | (Anum n) => n
  | (Avar x) => (get st x)
  | (Aadd e1 e2) => ((aeval st e1) + (aeval st e2))%Z
  | (Asub e1 e2) => ((aeval st e1) - (aeval st e2))%Z
  | (Amul e1 e2) => ((aeval st e1) * (aeval st e2))%Z
  end.

Parameter beval: (map id Z) -> bexpr -> bool.

Axiom beval_def : forall (st:(map id Z)) (b:bexpr),
  (match b with
  | Btrue => True
  | Bfalse => False
  | (Bnot b') => ((Init.Datatypes.negb (beval st b')) = true)
  | (Band b1 b2) => ((Init.Datatypes.andb (beval st b1) (beval st
      b2)) = true)
  | (Beq a1 a2) => ((aeval st a1) = (aeval st a2))
  | (Ble a1 a2) => ((aeval st a1) <= (aeval st a2))%Z
  end -> ((beval st b) = true)) /\
  ((~ match b with
  | Btrue => True
  | Bfalse => False
  | (Bnot b') => ((Init.Datatypes.negb (beval st b')) = true)
  | (Band b1 b2) => ((Init.Datatypes.andb (beval st b1) (beval st
      b2)) = true)
  | (Beq a1 a2) => ((aeval st a1) = (aeval st a2))
  | (Ble a1 a2) => ((aeval st a1) <= (aeval st a2))%Z
  end) -> ((beval st b) = false)).

(* Why3 assumption *)
Inductive ceval: (map id Z) -> com -> (map id Z) -> Prop :=
  | E_Skip : forall (m:(map id Z)), (ceval m Cskip m)
  | E_Ass : forall (m:(map id Z)) (a:aexpr) (x:id), (ceval m (Cassign x a)
      (set m x (aeval m a)))
  | E_Seq : forall (cmd1:com) (cmd2:com) (m0:(map id Z)) (m1:(map id Z))
      (m2:(map id Z)), (ceval m0 cmd1 m1) -> ((ceval m1 cmd2 m2) -> (ceval m0
      (Cseq cmd1 cmd2) m2))
  | E_IfTrue : forall (m0:(map id Z)) (m1:(map id Z)) (cond:bexpr) (cmd1:com)
      (cmd2:com), ((beval m0 cond) = true) -> ((ceval m0 cmd1 m1) -> (ceval
      m0 (Cif cond cmd1 cmd2) m1))
  | E_IfFalse : forall (m0:(map id Z)) (m1:(map id Z)) (cond:bexpr)
      (cmd1:com) (cmd2:com), (~ ((beval m0 cond) = true)) -> ((ceval m0 cmd2
      m1) -> (ceval m0 (Cif cond cmd1 cmd2) m1))
  | E_WhileEnd : forall (cond:bexpr) (m:(map id Z)) (body:com), (~ ((beval m
      cond) = true)) -> (ceval m (Cwhile cond body) m)
  | E_WhileLoop : forall (mi:(map id Z)) (mj:(map id Z)) (mf:(map id Z))
      (cond:bexpr) (body:com), ((beval mi cond) = true) -> ((ceval mi body
      mj) -> ((ceval mj (Cwhile cond body) mf) -> (ceval mi (Cwhile cond
      body) mf))).

Axiom ceval_deterministic_aux : forall (c:com) (mi:(map id Z)) (mf1:(map id
  Z)), (ceval mi c mf1) -> forall (mf2:(map id Z)), (ceval mi c mf2) ->
  (mf1 = mf2).

Axiom ceval_deterministic : forall (c:com) (mi:(map id Z)) (mf1:(map id Z))
  (mf2:(map id Z)), (ceval mi c mf1) -> ((ceval mi c mf2) -> (mf1 = mf2)).

(* Why3 assumption *)
Definition pos := Z.

(* Why3 assumption *)
Definition stack := (list Z).

(* Why3 assumption *)
Inductive machine_state :=
  | VMS : Z -> (list Z) -> (map id Z) -> machine_state.
Axiom machine_state_WhyType : WhyType machine_state.
Existing Instance machine_state_WhyType.

(* Why3 assumption *)
Definition ofs := Z.

(* Why3 assumption *)
Inductive instr :=
  | Iconst : Z -> instr
  | Ivar : id -> instr
  | Isetvar : id -> instr
  | Ibranch : Z -> instr
  | Iadd : instr
  | Isub : instr
  | Imul : instr
  | Ibeq : Z -> instr
  | Ibne : Z -> instr
  | Ible : Z -> instr
  | Ibgt : Z -> instr
  | Ihalt : instr.
Axiom instr_WhyType : WhyType instr.
Existing Instance instr_WhyType.

(* Why3 assumption *)
Definition code := (list instr).

(* Why3 assumption *)
Inductive codeseq_at: (list instr) -> Z -> (list instr) -> Prop :=
  | codeseq_at_intro : forall (c1:(list instr)) (c2:(list instr))
      (c3:(list instr)), (codeseq_at
      (Init.Datatypes.app (Init.Datatypes.app c1 c2) c3)
      (list.Length.length c1) c2).

Axiom codeseq_at_app_right : forall (c:(list instr)) (c1:(list instr))
  (c2:(list instr)) (p:Z), (codeseq_at c p (Init.Datatypes.app c1 c2)) ->
  (codeseq_at c (p + (list.Length.length c1))%Z c2).

Axiom codeseq_at_app_left : forall (c:(list instr)) (c1:(list instr))
  (c2:(list instr)) (p:Z), (codeseq_at c p (Init.Datatypes.app c1 c2)) ->
  (codeseq_at c p c1).

(* Why3 assumption *)
Definition iconst (n:Z): (list instr) :=
  (Init.Datatypes.cons (Iconst n) Init.Datatypes.nil).

(* Why3 assumption *)
Definition ivar (x:id): (list instr) :=
  (Init.Datatypes.cons (Ivar x) Init.Datatypes.nil).

(* Why3 assumption *)
Definition isetvar (x:id): (list instr) :=
  (Init.Datatypes.cons (Isetvar x) Init.Datatypes.nil).

(* Why3 assumption *)
Definition ibeq (ofs1:Z): (list instr) :=
  (Init.Datatypes.cons (Ibeq ofs1) Init.Datatypes.nil).

(* Why3 assumption *)
Definition ible (ofs1:Z): (list instr) :=
  (Init.Datatypes.cons (Ible ofs1) Init.Datatypes.nil).

(* Why3 assumption *)
Definition ibne (ofs1:Z): (list instr) :=
  (Init.Datatypes.cons (Ibne ofs1) Init.Datatypes.nil).

(* Why3 assumption *)
Definition ibgt (ofs1:Z): (list instr) :=
  (Init.Datatypes.cons (Ibgt ofs1) Init.Datatypes.nil).

(* Why3 assumption *)
Definition ibranch (ofs1:Z): (list instr) :=
  (Init.Datatypes.cons (Ibranch ofs1) Init.Datatypes.nil).

(* Why3 assumption *)
Inductive transition: (list instr) -> machine_state -> machine_state ->
  Prop :=
  | trans_const : forall (c:(list instr)) (p:Z) (n:Z), (codeseq_at c p
      (iconst n)) -> forall (s:(list Z)) (m:(map id Z)), (transition c (VMS p
      s m) (VMS (p + 1%Z)%Z (Init.Datatypes.cons n s) m))
  | trans_var : forall (c:(list instr)) (p:Z) (x:id), (codeseq_at c p
      (ivar x)) -> forall (s:(list Z)) (m:(map id Z)), (transition c (VMS p s
      m) (VMS (p + 1%Z)%Z (Init.Datatypes.cons (get m x) s) m))
  | trans_set_var : forall (c:(list instr)) (p:Z) (x:id), (codeseq_at c p
      (isetvar x)) -> forall (n:Z) (s:(list Z)) (m:(map id Z)), (transition c
      (VMS p (Init.Datatypes.cons n s) m) (VMS (p + 1%Z)%Z s (set m x n)))
  | trans_add : forall (c:(list instr)) (p:Z), (codeseq_at c p
      (Init.Datatypes.cons Iadd Init.Datatypes.nil)) -> forall (n1:Z) (n2:Z)
      (s:(list Z)) (m:(map id Z)), (transition c (VMS p
      (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m) (VMS (p + 1%Z)%Z
      (Init.Datatypes.cons (n1 + n2)%Z s) m))
  | trans_sub : forall (c:(list instr)) (p:Z), (codeseq_at c p
      (Init.Datatypes.cons Isub Init.Datatypes.nil)) -> forall (n1:Z) (n2:Z)
      (s:(list Z)) (m:(map id Z)), (transition c (VMS p
      (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m) (VMS (p + 1%Z)%Z
      (Init.Datatypes.cons (n1 - n2)%Z s) m))
  | trans_mul : forall (c:(list instr)) (p:Z), (codeseq_at c p
      (Init.Datatypes.cons Imul Init.Datatypes.nil)) -> forall (n1:Z) (n2:Z)
      (s:(list Z)) (m:(map id Z)), (transition c (VMS p
      (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m) (VMS (p + 1%Z)%Z
      (Init.Datatypes.cons (n1 * n2)%Z s) m))
  | trans_beq : forall (c:(list instr)) (p1:Z) (ofs1:Z), (codeseq_at c p1
      (ibeq ofs1)) -> forall (s:(list Z)) (m:(map id Z)) (n1:Z) (n2:Z),
      (n1 = n2) -> (transition c (VMS p1
      (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m)
      (VMS ((p1 + 1%Z)%Z + ofs1)%Z s m))
  | trans_beq1 : forall (c:(list instr)) (p1:Z) (ofs1:Z), (codeseq_at c p1
      (ibeq ofs1)) -> forall (s:(list Z)) (m:(map id Z)) (n1:Z) (n2:Z),
      (~ (n1 = n2)) -> (transition c (VMS p1
      (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m)
      (VMS (p1 + 1%Z)%Z s m))
  | trans_bne : forall (c:(list instr)) (p1:Z) (ofs1:Z), (codeseq_at c p1
      (ibne ofs1)) -> forall (s:(list Z)) (m:(map id Z)) (n1:Z) (n2:Z),
      (n1 = n2) -> (transition c (VMS p1
      (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m)
      (VMS (p1 + 1%Z)%Z s m))
  | trans_bne1 : forall (c:(list instr)) (p1:Z) (ofs1:Z), (codeseq_at c p1
      (ibne ofs1)) -> forall (s:(list Z)) (m:(map id Z)) (n1:Z) (n2:Z),
      (~ (n1 = n2)) -> (transition c (VMS p1
      (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m)
      (VMS ((p1 + 1%Z)%Z + ofs1)%Z s m))
  | trans_ble : forall (c:(list instr)) (p1:Z) (ofs1:Z), (codeseq_at c p1
      (ible ofs1)) -> forall (s:(list Z)) (m:(map id Z)) (n1:Z) (n2:Z),
      (n1 <= n2)%Z -> (transition c (VMS p1
      (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m)
      (VMS ((p1 + 1%Z)%Z + ofs1)%Z s m))
  | trans_ble1 : forall (c:(list instr)) (p1:Z) (ofs1:Z), (codeseq_at c p1
      (ible ofs1)) -> forall (s:(list Z)) (m:(map id Z)) (n1:Z) (n2:Z),
      (~ (n1 <= n2)%Z) -> (transition c (VMS p1
      (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m)
      (VMS (p1 + 1%Z)%Z s m))
  | trans_bgt : forall (c:(list instr)) (p1:Z) (ofs1:Z), (codeseq_at c p1
      (ibgt ofs1)) -> forall (s:(list Z)) (m:(map id Z)) (n1:Z) (n2:Z),
      (n1 <= n2)%Z -> (transition c (VMS p1
      (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m)
      (VMS (p1 + 1%Z)%Z s m))
  | trans_bgt1 : forall (c:(list instr)) (p1:Z) (ofs1:Z), (codeseq_at c p1
      (ibgt ofs1)) -> forall (s:(list Z)) (m:(map id Z)) (n1:Z) (n2:Z),
      (~ (n1 <= n2)%Z) -> (transition c (VMS p1
      (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m)
      (VMS ((p1 + 1%Z)%Z + ofs1)%Z s m))
  | trans_branch : forall (c:(list instr)) (p:Z) (ofs1:Z), (codeseq_at c p
      (ibranch ofs1)) -> forall (s:(list Z)) (m:(map id Z)), (transition c
      (VMS p s m) (VMS ((p + 1%Z)%Z + ofs1)%Z s m)).

(* Why3 assumption *)
Inductive transition_star: (list instr) -> machine_state -> machine_state ->
  Prop :=
  | Refl : forall (p:(list instr)) (x:machine_state), (transition_star p x x)
  | Step : forall (p:(list instr)) (x:machine_state) (y:machine_state)
      (z:machine_state), (transition p x y) -> ((transition_star p y z) ->
      (transition_star p x z)).

Axiom transition_star_one : forall (p:(list instr)) (s1:machine_state)
  (s2:machine_state), (transition p s1 s2) -> (transition_star p s1 s2).

Axiom transition_star_transitive : forall (p:(list instr)) (s1:machine_state)
  (s2:machine_state) (s3:machine_state), (transition_star p s1 s2) ->
  ((transition_star p s2 s3) -> (transition_star p s1 s3)).

(* Why3 assumption *)
Definition vm_terminates (c:(list instr)) (mi:(map id Z)) (mf:(map id
  Z)): Prop := exists p:Z, (codeseq_at c p
  (Init.Datatypes.cons Ihalt Init.Datatypes.nil)) /\ (transition_star c
  (VMS 0%Z Init.Datatypes.nil mi) (VMS p Init.Datatypes.nil mf)).

(* Why3 assumption *)
Definition fst {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b} (p:(a*
  b)%type): a := match p with
  | (x, _) => x
  end.

(* Why3 assumption *)
Definition snd {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b} (p:(a*
  b)%type): b := match p with
  | (_, y) => y
  end.

(* Why3 assumption *)
Definition pred := (machine_state -> bool).

(* Why3 assumption *)
Definition rel := (machine_state -> (machine_state -> bool)).

(* Why3 assumption *)
Definition pre (a:Type) := (a -> (Z -> (machine_state -> bool))).

(* Why3 assumption *)
Definition post (a:Type) := (a -> (Z -> (machine_state -> (machine_state ->
  bool)))).

(* Why3 assumption *)
Inductive hl
  (a:Type) :=
  | mk_hl : (list instr) -> (a -> (Z -> (machine_state -> bool))) -> (a ->
      (Z -> (machine_state -> (machine_state -> bool)))) -> hl a.
Axiom hl_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (hl a).
Existing Instance hl_WhyType.
Implicit Arguments mk_hl [[a]].

(* Why3 assumption *)
Definition post1 {a:Type} {a_WT:WhyType a} (v:(hl a)): (a -> (Z ->
  (machine_state -> (machine_state -> bool)))) :=
  match v with
  | (mk_hl x x1 x2) => x2
  end.

(* Why3 assumption *)
Definition pre1 {a:Type} {a_WT:WhyType a} (v:(hl a)): (a -> (Z ->
  (machine_state -> bool))) := match v with
  | (mk_hl x x1 x2) => x1
  end.

(* Why3 assumption *)
Definition code1 {a:Type} {a_WT:WhyType a} (v:(hl a)): (list instr) :=
  match v with
  | (mk_hl x x1 x2) => x
  end.

(* Why3 assumption *)
Definition wp_trans (a:Type) := (a -> (Z -> ((machine_state -> bool) ->
  (machine_state -> bool)))).

(* Why3 assumption *)
Inductive wp
  (a:Type) :=
  | mk_wp : (list instr) -> (a -> (Z -> ((machine_state -> bool) ->
      (machine_state -> bool)))) -> wp a.
Axiom wp_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (wp a).
Existing Instance wp_WhyType.
Implicit Arguments mk_wp [[a]].

(* Why3 assumption *)
Definition wp1 {a:Type} {a_WT:WhyType a} (v:(wp a)): (a -> (Z ->
  ((machine_state -> bool) -> (machine_state -> bool)))) :=
  match v with
  | (mk_wp x x1) => x1
  end.

(* Why3 assumption *)
Definition wcode {a:Type} {a_WT:WhyType a} (v:(wp a)): (list instr) :=
  match v with
  | (mk_wp x x1) => x
  end.

(* Why3 assumption *)
Definition contextual_irrelevance (c:(list instr)) (p:Z) (ms1:machine_state)
  (ms2:machine_state): Prop := forall (c_glob:(list instr)), (codeseq_at
  c_glob p c) -> (transition_star c_glob ms1 ms2).

(* Why3 assumption *)
Definition hl_correctness {a:Type} {a_WT:WhyType a} (cs:(hl a)): Prop :=
  forall (x:a) (p:Z) (ms:machine_state), (((((pre1 cs) x) p) ms) = true) ->
  exists ms':machine_state, ((((((post1 cs) x) p) ms) ms') = true) /\
  (contextual_irrelevance (code1 cs) p ms ms').

(* Why3 assumption *)
Definition wp_correctness {a:Type} {a_WT:WhyType a} (code2:(wp a)): Prop :=
  forall (x:a) (p:Z) (post2:(machine_state -> bool)) (ms:machine_state),
  ((((((wp1 code2) x) p) post2) ms) = true) -> exists ms':machine_state,
  ((post2 ms') = true) /\ (contextual_irrelevance (wcode code2) p ms ms').

(* Why3 assumption *)
Definition seq_wp {a:Type} {a_WT:WhyType a} (l1:Z) (w1:(a -> (Z ->
  ((machine_state -> bool) -> (machine_state -> bool))))) (w2:((a*
  machine_state)%type -> (Z -> ((machine_state -> bool) -> (machine_state ->
  bool))))): (a -> (Z -> ((machine_state -> bool) -> (machine_state ->
  bool)))) := fun (x:a) (p:Z) (q:(machine_state -> bool))
  (ms:machine_state) => ((((w1 x) p) (((w2 (x, ms)) (p + l1)%Z) q)) ms).

Axiom seq_wp_lemma : forall {a:Type} {a_WT:WhyType a}, forall (l1:Z)
  (w1:(a -> (Z -> ((machine_state -> bool) -> (machine_state -> bool)))))
  (w2:((a* machine_state)%type -> (Z -> ((machine_state -> bool) ->
  (machine_state -> bool))))) (x:a) (p:Z) (q:(machine_state -> bool))
  (ms:machine_state), ((((((seq_wp l1 w1 w2) x) p) q) ms) = ((((w1 x) p)
  (((w2 (x, ms)) (p + l1)%Z) q)) ms)).

Parameter fork_wp: forall {a:Type} {a_WT:WhyType a}, (a -> (Z ->
  ((machine_state -> bool) -> (machine_state -> bool)))) -> (a -> (Z ->
  (machine_state -> bool))) -> (a -> (Z -> ((machine_state -> bool) ->
  (machine_state -> bool)))).

Axiom fork_wp_def : forall {a:Type} {a_WT:WhyType a}, forall (w:(a -> (Z ->
  ((machine_state -> bool) -> (machine_state -> bool))))) (cond:(a -> (Z ->
  (machine_state -> bool)))) (x:a) (p:Z) (q:(machine_state -> bool))
  (ms:machine_state), ((((((fork_wp w cond) x) p) q) ms) = true) <->
  (((~ ((((cond x) p) ms) = true)) -> ((q ms) = true)) /\ (((((cond x) p)
  ms) = true) -> (((((w x) p) q) ms) = true))).

Axiom fork_wp_lemma : forall {a:Type} {a_WT:WhyType a}, forall (w:(a -> (Z ->
  ((machine_state -> bool) -> (machine_state -> bool))))) (cond:(a -> (Z ->
  (machine_state -> bool)))) (x:a) (p:Z) (q:(machine_state -> bool))
  (ms:machine_state), ((((((fork_wp w cond) x) p) q) ms) = true) <->
  (((~ ((((cond x) p) ms) = true)) -> ((q ms) = true)) /\ (((((cond x) p)
  ms) = true) -> (((((w x) p) q) ms) = true))).

Parameter towp_wp: forall {a:Type} {a_WT:WhyType a}, (a -> (Z ->
  (machine_state -> bool))) -> (a -> (Z -> (machine_state ->
  (machine_state -> bool)))) -> (a -> (Z -> ((machine_state -> bool) ->
  (machine_state -> bool)))).

Axiom towp_wp_def : forall {a:Type} {a_WT:WhyType a}, forall (pr:(a -> (Z ->
  (machine_state -> bool)))) (ps:(a -> (Z -> (machine_state ->
  (machine_state -> bool))))) (x:a) (p:Z) (q:(machine_state -> bool))
  (ms:machine_state), ((((((towp_wp pr ps) x) p) q) ms) = true) <-> (((((pr
  x) p) ms) = true) /\ forall (ms':machine_state), (((((ps x) p) ms)
  ms') = true) -> ((q ms') = true)).

Axiom towp_wp_lemma : forall {a:Type} {a_WT:WhyType a}, forall (pr:(a ->
  (Z -> (machine_state -> bool)))) (ps:(a -> (Z -> (machine_state ->
  (machine_state -> bool))))) (x:a) (p:Z) (q:(machine_state -> bool))
  (ms:machine_state), ((((((towp_wp pr ps) x) p) q) ms) = true) <-> (((((pr
  x) p) ms) = true) /\ forall (ms':machine_state), (((((ps x) p) ms)
  ms') = true) -> ((q ms') = true)).

Parameter trivial_pre: forall {a:Type} {a_WT:WhyType a}, (a -> (Z ->
  (machine_state -> bool))).

Axiom trivial_pre_def : forall {a:Type} {a_WT:WhyType a}, forall (us:a) (p:Z)
  (ms:machine_state), (((((trivial_pre : (a -> (Z -> (machine_state ->
  bool)))) us) p) ms) = true) <-> match ms with
  | (VMS p' _ _) => (p = p')
  end.

(* Why3 assumption *)
Inductive acc {a:Type} {a_WT:WhyType a}: (a -> (a -> bool)) -> a -> Prop :=
  | Acc : forall (r:(a -> (a -> bool))) (x:a), (forall (y:a), (((r y)
      x) = true) -> (acc r y)) -> (acc r x).

Parameter loop_progress: forall {a:Type} {a_WT:WhyType a}, (a -> (Z ->
  (machine_state -> bool))) -> (a -> (Z -> (machine_state -> bool))) -> (a ->
  (Z -> (machine_state -> (machine_state -> bool)))) -> (a -> (Z ->
  (machine_state -> (machine_state -> bool)))).

Axiom loop_progress_def : forall {a:Type} {a_WT:WhyType a}, forall (inv:(a ->
  (Z -> (machine_state -> bool)))) (post2:(a -> (Z -> (machine_state ->
  bool)))) (var:(a -> (Z -> (machine_state -> (machine_state -> bool)))))
  (x:a) (p:Z) (ms:machine_state) (ms':machine_state), ((((((loop_progress inv
  post2 var) x) p) ms) ms') = true) <-> ((((((inv x) p) ms') = true) /\
  (((((var x) p) ms') ms) = true)) \/ ((((post2 x) p) ms') = true)).

(* Why3 assumption *)
Definition forget_old {a:Type} {a_WT:WhyType a} (post2:(a -> (Z ->
  (machine_state -> bool)))): (a -> (Z -> (machine_state -> (machine_state ->
  bool)))) := fun (x:a) (p:Z) (us:machine_state) => ((post2 x) p).

Parameter ifun_post: forall {a:Type} {a_WT:WhyType a}, (machine_state ->
  machine_state) -> (a -> (Z -> (machine_state -> (machine_state -> bool)))).

Axiom ifun_post_def : forall {a:Type} {a_WT:WhyType a},
  forall (f:(machine_state -> machine_state)) (us:a) (us1:Z)
  (ms:machine_state) (ms':machine_state), ((((((ifun_post f: (a -> (Z ->
  (machine_state -> (machine_state -> bool))))) us) us1) ms) ms') = true) <->
  (ms' = (f ms)).

Parameter iconst_post: forall {a:Type} {a_WT:WhyType a}, Z -> (a -> (Z ->
  (machine_state -> (machine_state -> bool)))).

Axiom iconst_post_def : forall {a:Type} {a_WT:WhyType a}, forall (n:Z) (us:a)
  (p:Z) (ms:machine_state) (ms':machine_state), ((((((iconst_post n: (a ->
  (Z -> (machine_state -> (machine_state -> bool))))) us) p) ms)
  ms') = true) <-> forall (s:(list Z)) (m:(map id Z)), (ms = (VMS p s m)) ->
  (ms' = (VMS (p + 1%Z)%Z (Init.Datatypes.cons n s) m)).

(* Why3 assumption *)
Definition iconst_fun (n:Z): (machine_state -> machine_state) :=
  fun (ms:machine_state) =>
  match ms with
  | (VMS p s m) => (VMS (p + 1%Z)%Z (Init.Datatypes.cons n s) m)
  end.

Parameter ivar_post: forall {a:Type} {a_WT:WhyType a}, id -> (a -> (Z ->
  (machine_state -> (machine_state -> bool)))).

Axiom ivar_post_def : forall {a:Type} {a_WT:WhyType a}, forall (x:id) (us:a)
  (p:Z) (ms:machine_state) (ms':machine_state), ((((((ivar_post x: (a ->
  (Z -> (machine_state -> (machine_state -> bool))))) us) p) ms)
  ms') = true) <-> forall (s:(list Z)) (m:(map id Z)), (ms = (VMS p s m)) ->
  (ms' = (VMS (p + 1%Z)%Z (Init.Datatypes.cons (get m x) s) m)).

(* Why3 assumption *)
Definition ivar_fun (x:id): (machine_state -> machine_state) :=
  fun (ms:machine_state) =>
  match ms with
  | (VMS p s m) => (VMS (p + 1%Z)%Z (Init.Datatypes.cons (get m x) s) m)
  end.

(* Why3 assumption *)
Definition binop := (Z -> (Z -> Z)).

Parameter ibinop_pre: forall {a:Type} {a_WT:WhyType a}, (a -> (Z ->
  (machine_state -> bool))).

Axiom ibinop_pre_def : forall {a:Type} {a_WT:WhyType a}, forall (us:a) (p:Z)
  (ms:machine_state), (((((ibinop_pre : (a -> (Z -> (machine_state ->
  bool)))) us) p) ms) = true) <-> exists n1:Z, exists n2:Z,
  exists s:(list Z), exists m:(map id Z), (ms = (VMS p
  (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m)).

Parameter ibinop_post: forall {a:Type} {a_WT:WhyType a}, (Z -> (Z -> Z)) ->
  (a -> (Z -> (machine_state -> (machine_state -> bool)))).

Axiom ibinop_post_def : forall {a:Type} {a_WT:WhyType a}, forall (op:(Z ->
  (Z -> Z))) (us:a) (p:Z) (ms:machine_state) (ms':machine_state),
  ((((((ibinop_post op: (a -> (Z -> (machine_state -> (machine_state ->
  bool))))) us) p) ms) ms') = true) <-> forall (n1:Z) (n2:Z) (s:(list Z))
  (m:(map id Z)), (ms = (VMS p
  (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m)) ->
  (ms' = (VMS (p + 1%Z)%Z (Init.Datatypes.cons ((op n1) n2) s) m)).

(* Why3 assumption *)
Definition ibinop_fun (op:(Z -> (Z -> Z))): (machine_state ->
  machine_state) := fun (ms:machine_state) =>
  match ms with
  | (VMS p (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m) =>
      (VMS (p + 1%Z)%Z (Init.Datatypes.cons ((op n1) n2) s) m)
  | _ => ms
  end.

(* Why3 assumption *)
Definition plus: (Z -> (Z -> Z)) := fun (x:Z) (y:Z) => (x + y)%Z.

(* Why3 assumption *)
Definition sub: (Z -> (Z -> Z)) := fun (x:Z) (y:Z) => (x - y)%Z.

(* Why3 assumption *)
Definition mul: (Z -> (Z -> Z)) := fun (x:Z) (y:Z) => (x * y)%Z.

Parameter inil_post: forall {a:Type} {a_WT:WhyType a}, (a -> (Z ->
  (machine_state -> (machine_state -> bool)))).

Axiom inil_post_def : forall {a:Type} {a_WT:WhyType a}, forall (us:a) (us1:Z)
  (ms:machine_state) (ms':machine_state), ((((((inil_post : (a -> (Z ->
  (machine_state -> (machine_state -> bool))))) us) us1) ms) ms') = true) <->
  (ms = ms').

Parameter ibranch_post: forall {a:Type} {a_WT:WhyType a}, Z -> (a -> (Z ->
  (machine_state -> (machine_state -> bool)))).

Axiom ibranch_post_def : forall {a:Type} {a_WT:WhyType a}, forall (ofs1:Z)
  (us:a) (p:Z) (ms:machine_state) (ms':machine_state),
  ((((((ibranch_post ofs1: (a -> (Z -> (machine_state -> (machine_state ->
  bool))))) us) p) ms) ms') = true) <-> forall (s:(list Z)) (m:(map id Z)),
  (ms = (VMS p s m)) -> (ms' = (VMS ((p + 1%Z)%Z + ofs1)%Z s m)).

(* Why3 assumption *)
Definition ibranch_fun (ofs1:Z): (machine_state -> machine_state) :=
  fun (ms:machine_state) =>
  match ms with
  | (VMS p s m) => (VMS ((p + 1%Z)%Z + ofs1)%Z s m)
  end.

(* Why3 assumption *)
Definition cond := (Z -> (Z -> bool)).

Parameter icjump_post: forall {a:Type} {a_WT:WhyType a}, (Z -> (Z ->
  bool)) -> Z -> (a -> (Z -> (machine_state -> (machine_state -> bool)))).

Axiom icjump_post_def : forall {a:Type} {a_WT:WhyType a}, forall (cond1:(Z ->
  (Z -> bool))) (ofs1:Z) (us:a) (p:Z) (ms:machine_state) (ms':machine_state),
  ((((((icjump_post cond1 ofs1: (a -> (Z -> (machine_state ->
  (machine_state -> bool))))) us) p) ms) ms') = true) <-> forall (n1:Z)
  (n2:Z) (s:(list Z)) (m:(map id Z)), (ms = (VMS p
  (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m)) -> (((((cond1 n1)
  n2) = true) -> (ms' = (VMS ((p + ofs1)%Z + 1%Z)%Z s m))) /\ ((~ (((cond1
  n1) n2) = true)) -> (ms' = (VMS (p + 1%Z)%Z s m)))).

Parameter icjump_fun: (Z -> (Z -> bool)) -> Z -> (machine_state ->
  machine_state).

Axiom icjump_fun_def : forall (cond1:(Z -> (Z -> bool))) (ofs1:Z)
  (ms:machine_state),
  match ms with
  | (VMS p (Init.Datatypes.cons n2 (Init.Datatypes.cons n1 s)) m) =>
      ((((cond1 n1) n2) = true) -> (((icjump_fun cond1 ofs1)
      ms) = (VMS ((p + ofs1)%Z + 1%Z)%Z s m))) /\ ((~ (((cond1 n1)
      n2) = true)) -> (((icjump_fun cond1 ofs1) ms) = (VMS (p + 1%Z)%Z s m)))
  | _ => (((icjump_fun cond1 ofs1) ms) = ms)
  end.

Parameter beq: (Z -> (Z -> bool)).

Axiom beq_def : forall (x:Z) (y:Z), (((beq x) y) = true) <-> (x = y).

Parameter bne: (Z -> (Z -> bool)).

Axiom bne_def : forall (x:Z) (y:Z), (((bne x) y) = true) <-> ~ (x = y).

Parameter ble: (Z -> (Z -> bool)).

Axiom ble_def : forall (x:Z) (y:Z), (((ble x) y) = true) <-> (x <= y)%Z.

Parameter bgt: (Z -> (Z -> bool)).

Axiom bgt_def : forall (x:Z) (y:Z), (((bgt x) y) = true) <-> (y < x)%Z.

Parameter isetvar_pre: forall {a:Type} {a_WT:WhyType a}, (a -> (Z ->
  (machine_state -> bool))).

Axiom isetvar_pre_def : forall {a:Type} {a_WT:WhyType a}, forall (us:a) (p:Z)
  (ms:machine_state), (((((isetvar_pre : (a -> (Z -> (machine_state ->
  bool)))) us) p) ms) = true) <-> exists n:Z, exists s:(list Z),
  exists m:(map id Z), (ms = (VMS p (Init.Datatypes.cons n s) m)).

Parameter isetvar_post: forall {a:Type} {a_WT:WhyType a}, id -> (a -> (Z ->
  (machine_state -> (machine_state -> bool)))).

Axiom isetvar_post_def : forall {a:Type} {a_WT:WhyType a}, forall (x:id)
  (us:a) (p:Z) (ms:machine_state) (ms':machine_state),
  ((((((isetvar_post x: (a -> (Z -> (machine_state -> (machine_state ->
  bool))))) us) p) ms) ms') = true) <-> forall (s:(list Z)) (n:Z) (m:(map id
  Z)), (ms = (VMS p (Init.Datatypes.cons n s) m)) -> (ms' = (VMS (p + 1%Z)%Z
  s (set m x n))).

(* Why3 assumption *)
Definition isetvar_fun (x:id): (machine_state -> machine_state) :=
  fun (ms:machine_state) =>
  match ms with
  | (VMS p (Init.Datatypes.cons n s) m) => (VMS (p + 1%Z)%Z s (set m x n))
  | _ => ms
  end.

Parameter aexpr_post: forall {a:Type} {a_WT:WhyType a}, aexpr -> Z -> (a ->
  (Z -> (machine_state -> (machine_state -> bool)))).

Axiom aexpr_post_def : forall {a:Type} {a_WT:WhyType a}, forall (a1:aexpr)
  (len:Z) (us:a) (p:Z) (ms:machine_state) (ms':machine_state),
  ((((((aexpr_post a1 len: (a -> (Z -> (machine_state -> (machine_state ->
  bool))))) us) p) ms) ms') = true) <->
  match ms with
  | (VMS _ s m) => (ms' = (VMS (p + len)%Z (Init.Datatypes.cons (aeval m
      a1) s) m))
  end.

Parameter bexpr_post: forall {a:Type} {a_WT:WhyType a}, bexpr -> bool -> Z ->
  Z -> (a -> (Z -> (machine_state -> (machine_state -> bool)))).

Axiom bexpr_post_def : forall {a:Type} {a_WT:WhyType a}, forall (b:bexpr)
  (cond1:bool) (out_t:Z) (out_f:Z) (us:a) (p:Z) (ms:machine_state)
  (ms':machine_state), (((((((bexpr_post b cond1 out_t out_f: (a -> (Z ->
  (machine_state -> (machine_state -> bool))))) us) p) ms) ms') = true) ->
  match ms with
  | (VMS _ s m) => (((beval m b) = cond1) -> (ms' = (VMS (p + out_t)%Z s
      m))) /\ ((~ ((beval m b) = cond1)) -> (ms' = (VMS (p + out_f)%Z s m)))
  end) /\
  (match ms with
  | (VMS _ s m) => (((beval m b) = cond1) /\ (ms' = (VMS (p + out_t)%Z s
      m))) \/ ((~ ((beval m b) = cond1)) /\ (ms' = (VMS (p + out_f)%Z s m)))
  end -> ((((((bexpr_post b cond1 out_t out_f: (a -> (Z -> (machine_state ->
  (machine_state -> bool))))) us) p) ms) ms') = true)).

Parameter exec_cond: forall {a:Type} {a_WT:WhyType a}, bexpr -> bool -> (a ->
  (Z -> (machine_state -> bool))).

Axiom exec_cond_def : forall {a:Type} {a_WT:WhyType a}, forall (b1:bexpr)
  (cond1:bool) (us:a) (us1:Z) (ms:machine_state), (((((exec_cond b1
  cond1: (a -> (Z -> (machine_state -> bool)))) us) us1) ms) = true) <->
  match ms with
  | (VMS _ _ m) => ((beval m b1) = cond1)
  end.

Parameter com_pre: forall {a:Type} {a_WT:WhyType a}, com -> (a -> (Z ->
  (machine_state -> bool))).

Axiom com_pre_def : forall {a:Type} {a_WT:WhyType a}, forall (cmd:com) (us:a)
  (p:Z) (ms:machine_state), (((((com_pre cmd: (a -> (Z -> (machine_state ->
  bool)))) us) p) ms) = true) <->
  match ms with
  | (VMS p' _ m) => (p = p') /\ exists m':(map id Z), (ceval m cmd m')
  end.

Parameter com_post: forall {a:Type} {a_WT:WhyType a}, com -> Z -> (a -> (Z ->
  (machine_state -> (machine_state -> bool)))).

Axiom com_post_def : forall {a:Type} {a_WT:WhyType a}, forall (cmd:com)
  (len:Z) (us:a) (us1:Z) (ms:machine_state) (ms':machine_state),
  ((((((com_post cmd len: (a -> (Z -> (machine_state -> (machine_state ->
  bool))))) us) us1) ms) ms') = true) <->
  match ms with
  | (VMS p s m) =>
      match ms' with
      | (VMS p' s' m') => (p' = (p + len)%Z) /\ ((s' = s) /\ (ceval m cmd
          m'))
      end
  end.

Parameter exec_cond_old: forall {a:Type} {a_WT:WhyType a}, bexpr -> bool ->
  ((a* machine_state)%type -> (Z -> (machine_state -> bool))).

Axiom exec_cond_old_def : forall {a:Type} {a_WT:WhyType a}, forall (b1:bexpr)
  (cond1:bool) (x:(a* machine_state)%type) (us:Z) (us1:machine_state),
  (((((exec_cond_old b1 cond1: ((a* machine_state)%type -> (Z ->
  (machine_state -> bool)))) x) us) us1) = true) <->
  match (snd x) with
  | (VMS _ _ m) => ((beval m b1) = cond1)
  end.

Parameter loop_invariant: forall {a:Type} {a_WT:WhyType a}, com -> ((a*
  machine_state)%type -> (Z -> (machine_state -> bool))).

Axiom loop_invariant_def : forall {a:Type} {a_WT:WhyType a}, forall (c:com)
  (x:(a* machine_state)%type) (p:Z) (msi:machine_state),
  (((((loop_invariant c: ((a* machine_state)%type -> (Z -> (machine_state ->
  bool)))) x) p) msi) = true) <->
  match (snd x) with
  | (VMS _ s0 m0) =>
      match msi with
      | (VMS pi si mi) => (pi = p) /\ ((s0 = si) /\ exists mf:(map id Z),
          (ceval m0 c mf) /\ (ceval mi c mf))
      end
  end.

Parameter loop_post: forall {a:Type} {a_WT:WhyType a}, com -> Z -> ((a*
  machine_state)%type -> (Z -> (machine_state -> bool))).

Axiom loop_post_def : forall {a:Type} {a_WT:WhyType a}, forall (c:com)
  (len:Z) (x:(a* machine_state)%type) (p:Z) (msf:machine_state),
  (((((loop_post c len: ((a* machine_state)%type -> (Z -> (machine_state ->
  bool)))) x) p) msf) = true) <->
  match (snd x) with
  | (VMS _ s0 m0) =>
      match msf with
      | (VMS pf sf mf) => (pf = (p + len)%Z) /\ ((s0 = sf) /\ (ceval m0 c
          mf))
      end
  end.

Parameter loop_variant: forall {a:Type} {a_WT:WhyType a}, com -> bexpr ->
  (a -> (Z -> (machine_state -> (machine_state -> bool)))).

Axiom loop_variant_def : forall {a:Type} {a_WT:WhyType a}, forall (c:com)
  (test:bexpr) (us:a) (us1:Z) (msj:machine_state) (msi:machine_state),
  ((((((loop_variant c test: (a -> (Z -> (machine_state -> (machine_state ->
  bool))))) us) us1) msj) msi) = true) <->
  match msj with
  | (VMS pj sj mj) =>
      match msi with
      | (VMS pi si mi) => (pj = pi) /\ ((sj = si) /\ ((ceval mi c mj) /\
          ((beval mi test) = true)))
      end
  end.

Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.99.1," timelimit 5; admit.
Ltac cvc := why3 "CVC4,1.4," timelimit 5; admit.

(* Why3 goal *)
Theorem WP_parameter_compile_com : forall {a:Type} {a_WT:WhyType a},
  forall (cmd:com), forall (x:bexpr) (x1:com), (cmd = (Cwhile x x1)) ->
  forall (code_body:(list instr)) (code_body1:(((a* machine_state)%type*
  machine_state)%type -> (Z -> (machine_state -> bool)))) (code_body2:(((a*
  machine_state)%type* machine_state)%type -> (Z -> (machine_state ->
  (machine_state -> bool))))), let code_body3 := (mk_hl code_body code_body1
  code_body2) in ((((code_body1 = (com_pre x1: (((a* machine_state)%type*
  machine_state)%type -> (Z -> (machine_state -> bool))))) /\ (hl_correctness
  code_body3)) /\ (code_body2 = (com_post x1
  (list.Length.length code_body): (((a* machine_state)%type*
  machine_state)%type -> (Z -> (machine_state -> (machine_state ->
  bool))))))) -> let body_length :=
  ((list.Length.length code_body) + 1%Z)%Z in forall (code_test:(list instr))
  (code_test1:((a* machine_state)%type -> (Z -> (machine_state -> bool))))
  (code_test2:((a* machine_state)%type -> (Z -> (machine_state ->
  (machine_state -> bool))))), let code_test3 := (mk_hl code_test code_test1
  code_test2) in ((((code_test1 = (trivial_pre : ((a* machine_state)%type ->
  (Z -> (machine_state -> bool))))) /\ (hl_correctness code_test3)) /\
  (code_test2 = (bexpr_post x false
  ((list.Length.length code_test) + body_length)%Z
  (list.Length.length code_test): ((a* machine_state)%type -> (Z ->
  (machine_state -> (machine_state -> bool))))))) -> let ofs1 :=
  ((list.Length.length code_test) + body_length)%Z in forall (o:(list instr))
  (o1:((((a* machine_state)%type* machine_state)%type* machine_state)%type ->
  (Z -> (machine_state -> bool)))) (o2:((((a* machine_state)%type*
  machine_state)%type* machine_state)%type -> (Z -> (machine_state ->
  (machine_state -> bool))))), let o3 := (mk_hl o o1 o2) in
  ((((o1 = (trivial_pre : ((((a* machine_state)%type* machine_state)%type*
  machine_state)%type -> (Z -> (machine_state -> bool))))) /\
  (o2 = (ibranch_post (-ofs1)%Z: ((((a* machine_state)%type*
  machine_state)%type* machine_state)%type -> (Z -> (machine_state ->
  (machine_state -> bool))))))) /\ (((list.Length.length o) = 1%Z) /\
  (hl_correctness o3))) -> ((hl_correctness o3) -> forall (o4:(list instr))
  (o5:((((a* machine_state)%type* machine_state)%type* machine_state)%type ->
  (Z -> ((machine_state -> bool) -> (machine_state -> bool))))), let o6 :=
  (mk_wp o4 o5) in ((((list.Length.length o4) = (list.Length.length o)) /\
  ((o5 = (towp_wp o1 o2)) /\ (wp_correctness o6))) -> ((hl_correctness
  code_body3) -> forall (o7:(list instr)) (o8:(((a* machine_state)%type*
  machine_state)%type -> (Z -> ((machine_state -> bool) -> (machine_state ->
  bool))))), let o9 := (mk_wp o7 o8) in
  ((((list.Length.length o7) = (list.Length.length code_body)) /\
  ((o8 = (towp_wp code_body1 code_body2)) /\ (wp_correctness o9))) ->
  (((wp_correctness o9) /\ (wp_correctness o6)) -> forall (o10:(list instr))
  (o11:(((a* machine_state)%type* machine_state)%type -> (Z ->
  ((machine_state -> bool) -> (machine_state -> bool))))), let o12 :=
  (mk_wp o10 o11) in
  ((((list.Length.length o10) = ((list.Length.length o7) + (list.Length.length o4))%Z) /\
  ((o11 = (seq_wp (list.Length.length o7) o8 o5)) /\ (wp_correctness
  o12))) -> ((wp_correctness o12) -> forall (o13:(list instr)) (o14:(((a*
  machine_state)%type* machine_state)%type -> (Z -> ((machine_state ->
  bool) -> (machine_state -> bool))))), let o15 := (mk_wp o13 o14) in
  (((o14 = (fork_wp o11 (exec_cond x true: (((a* machine_state)%type*
  machine_state)%type -> (Z -> (machine_state -> bool)))))) /\
  (((list.Length.length o13) = (list.Length.length o10)) /\ (wp_correctness
  o15))) -> ((hl_correctness code_test3) -> forall (o16:(list instr))
  (o17:((a* machine_state)%type -> (Z -> ((machine_state -> bool) ->
  (machine_state -> bool))))), let o18 := (mk_wp o16 o17) in
  ((((list.Length.length o16) = (list.Length.length code_test)) /\
  ((o17 = (towp_wp code_test1 code_test2)) /\ (wp_correctness o18))) ->
  (((wp_correctness o18) /\ (wp_correctness o15)) ->
  forall (wp_while:(list instr)) (wp_while1:((a* machine_state)%type -> (Z ->
  ((machine_state -> bool) -> (machine_state -> bool))))), let wp_while2 :=
  (mk_wp wp_while wp_while1) in
  ((((list.Length.length wp_while) = ((list.Length.length o16) + (list.Length.length o13))%Z) /\
  ((wp_while1 = (seq_wp (list.Length.length o16) o17 o14)) /\ (wp_correctness
  wp_while2))) -> let inv := (loop_invariant cmd: ((a* machine_state)%type ->
  (Z -> (machine_state -> bool)))) in let var := (loop_variant x1 x: ((a*
  machine_state)%type -> (Z -> (machine_state -> (machine_state ->
  bool))))) in let o19 := (loop_progress inv (loop_post cmd ofs1: ((a*
  machine_state)%type -> (Z -> (machine_state -> bool)))) var) in
  (((wp_correctness wp_while2) /\ forall (x2:(a* machine_state)%type) (p:Z)
  (ms:machine_state), ((((inv x2) p) ms) = true) -> (((((wp_while1 x2) p)
  (((o19 x2) p) ms)) ms) = true)) -> forall (hl_while:(list instr))
  (hl_while1:((a* machine_state)%type -> (Z -> (machine_state -> bool))))
  (hl_while2:((a* machine_state)%type -> (Z -> (machine_state ->
  (machine_state -> bool))))), (((hl_while1 = inv) /\ (hl_while2 = o19)) /\
  (((list.Length.length hl_while) = (list.Length.length wp_while)) /\
  (hl_correctness (mk_hl hl_while hl_while1 hl_while2)))) -> forall (x2:(a*
  machine_state)%type) (p:Z) (ms:machine_state), ((((inv x2) p)
  ms) = true) -> (acc ((var x2) p) ms))))))))))))))))).
(* Why3 intros a a_WT cmd x x1 h1 code_body code_body1 code_body2 code_body3
        ((h2,h3),h4) body_length code_test code_test1 code_test2 code_test3
        ((h5,h6),h7) ofs1 o o1 o2 o3 ((h8,h9),(h10,h11)) h12 o4 o5 o6
        (h13,(h14,h15)) h16 o7 o8 o9 (h17,(h18,h19)) (h20,h21) o10 o11 o12
        (h22,(h23,h24)) h25 o13 o14 o15 (h26,(h27,h28)) h29 o16 o17 o18
        (h30,(h31,h32)) (h33,h34) wp_while wp_while1 wp_while2
        (h35,(h36,h37)) inv var o19 (h38,h39) hl_while hl_while1 hl_while2
        ((h40,h41),(h42,h43)) x2 p ms h44. *)
intros a a_WT cmd x x1 h1 code_body code_body1 code_body2 code_body3
((h2,h3),h4) body_length code_test code_test1 code_test2 code_test3
((h5,h6),h7) ofs o o1 o2 o3 ((h8,h9),(h10,h11)) h12 o4 o5 o6 (h13,(h14,h15))
h16 o7 o8 o9 (h17,(h18,h19)) (h20,h21) o10 o11 o12 (h22,(h23,h24)) h25 o13
o14 o15 (h26,(h27,h28)) h29 o16 o17 o18 (h30,(h31,h32)) (h33,h34) wp_while
wp_while1 wp_while2 (h35,(h36,h37)) inv var o19 (h38,h39) hl_while hl_while1
hl_while2 ((h40,h41),(h42,h43)) x2 p ms h44.
apply loop_invariant_def in h44.
destruct x2.
destruct m.
destruct ms.
simpl in *.
destruct h44.
destruct H0.
destruct H1 as [mf [ P T]].
induction T; try discriminate.
apply Acc.
intros.
apply loop_variant_def in H2.
exfalso. cvc.
apply Acc.
intros.
replace y with (VMS z0 l0 mj).
apply IHT2; trivial.
apply loop_variant_def in H2.
destruct y.
assert (body = x1) by ae.
assert (m0 = mj).
eapply ceval_deterministic.
2: exact T1.
ae. ae.
Admitted.


From Coq Require Import
     Relation_Definitions RelationClasses Morphisms Utf8.

From Mon Require Import
     FiniteProbabilities
     SPropMonadicStructures
     SpecificationMonads
     MonadExamples
     SPropBase.

From Relational Require Import
     OrderEnrichedCategory
     OrderEnrichedRelativeMonadExamples
     Commutativity
     GenericRulesSimple.

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import
     all_ssreflect
     all_algebra
     reals
     distr
     realsum.
Set Warnings "notation-overridden,ambiguous-paths".

From Crypt Require Import
     Axioms
     ChoiceAsOrd
     SubDistr
     Couplings
     Theta_dens
     Theta_exCP
     LaxComp
     FreeProbProg.

Import SPropNotations.
Import Num.Theory.
Import Order.POrderTheory.

(* Notation "⟦ b ⟧" := (is_true_sprop b). *)
(* Infix "-s>" := (s_impl) (right associativity, at level 86, only parsing). *)

Local Open Scope ring_scope.

Lemma card_non_zero {F : finType} {w0 : F} : #|F|%:~R != 0 :> R.
Proof.
  eapply fintype0 in w0 as h.
  apply /negP. intro n. eapply h.
  rewrite intr_eq0 in n. move: n => /eqP n.
  inversion n. reflexivity.
Qed.

Definition r { F : finType} { w0 : F } : R := (1%:~R) / ((#|F|)%:~R).

Lemma r_nonneg { F : finType} { w0 : F } : 0 <= (@r F w0).
Proof.
  rewrite /r.
  apply: divr_ge0; by apply: ler0n.
Qed.

(* Rem.: TODO: generalize this *)
Lemma sum_const_seq_finType { T : finType } ( J : seq T) (k : R) (Huniq : uniq J) :
  \sum_(j <- J) k = \sum_(j in (seq_sub_finType J)) k.
Proof.
  rewrite /seq_sub_finType. simpl.
  rewrite big_const.
  rewrite big_const_seq.
  rewrite card_seq_sub.
  - simpl.
    rewrite count_predT.
    reflexivity.
  - apply Huniq.
Qed.

Lemma cardinality_bound {T : finType} (J : seq T) (Huniq: uniq J) (k : R) (k_geq0 : 0 <= k) :
  \sum_(j <- J) k <= (#|T|%:~R) * k.
Proof.
  rewrite GRing.mulrC.
  rewrite sum_const_seq_finType.
  2: { exact Huniq. }
  rewrite GRing.sumr_const pmulrn /=.
  have hfoo' :  k *~ #|seq_sub_finType (T:=T) J| =  k * #|seq_sub_finType (T:=T) J|%:~R.
  { by rewrite mulrzr. }
  rewrite hfoo' /=.
  apply: ler_pmul; auto.
  - rewrite ler0z. rewrite lez_nat. reflexivity.
  - rewrite card_seq_sub. 2: eauto.
    rewrite cardT.
    rewrite ler_int. rewrite lez_nat.
    rewrite uniq_leq_size. 1,2: auto.
    intros x hx.
    rewrite mem_enum. reflexivity.
Qed.

Lemma gen_cardinality_bound :
  ∀ {T : finType}
    (J : seq T) (Huniq: uniq J)
    (π : T → R)
    (π_geq0 : ∀ t, 0 <= (π t)),
    \sum_(j <- J) (π j) <= \sum_(j <- enum T) (π j).
Proof.
  (* Basically a rip-off of xfinmap.big_fset_subset *)
  intros T J hu π hπ.
  rewrite [X in _<=X](bigID [pred j : T | j \in J]) /=.
  rewrite ler_paddr ?sumr_ge0 // -[X in _<=X]big_filter.
  rewrite Order.POrderTheory.le_eqVlt; apply/orP; left; apply/eqP/perm_big.
  apply/uniq_perm; rewrite ?filter_uniq //; last move=> i.
  rewrite -enum_setT. apply enum_uniq.
  rewrite mem_filter; case/boolP: (_ \in _) => //=.
  intro. rewrite mem_enum. reflexivity.
Qed.

Lemma is_uniform {F : finType} (w0 : F) : isdistr (fun w : F => (@r F w0)).
Proof.
  split.
  - move => w; apply: r_nonneg.
  - move => J uniq_J. apply /idP.
    apply: le_trans.
    -- by apply: (cardinality_bound J uniq_J r r_nonneg).
    -- rewrite /r -GRing.invf_div GRing.divr1 GRing.divff.
         by [].
         exact (@card_non_zero F w0).
Qed.

Definition f_dprod { F : finType} { w0 : F } (f : F -> F) : F * F -> R :=
  fun w =>
    if ((f (fst w)) == (snd w)) then (@r F w0) else 0.

Lemma sum_oneq_eq :
  ∀ {I : eqType} (r : seq I) (P : pred I) (F G : I → R),
    (∀ i : I, P i → F i = G i) →
    \sum_(i <- r | P i) F i = \sum_(i <- r | P i) G i.
Proof.
  intros I r P F G eFG.
  induction r as [| a r ihr].
  - rewrite !big_nil. reflexivity.
  - rewrite !big_cons.
    case: ifP=> pa /=.
    + rewrite eFG. 2: auto.
      rewrite ihr. reflexivity.
    + apply ihr.
Qed.

Lemma sum_pred_eq :
  ∀ {I : eqType} (r : seq I) (P Q : pred I) (F : I → R),
    (∀ i : I, P i = Q i) →
    \sum_(i <- r | P i) F i = \sum_(i <- r | Q i) F i.
Proof.
  intros I r P Q F ePQ.
  induction r as [| a r ihr].
  - rewrite !big_nil. reflexivity.
  - rewrite !big_cons.
    case: ifP=> pa /=.
    + rewrite ePQ in pa. rewrite pa.
      rewrite ihr. reflexivity.
    + rewrite ePQ in pa. rewrite pa. apply ihr.
Qed.

(* TODO RENAME *)
Lemma sum_prod_bij
  {T : finType} {f : T -> T}
  (π : (prod_finType T T) -> R)
  (π_geq0 : forall t, 0 <= π t) :
  \sum_(jj <- enum (prod_finType T T)) (if f jj.1 == jj.2 then π jj else 0) =
  \sum_(j <- enum T) (π (j, f j)).
Proof.
  rewrite [X in X=_](bigID [pred jj : prod_finType T T | f jj.1 == jj.2]) /=.
  match goal with
  | |- _ + ?x = _ =>
    assert (e : x == 0)
  end.
  { rewrite psumr_eq0.
    - apply/allP. intros [i j] h. cbn.
      destruct (f i == j).
      + cbn. reflexivity.
      + cbn. apply/eqP. reflexivity.
    - intros [i j]. cbn. intros h.
      destruct (f i == j). 1: discriminate.
      auto.
  }
  move: e => /eqP e. rewrite e. clear e.
  rewrite GRing.Theory.addr0.
  erewrite sum_oneq_eq with (G := fun ij => π (ij.1, ij.2)).
  2:{
    intros [i j]. cbn. intro h. rewrite h. reflexivity.
  }
  rewrite !enumT.
  pose proof pair_big_dep as e.
  specialize e with (F := fun i j => π (i, j)).
  specialize e with (P := λ _, true).
  cbn in e.
  specialize e with (Q := λ i j, f i == j).
  cbn in e. rewrite -e. clear e.
  cbn.
  erewrite sum_oneq_eq with (G := λ i, π (i, f i)).
  2:{
    intros i _.
    erewrite <- big_pred1_eq with (F := λ j, π (i, j)).
    erewrite sum_pred_eq with (Q := λ j, j == f i).
    2:{
      intro j. destruct (f i == j) eqn:e.
      - move: e => /eqP e. subst. destruct (f i == f i) eqn:e.
        + reflexivity.
        + move: e => /eqP e. contradiction.
      - move: e => /eqP e. destruct (j == f i) eqn:e'.
        + move: e' => /eqP e'. subst. contradiction.
        + reflexivity.
    }
    reflexivity.
  }
  reflexivity.
Qed.

(*Rem.: adapting GRing.sumr_const *)
Lemma sumr_const (T : finType) (x : R): \sum_(i <- enum T) x = x * (#|T|%:~R).
Proof.
  rewrite sum_const_seq_finType.
  2: { apply enum_uniq. }
  rewrite GRing.sumr_const pmulrn /=.
  (* Rem.: need to show #|seq_sub (T:=T) (enum T)| = #|T| *)
  rewrite !enumT.
  unfold intmul.
  rewrite GRing.mulrC.
  rewrite GRing.Theory.mulr_natl.
  apply f_equal.
  rewrite card_seq_sub.
  + rewrite cardE.
    rewrite -enumT.
    reflexivity.
  + rewrite -enumT.
    apply enum_uniq.
Qed.

(* the uniform distribution over F *)
Definition uniform_F { F : finType} { w0 : F } : SDistr _ := mkdistr (@is_uniform F w0).

Lemma bijective_isdistr { F : finType} { w0 : F } {f : F -> F} (Hbij : bijective f) :
  isdistr (@f_dprod F w0 f).
Proof.
  rewrite /f_dprod. split.
  move => [w1 w2].
  - destruct (f (w1, w2).1 == (w1, w2).2) eqn: Heq; rewrite Heq.
    -- exact r_nonneg.
    -- trivial.
  - move => J uniq_J.
    apply: le_trans.
    apply: (gen_cardinality_bound J uniq_J _).
    -- move => [t1 t2] /=.
       destruct (f t1 == t2) eqn:Heq; auto. exact r_nonneg.
    -- rewrite sum_prod_bij.
       rewrite sumr_const /r -GRing.invf_div GRing.divr1 GRing.mulVf. auto.
       exact (@card_non_zero F w0).
       by move => w; exact r_nonneg.
Qed.

Definition sampleFsq_f { F : finType} { w0 : F } {f : F -> F} (f_bij : bijective f) : SDistr _ :=
  (mkdistr (@bijective_isdistr F w0 f f_bij)).

Lemma sampleFsq_f_coupling { F : finType} { w0 : F } { f : F -> F } (f_bij : bijective f):
  coupling (@sampleFsq_f F w0 f f_bij) (@uniform_F F w0) (@uniform_F F w0).
Proof.
  destruct f_bij as [f_inv K1 K2].
  rewrite /sampleFsq_f /f_dprod; split; apply: distr_ext => w /=.
  - rewrite /lmg dfstE /mkdistr psum_sum /=.
    rewrite (sum_seq1 (f w)).
    destruct (f w == f w) eqn: Hfw; auto.
    -- exfalso. by move/idP: Hfw.
    move => y Hy.
    destruct (f w == y) eqn: Hfw; auto.
    -- exfalso. move/eqP: Hy; auto.
    move => x.
    destruct (f w == x) eqn: Hfw; auto.
    exact r_nonneg.
  - rewrite /rmg dsndE /mkdistr psum_sum /=.
    rewrite (sum_seq1 (f_inv w)).
    have Heq: (f (f_inv w) == w) by apply /eqP; apply: (K2 w).
    by rewrite Heq.
    move => y Hy.
    destruct (f y == w) eqn: Hfy.
    -- apply /eqP.
       move/eqP: Hfy => Hfy.
       rewrite -Hfy.
       exact (K1 y).
    -- exfalso. move/eqP: Hy; auto.
       move => x.
       destruct (f x == w) eqn: Hfw; auto.
       exact r_nonneg.
Qed.

Lemma sampleFsq_support { F : finType} { w0 : F }
                        {a1 a2 : F} {f : F -> F}
                        (f_bij : bijective f)
                        (H : 0 < (@sampleFsq_f F w0 f f_bij) (a1, a2)) : f a1 == a2.
Proof.
  simpl in H. rewrite /f_dprod /= in H.
  case (f a1 == a2) eqn:Heq; auto.
    by rewrite ltxx in H.
Qed.

Lemma support_sub_diag_mgs { A : choiceType }
                           ( d : SDistr (prod_choiceType A A) )
                           (Hsupp : forall a1 a2, 0 < d (a1, a2) -> a1 = a2) :
  forall a : A, lmg d a = d (a, a) /\ rmg d a = d (a, a).
Proof.
  move => a.
  rewrite /lmg /rmg dfstE dsndE.
  split.
  - rewrite psum_sum.
    rewrite (sum_seq1 a).
    + reflexivity.
    + move => y Hdd. specialize (Hsupp a y).
      assert (0 < d (a, y)) as Hd.
      { rewrite lt_def. apply /andP.
        split.
        - assumption.
        - apply (ge0_mu d). }
      specialize (Hsupp Hd). rewrite Hsupp. auto.
    + move => x. apply (ge0_mu d).
  - rewrite psum_sum.
    rewrite (sum_seq1 a).
    + reflexivity.
    + move => y Hdd. specialize (Hsupp y a).
      assert (0 < d (y, a)) as Hd.
      { rewrite lt_def. apply /andP.
        split.
        - assumption.
        - apply (ge0_mu d).  }
      specialize (Hsupp Hd). rewrite Hsupp. auto.
    + move => x. apply (ge0_mu d).
Qed.

Section prod_uniform.
(* (mkdistrd (λ f : fin_family i * fin_family j, r)) *)

  Let SD_bind
      {A B : choiceType}
      (m : SDistr_carrier A)
      (k : A -> SDistr_carrier B) :=
    SDistr_bind A B k m.
  Let SD_ret {A : choiceType}
      (a : A) :=
    SDistr_unit A a.

  Context {X Y : finType}.
  Context {x0 : X} {y0 : Y}.

  Arguments r _ {_}.

  Lemma prod_uniform :
    @uniform_F (prod_finType X Y) (x0,y0) =
    SD_bind (@uniform_F X x0) (fun x =>
    SD_bind (@uniform_F Y y0) (fun y =>
    SD_ret (x,y))).
  Proof.
    apply distr_ext. move=> [x y].
    rewrite !/SD_bind !/SDistr_bind /dlet /=. unlock.
    rewrite /mlet /=.
    rewrite psumZ. 2: apply r_nonneg.
    erewrite eq_psum.
    2:{
      move=> x1. rewrite psumZ. 2: apply r_nonneg.
      reflexivity.
    }
    rewrite psumZ. 2: apply r_nonneg.
    rewrite GRing.Theory.mulrA.
    assert (psum_ret :
      psum (λ x1 : X, psum (λ x2 : Y, SD_ret (x1, x2) (x, y))) = 1
    ).
    { rewrite /SD_ret.
      pose hlp := (
        @psum_pair _ X Y
          (fun (x12 : prod_finType X Y) =>
          let (x1,x2) := x12 in
          SDistr_unit (prod_choiceType X Y) (x1,x2) (x,y))
      ).
      rewrite -hlp.
      - unshelve erewrite eq_psum.
        + exact (SDistr_unit _ (x,y)).
        + apply psum_SDistr_unit.
        + move=> [x1 x2] /=. rewrite /SDistr_unit.
          rewrite !dunit1E.
          rewrite eq_sym. reflexivity.
        + unshelve eapply eq_summable.
          * exact (SDistr_unit _ (x,y)).
          * move=> [x1 x2] /=. rewrite /SDistr_unit.
            rewrite !dunit1E. rewrite eq_sym. reflexivity.
          * apply summable_mu.
    }
    rewrite psum_ret. rewrite GRing.mulr1.
    rewrite !/r. rewrite card_prod.
    rewrite GRing.Theory.mulf_div.
    rewrite GRing.mulr1.
    rewrite -intrM. reflexivity.
Qed.

End prod_uniform.


Require Export compcert.common.Values.
Import Coqlib.

Lemma val_inject_lessdef_compose:
  forall j v1 v2, val_inject j v1 v2 -> forall v3, Val.lessdef v2 v3 -> val_inject j v1 v3.
Proof.
  inversion 1; subst; inversion 1; subst; auto.
Qed.

Lemma val_lessdef_inject_compose:
  forall v1 v2, Val.lessdef v1 v2 -> forall j v3, val_inject j v2 v3 -> val_inject j v1 v3.
Proof.
  inversion 1; subst; inversion 1; subst; auto.
Qed.

Lemma val_inject_incr_recip :
  forall j1 v v1,
    val_inject j1 v v1 ->
    forall j2 v2,
      val_inject j2 v v2 ->
      inject_incr j2 j1 ->
      val_inject j2 v v1.
Proof.
  inversion 1; subst; try (constructor; fail).
  inversion 1; subst.
  intro INCR. exploit INCR; eauto. intro.
  econstructor.
  2: reflexivity.
  congruence.
Qed.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import List.
Require Import Lia.
Require Import DataSystem.
Require Import Dataframe.

Section DataframeSize.
  Context {fruntime:foreign_runtime}.
  Context {ftype: foreign_type}.

  Fixpoint column_size (c:column)
    := match c with
       | CCol _ => 1
       | CDot _ c0 => S (column_size c0)
       | CLit _ => 1
       | CPlus c1 c2 => S (column_size c1 + column_size c2)
       | CEq c1 c2 => S (column_size c1 + column_size c2)
       | CLessThan  c1 c2 => S (column_size c1 + column_size c2)
       | CNeg c0 => S (column_size c0)
       (* NOTE we actually codegen to a UDF for this, not Spark's printing *)
       | CToString c0 => S (column_size c0)
       | CSConcat c1 c2 => S (column_size c1 + column_size c2)
       | CUDFCast _ c0 => S (column_size c0)
       | CUDFUnbrand _ c0 => S (column_size c0)
       end.

  Fixpoint dataframe_size (d:dataframe)
    := match d with
       | DSVar _ => 1
       | DSSelect scl d0 => S (
                                (fold_left (fun acc sc => column_size (snd sc) + acc) scl 0)
                                  + dataframe_size d0)
       | DSFilter c0 d0 => S (column_size c0 + dataframe_size d0)
       | DSCartesian d1 d2 => S (dataframe_size d1 + dataframe_size d2)
       | DSExplode _ d0 => S (dataframe_size d0)
       end.

  Lemma column_size_nzero (c:column) : column_size c <> 0.
  Proof.
    induction c; simpl; lia.
  Qed.

    Lemma dataframe_size_nzero (d:dataframe) : dataframe_size d <> 0.
  Proof.
    induction d; simpl; lia.
  Qed.

End DataframeSize.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2011-2013 Sylvie Boldo
#<br />#
Copyright (C) 2011-2013 Guillaume Melquiond

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 3 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
COPYING file for more details.
*)

Require Import ZArith.
Require Import ZArith.Zquot.

Section Zmissing.

(** About Z *)
Theorem Zopp_le_cancel :
  forall x y : Z,
  (-y <= -x)%Z -> Zle x y.
Proof.
intros x y Hxy.
apply Zplus_le_reg_r with (-x - y)%Z.
now ring_simplify.
Qed.

Theorem Zgt_not_eq :
  forall x y : Z,
  (y < x)%Z -> (x <> y)%Z.
Proof.
intros x y H Hn.
apply Zlt_irrefl with x.
now rewrite Hn at 1.
Qed.

End Zmissing.

Section Proof_Irrelevance.

Scheme eq_dep_elim := Induction for eq Sort Type.

Definition eqbool_dep P (h1 : P true) b :=
  match b return P b -> Prop with
  | true => fun (h2 : P true) => h1 = h2
  | false => fun (h2 : P false) => False
  end.

Lemma eqbool_irrelevance : forall (b : bool) (h1 h2 : b = true), h1 = h2.
Proof.
assert (forall (h : true = true), refl_equal true = h).
apply (eq_dep_elim bool true (eqbool_dep _ _) (refl_equal _)).
intros b.
case b.
intros h1 h2.
now rewrite <- (H h1).
intros h.
discriminate h.
Qed.

End Proof_Irrelevance.

Section Even_Odd.

(** Zeven, used for rounding to nearest, ties to even *)
Definition Zeven (n : Z) :=
  match n with
  | Zpos (xO _) => true
  | Zneg (xO _) => true
  | Z0 => true
  | _ => false
  end.

Theorem Zeven_mult :
  forall x y, Zeven (x * y) = orb (Zeven x) (Zeven y).
Proof.
now intros [|[xp|xp|]|[xp|xp|]] [|[yp|yp|]|[yp|yp|]].
Qed.

Theorem Zeven_opp :
  forall x, Zeven (- x) = Zeven x.
Proof.
now intros [|[n|n|]|[n|n|]].
Qed.

Theorem Zeven_ex :
  forall x, exists p, x = (2 * p + if Zeven x then 0 else 1)%Z.
Proof.
intros [|[n|n|]|[n|n|]].
now exists Z0.
now exists (Zpos n).
now exists (Zpos n).
now exists Z0.
exists (Zneg n - 1)%Z.
change (2 * Zneg n - 1 = 2 * (Zneg n - 1) + 1)%Z.
ring.
now exists (Zneg n).
now exists (-1)%Z.
Qed.

Theorem Zeven_2xp1 :
  forall n, Zeven (2 * n + 1) = false.
Proof.
intros n.
destruct (Zeven_ex (2 * n + 1)) as (p, Hp).
revert Hp.
case (Zeven (2 * n + 1)) ; try easy.
intros H.
apply False_ind.
omega.
Qed.

Theorem Zeven_plus :
  forall x y, Zeven (x + y) = Bool.eqb (Zeven x) (Zeven y).
Proof.
intros x y.
destruct (Zeven_ex x) as (px, Hx).
rewrite Hx at 1.
destruct (Zeven_ex y) as (py, Hy).
rewrite Hy at 1.
replace (2 * px + (if Zeven x then 0 else 1) + (2 * py + (if Zeven y then 0 else 1)))%Z
  with (2 * (px + py) + ((if Zeven x then 0 else 1) + (if Zeven y then 0 else 1)))%Z by ring.
case (Zeven x) ; case (Zeven y).
rewrite Zplus_0_r.
now rewrite Zeven_mult.
apply Zeven_2xp1.
apply Zeven_2xp1.
replace (2 * (px + py) + (1 + 1))%Z with (2 * (px + py + 1))%Z by ring.
now rewrite Zeven_mult.
Qed.

End Even_Odd.

Section Zpower.

Theorem Zpower_plus :
  forall n k1 k2, (0 <= k1)%Z -> (0 <= k2)%Z ->
  Zpower n (k1 + k2) = (Zpower n k1 * Zpower n k2)%Z.
Proof.
intros n k1 k2 H1 H2.
now apply Zpower_exp ; apply Zle_ge.
Qed.

Theorem Zpower_Zpower_nat :
  forall b e, (0 <= e)%Z ->
  Zpower b e = Zpower_nat b (Zabs_nat e).
Proof.
intros b [|e|e] He.
apply refl_equal.
apply Zpower_pos_nat.
elim He.
apply refl_equal.
Qed.

Theorem Zpower_nat_S :
  forall b e,
  Zpower_nat b (S e) = (b * Zpower_nat b e)%Z.
Proof.
intros b e.
rewrite (Zpower_nat_is_exp 1 e).
apply (f_equal (fun x => x * _)%Z).
apply Zmult_1_r.
Qed.

Theorem Zpower_pos_gt_0 :
  forall b p, (0 < b)%Z ->
  (0 < Zpower_pos b p)%Z.
Proof.
intros b p Hb.
rewrite Zpower_pos_nat.
induction (nat_of_P p).
easy.
rewrite Zpower_nat_S.
now apply Zmult_lt_0_compat.
Qed.

Theorem Zeven_Zpower :
  forall b e, (0 < e)%Z ->
  Zeven (Zpower b e) = Zeven b.
Proof.
intros b e He.
case_eq (Zeven b) ; intros Hb.
(* b even *)
replace e with (e - 1 + 1)%Z by ring.
rewrite Zpower_exp.
rewrite Zeven_mult.
replace (Zeven (b ^ 1)) with true.
apply Bool.orb_true_r.
unfold Zpower, Zpower_pos. simpl.
now rewrite Zmult_1_r.
omega.
discriminate.
(* b odd *)
rewrite Zpower_Zpower_nat.
induction (Zabs_nat e).
easy.
unfold Zpower_nat. simpl.
rewrite Zeven_mult.
now rewrite Hb.
now apply Zlt_le_weak.
Qed.

Theorem Zeven_Zpower_odd :
  forall b e, (0 <= e)%Z -> Zeven b = false ->
  Zeven (Zpower b e) = false.
Proof.
intros b e He Hb.
destruct (Z_le_lt_eq_dec _ _ He) as [He'|He'].
rewrite <- Hb.
now apply Zeven_Zpower.
now rewrite <- He'.
Qed.

(** The radix must be greater than 1 *)
Record radix := { radix_val :> Z ; radix_prop : Zle_bool 2 radix_val = true }.

Theorem radix_val_inj :
  forall r1 r2, radix_val r1 = radix_val r2 -> r1 = r2.
Proof.
intros (r1, H1) (r2, H2) H.
simpl in H.
revert H1.
rewrite H.
intros H1.
apply f_equal.
apply eqbool_irrelevance.
Qed.

Variable r : radix.

Theorem radix_gt_0 : (0 < r)%Z.
Proof.
apply Zlt_le_trans with 2%Z.
easy.
apply Zle_bool_imp_le.
apply r.
Qed.

Theorem radix_gt_1 : (1 < r)%Z.
Proof.
destruct r as (v, Hr). simpl.
apply Zlt_le_trans with 2%Z.
easy.
now apply Zle_bool_imp_le.
Qed.

Theorem Zpower_gt_1 :
  forall p,
  (0 < p)%Z ->
  (1 < Zpower r p)%Z.
Proof.
intros [|p|p] Hp ; try easy.
simpl.
rewrite Zpower_pos_nat.
generalize (lt_O_nat_of_P p).
induction (nat_of_P p).
easy.
intros _.
rewrite Zpower_nat_S.
assert (0 < Zpower_nat r n)%Z.
clear.
induction n.
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
apply Zle_lt_trans with (1 * Zpower_nat r n)%Z.
rewrite Zmult_1_l.
now apply (Zlt_le_succ 0).
apply Zmult_lt_compat_r with (1 := H).
apply radix_gt_1.
Qed.

Theorem Zpower_gt_0 :
  forall p,
  (0 <= p)%Z ->
  (0 < Zpower r p)%Z.
Proof.
intros p Hp.
rewrite Zpower_Zpower_nat with (1 := Hp).
induction (Zabs_nat p).
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
Qed.

Theorem Zpower_ge_0 :
  forall e,
  (0 <= Zpower r e)%Z.
Proof.
intros [|e|e] ; try easy.
apply Zlt_le_weak.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_le :
  forall e1 e2, (e1 <= e2)%Z ->
  (Zpower r e1 <= Zpower r e2)%Z.
Proof.
intros e1 e2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite <- (Zmult_1_l (r ^ e1)) at 1.
apply Zmult_le_compat_r.
apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zpower_ge_0.
now apply Zle_minus_le_0.
clear He.
destruct e1 as [|e1|e1] ; try easy.
apply Zpower_ge_0.
Qed.

Theorem Zpower_lt :
  forall e1 e2, (0 <= e2)%Z -> (e1 < e2)%Z ->
  (Zpower r e1 < Zpower r e2)%Z.
Proof.
intros e1 e2 He2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite Zmult_comm.
rewrite <- (Zmult_1_r (r ^ e1)) at 1.
apply Zmult_lt_compat2.
split.
now apply Zpower_gt_0.
apply Zle_refl.
split.
easy.
apply Zpower_gt_1.
clear -He ; omega.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
revert H1.
clear -He2.
destruct e1 ; try easy.
intros _.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_lt_Zpower :
  forall e1 e2,
  (Zpower r (e1 - 1) < Zpower r e2)%Z ->
  (e1 <= e2)%Z.
Proof.
intros e1 e2 He.
apply Znot_gt_le.
intros H.
apply Zlt_not_le with (1 := He).
apply Zpower_le.
clear -H ; omega.
Qed.

End Zpower.

Section Div_Mod.

Theorem Zmod_mod_mult :
  forall n a b, (0 < a)%Z -> (0 <= b)%Z ->
  Zmod (Zmod n (a * b)) b = Zmod n b.
Proof.
intros n a [|b|b] Ha Hb.
now rewrite 2!Zmod_0_r.
rewrite (Zmod_eq n (a * Zpos b)).
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
apply Z_mod_plus.
easy.
apply Zmult_gt_0_compat.
now apply Zlt_gt.
easy.
now elim Hb.
Qed.
(*
Notation ZOmod := Z.rem.
Notation ZOdiv := Z.quot.
Notation ZO_div_mod_eq := Z.quot_rem'.
*)
Theorem ZOmod_eq :
  forall a b,
  Z.rem a b = (a - Z.quot a b * b)%Z.
Proof.
intros a b.
rewrite (Z.quot_rem' a b) at 2.
ring.
Qed.
(* TODO *)
Theorem ZOmod_mod_mult :
  forall n a b,
  Z.rem (Z.rem n (a * b)) b = Z.rem n b.
Proof.
intros n a b.
assert (Z.rem n (a * b) = n + - (Z.quot n (a * b) * a) * b)%Z.
rewrite <- Zopp_mult_distr_l.
rewrite <- Zmult_assoc.
apply ZOmod_eq.
rewrite H.
apply Z_rem_plus.
rewrite <- H.
apply Zrem_sgn2.
Qed.

Theorem Zdiv_mod_mult :
  forall n a b, (0 <= a)%Z -> (0 <= b)%Z ->
  (Zdiv (Zmod n (a * b)) a) = Zmod (Zdiv n a) b.
Proof.
intros n a b Ha Hb.
destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|Ha'].
destruct (Zle_lt_or_eq _ _ Hb) as [Hb'|Hb'].
rewrite (Zmod_eq n (a * b)).
rewrite (Zmult_comm a b) at 2.
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
rewrite Z_div_plus by now apply Zlt_gt.
rewrite <- Zdiv_Zdiv by easy.
apply sym_eq.
apply Zmod_eq.
now apply Zlt_gt.
now apply Zmult_gt_0_compat ; apply Zlt_gt.
rewrite <- Hb'.
rewrite Zmult_0_r, 2!Zmod_0_r.
apply Zdiv_0_l.
rewrite <- Ha'.
now rewrite 2!Zdiv_0_r, Zmod_0_l.
Qed.

Theorem ZOdiv_mod_mult :
  forall n a b,
  (Z.quot (Z.rem n (a * b)) a) = Z.rem (Z.quot n a) b.
Proof.
intros n a b.
destruct (Z_eq_dec a 0) as [Za|Za].
rewrite Za.
now rewrite 2!Zquot_0_r, Zrem_0_l.
assert (Z.rem n (a * b) = n + - (Z.quot (Z.quot n a) b * b) * a)%Z.
rewrite (ZOmod_eq n (a * b)) at 1.
rewrite Zquot_Zquot.
ring.
rewrite H.
rewrite Z_quot_plus with (2 := Za).
apply sym_eq.
apply ZOmod_eq.
rewrite <- H.
apply Zrem_sgn2.
Qed.

Theorem ZOdiv_small_abs :
  forall a b,
  (Zabs a < b)%Z -> Z.quot a b = Z0.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply Zquot_small.
split.
exact H.
now rewrite Zabs_eq in Ha.
apply Zopp_inj.
rewrite <- Zquot_opp_l, Zopp_0.
apply Zquot_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOmod_small_abs :
  forall a b,
  (Zabs a < b)%Z -> Z.rem a b = a.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply Zrem_small.
split.
exact H.
now rewrite Zabs_eq in Ha.
apply Zopp_inj.
rewrite <- Zrem_opp_l.
apply Zrem_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOdiv_plus :
  forall a b c, (0 <= a * b)%Z ->
  (Z.quot (a + b) c = Z.quot a c + Z.quot b c + Z.quot (Z.rem a c + Z.rem b c) c)%Z.
Proof.
intros a b c Hab.
destruct (Z_eq_dec c 0) as [Zc|Zc].
now rewrite Zc, 4!Zquot_0_r.
apply Zmult_reg_r with (1 := Zc).
rewrite 2!Zmult_plus_distr_l.
assert (forall d, Z.quot d c * c = d - Z.rem d c)%Z.
intros d.
rewrite ZOmod_eq.
ring.
rewrite 4!H.
rewrite <- Zplus_rem with (1 := Hab).
ring.
Qed.

End Div_Mod.

Section Same_sign.

Theorem Zsame_sign_trans :
  forall v u w, v <> Z0 ->
  (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof.
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now elim Zv.
Qed.

Theorem Zsame_sign_trans_weak :
  forall v u w, (v = Z0 -> w = Z0) ->
  (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof.
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now discriminate Zv.
Qed.

Theorem Zsame_sign_imp :
  forall u v,
  (0 < u -> 0 <= v)%Z ->
  (0 < -u -> 0 <= -v)%Z ->
  (0 <= u * v)%Z.
Proof.
intros [|u|u] v Hp Hn.
easy.
apply Zmult_le_0_compat.
easy.
now apply Hp.
replace (Zneg u * v)%Z with (Zpos u * (-v))%Z.
apply Zmult_le_0_compat.
easy.
now apply Hn.
rewrite <- Zopp_mult_distr_r.
apply Zopp_mult_distr_l.
Qed.

Theorem Zsame_sign_odiv :
  forall u v, (0 <= v)%Z ->
  (0 <= u * Z.quot u v)%Z.
Proof.
intros u v Hv.
apply Zsame_sign_imp ; intros Hu.
apply Z_quot_pos with (2 := Hv).
now apply Zlt_le_weak.
rewrite <- Zquot_opp_l.
apply Z_quot_pos with (2 := Hv).
now apply Zlt_le_weak.
Qed.

End Same_sign.

(** Boolean comparisons *)

Section Zeq_bool.

Inductive Zeq_bool_prop (x y : Z) : bool -> Prop :=
  | Zeq_bool_true_ : x = y -> Zeq_bool_prop x y true
  | Zeq_bool_false_ : x <> y -> Zeq_bool_prop x y false.

Theorem Zeq_bool_spec :
  forall x y, Zeq_bool_prop x y (Zeq_bool x y).
Proof.
intros x y.
generalize (Zeq_is_eq_bool x y).
case (Zeq_bool x y) ; intros (H1, H2) ; constructor.
now apply H2.
intros H.
specialize (H1 H).
discriminate H1.
Qed.

Theorem Zeq_bool_true :
  forall x y, x = y -> Zeq_bool x y = true.
Proof.
intros x y.
apply -> Zeq_is_eq_bool.
Qed.

Theorem Zeq_bool_false :
  forall x y, x <> y -> Zeq_bool x y = false.
Proof.
intros x y.
generalize (proj2 (Zeq_is_eq_bool x y)).
case Zeq_bool.
intros He Hn.
elim Hn.
now apply He.
now intros _ _.
Qed.

End Zeq_bool.

Section Zle_bool.

Inductive Zle_bool_prop (x y : Z) : bool -> Prop :=
  | Zle_bool_true_ : (x <= y)%Z -> Zle_bool_prop x y true
  | Zle_bool_false_ : (y < x)%Z -> Zle_bool_prop x y false.

Theorem Zle_bool_spec :
  forall x y, Zle_bool_prop x y (Zle_bool x y).
Proof.
intros x y.
generalize (Zle_is_le_bool x y).
case Zle_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt x y) as [H|H].
now specialize (H1 H).
exact H.
Qed.

Theorem Zle_bool_true :
  forall x y : Z,
  (x <= y)%Z -> Zle_bool x y = true.
Proof.
intros x y.
apply (proj1 (Zle_is_le_bool x y)).
Qed.

Theorem Zle_bool_false :
  forall x y : Z,
  (y < x)%Z -> Zle_bool x y = false.
Proof.
intros x y Hxy.
generalize (Zle_cases x y).
case Zle_bool ; intros H.
elim (Zlt_irrefl x).
now apply Zle_lt_trans with y.
apply refl_equal.
Qed.

End Zle_bool.

Section Zlt_bool.

Inductive Zlt_bool_prop (x y : Z) : bool -> Prop :=
  | Zlt_bool_true_ : (x < y)%Z -> Zlt_bool_prop x y true
  | Zlt_bool_false_ : (y <= x)%Z -> Zlt_bool_prop x y false.

Theorem Zlt_bool_spec :
  forall x y, Zlt_bool_prop x y (Zlt_bool x y).
Proof.
intros x y.
generalize (Zlt_is_lt_bool x y).
case Zlt_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt y x) as [H|H].
exact H.
now specialize (H1 H).
Qed.

Theorem Zlt_bool_true :
  forall x y : Z,
  (x < y)%Z -> Zlt_bool x y = true.
Proof.
intros x y.
apply (proj1 (Zlt_is_lt_bool x y)).
Qed.

Theorem Zlt_bool_false :
  forall x y : Z,
  (y <= x)%Z -> Zlt_bool x y = false.
Proof.
intros x y Hxy.
generalize (Zlt_cases x y).
case Zlt_bool ; intros H.
elim (Zlt_irrefl x).
now apply Zlt_le_trans with y.
apply refl_equal.
Qed.

Theorem negb_Zle_bool :
  forall x y : Z,
  negb (Zle_bool x y) = Zlt_bool y x.
Proof.
intros x y.
case Zle_bool_spec ; intros H.
now rewrite Zlt_bool_false.
now rewrite Zlt_bool_true.
Qed.

Theorem negb_Zlt_bool :
  forall x y : Z,
  negb (Zlt_bool x y) = Zle_bool y x.
Proof.
intros x y.
case Zlt_bool_spec ; intros H.
now rewrite Zle_bool_false.
now rewrite Zle_bool_true.
Qed.

End Zlt_bool.

Section Zcompare.

Inductive Zcompare_prop (x y : Z) : comparison -> Prop :=
  | Zcompare_Lt_ : (x < y)%Z -> Zcompare_prop x y Lt
  | Zcompare_Eq_ : x = y -> Zcompare_prop x y Eq
  | Zcompare_Gt_ : (y < x)%Z -> Zcompare_prop x y Gt.

Theorem Zcompare_spec :
  forall x y, Zcompare_prop x y (Zcompare x y).
Proof.
intros x y.
destruct (Z_dec x y) as [[H|H]|H].
generalize (Zlt_compare _ _ H).
case (Zcompare x y) ; try easy.
now constructor.
generalize (Zgt_compare _ _ H).
case (Zcompare x y) ; try easy.
constructor.
now apply Zgt_lt.
generalize (proj2 (Zcompare_Eq_iff_eq _ _) H).
case (Zcompare x y) ; try easy.
now constructor.
Qed.

Theorem Zcompare_Lt :
  forall x y,
  (x < y)%Z -> Zcompare x y = Lt.
Proof.
easy.
Qed.

Theorem Zcompare_Eq :
  forall x y,
  (x = y)%Z -> Zcompare x y = Eq.
Proof.
intros x y.
apply <- Zcompare_Eq_iff_eq.
Qed.

Theorem Zcompare_Gt :
  forall x y,
  (y < x)%Z -> Zcompare x y = Gt.
Proof.
intros x y.
apply Zlt_gt.
Qed.

End Zcompare.

Section cond_Zopp.

Definition cond_Zopp (b : bool) m := if b then Zopp m else m.

Theorem abs_cond_Zopp :
  forall b m,
  Zabs (cond_Zopp b m) = Zabs m.
Proof.
intros [|] m.
apply Zabs_Zopp.
apply refl_equal.
Qed.

Theorem cond_Zopp_Zlt_bool :
  forall m,
  cond_Zopp (Zlt_bool m 0) m = Zabs m.
Proof.
intros m.
apply sym_eq.
case Zlt_bool_spec ; intros Hm.
apply Zabs_non_eq.
now apply Zlt_le_weak.
now apply Zabs_eq.
Qed.

End cond_Zopp.


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.

Require Import Defs.Env.
Require Import Defs.List.
Require Import Defs.Obj.
Require Import Defs.Set.
Require Import Defs.Substs.

Require Import Defs.FrA.
Require Import Defs.WfTy.

(*** Notation, tactics etc*)
Notation "wf( A )" := (WfEnv A) (at level 50, format "wf( A )") : type_scope.

Ltac inv_Wf_ :=
  match goal with
    | [ H : wf(_ ::s _)  |- _ ] => inverts H
    | [ H : wf(_ ::a _)  |- _ ] => inverts H
    | [ H : wf(_ ::x _ :- _)  |- _ ] => inverts H
    | [ H : wf(_ ::o _)  |- _ ] => inverts H
  end.
Ltac inv_Wf := repeat inv_Wf_.
Ltac inv_Wf' := repeat (inv_Wf; inv_FrA).

(*** Weakening *)
Theorem WfEnv_weak_app : forall (env1 env2 : Env),
    wf(env1 +++ env2)
  -> wf(env1).
Proof. introv WF. induction env2; inverts WF; crush. Qed.
#[export] Hint Resolve WfEnv_weak_app : core.

Theorem WfEnv_weak_cons_s : forall (skA : skvar) (env : Env),
    wf(env ::s skA)
  -> False.
Proof. introv WF. inverts WF. Qed.
#[export] Hint Resolve WfEnv_weak_cons_s : core.

Theorem WfEnv_weak_cons_a : forall (a : A) (env : Env),
    wf(env ::a a)
  -> wf(env).
Proof. introv WF. norm*. eauto. Qed.
#[export] Hint Resolve WfEnv_weak_cons_a : core.

Theorem WfEnv_weak_cons_a_cons : forall (exA : exvar) (a : A) (env : Env),
    wf(env ::a (exA :: a))
  -> wf(env ::a a).
Proof. introv WF. inverts WF. constructor. assumption. eauto. Qed.
#[export] Hint Resolve WfEnv_weak_cons_a_cons : core.

Theorem WfEnv_weak_cons_a_app : forall (a1 a2 : A) (env : Env),
    wf(env ::a (a2 ++ a1))
  -> wf(env ::a a1).
Proof. introv WF. inverts WF. constructor. assumption. eauto 6. Qed.
#[export] Hint Resolve WfEnv_weak_cons_a_app : core.

Theorem WfEnv_weak_cons_x : forall (x : termvar) (sch : Sch) (env : Env),
    wf(env ::x x :- sch)
  -> wf(env).
Proof. introv WF. norm*. eauto. Qed.
#[export] Hint Resolve WfEnv_weak_cons_x : core.

Theorem WfEnv_weak_cons_o : forall (obj : Obj) (env : Env),
    wf(env ::o obj)
  -> wf(env).
Proof. introv WF. norm*. eauto. Qed.
#[export] Hint Resolve WfEnv_weak_cons_o : core.

Theorem WfEnv_weak_app_onea_cons : forall (exA : exvar) (a : A) (env : Env),
    wf(env +++ <exA :: a>a)
  -> wf(env +++ <      a>a).
Proof. introv WF. inverts WF. constructor; eauto. Qed.
#[export] Hint Resolve WfEnv_weak_app_onea_cons : core.

Theorem WfEnv_weak_app_onea_app : forall (a1 a2 : A) (env : Env),
    wf(env +++ <a2 ++ a1>a)
  -> wf(env +++ <      a1>a).
Proof. introv WF. inverts WF. constructor; eauto 6. Qed.
#[export] Hint Resolve WfEnv_weak_app_onea_app : core.

(*** Inversion *)
Theorem WfEnv_inv_app_onea : forall (a : A) (env : Env),
    wf(env +++ <a>a)
  -> FrA a env.
Proof. inversion 1. trivial. Qed.
#[export] Hint Resolve WfEnv_inv_app_onea : core.

Theorem WfEnv_inv_cons_a : forall (a : A) (env : Env),
    wf(env ::a a)
  -> FrA a env.
Proof. intros. norm*. eauto. Qed.
#[export] Hint Resolve WfEnv_inv_cons_a : core.

Theorem WfEnv_inv_cons_x : forall (x : termvar) (sch : Sch) (env : Env),
    wf(env ::x x :- sch)
  -> env |=ty sch.
Proof. intros. inv_Wf. assumption. Qed.
#[export] Hint Resolve WfEnv_inv_cons_x : core.

Theorem wf_Env_inv_o : forall (env : Env) (a : A) (sch : Sch),
    wf(env ::o ⟦⟨a⟩ sch⟧)
  -> env ::a a |=ty sch.
Proof. inversion 1; assumption. Qed.
#[export] Hint Resolve wf_Env_inv_o : core.

(*** Wf-ness of objects*)
Theorem wf_Env_Obj_x : forall (env : Env) (sch : Sch) (x : termvar) (a : A),
    wf(env ::o ⟦⟨a⟩ sch⟧)
  <-> wf(env ::a a ::x x :- sch).
Proof. split; intros; inv_Wf; crush. Qed.
Corollary wf_Env_Obj_x1 : forall (env : Env) (sch : Sch) (x : termvar) (a : A),
    wf(env ::o ⟦⟨a⟩ sch⟧)
  -> wf(env ::a a ::x x :- sch).
Proof. apply wf_Env_Obj_x. Qed.
Corollary wf_Env_Obj_x2 : forall (env : Env) (sch : Sch) (x : termvar) (a : A),
    wf(env ::a a ::x x :- sch)
  -> wf(env ::o ⟦⟨a⟩ sch⟧).
Proof. apply wf_Env_Obj_x. Qed.
#[export] Hint Resolve wf_Env_Obj_x1 wf_Env_Obj_x2 : slow.

Theorem wf_Env_Obj_noa_x : forall (env : Env) (sch : Sch) (x : termvar),
    wf(env ::o ⟦sch⟧)
  <-> wf(env ::x x :- sch).
Proof. split; intros; inv_Wf. constructor. auto. eapply WfTy_Env_sub. eassumption. auto. eauto. Qed.

Corollary wf_Env_Obj_noa_x1 : forall (env : Env) (sch : Sch) (x : termvar),
    wf(env ::o ⟦sch⟧)
  -> wf(env ::x x :- sch).
Proof. apply wf_Env_Obj_noa_x. Qed.
Corollary wf_Env_Obj_noa_x2 : forall (env : Env) (sch : Sch) (x : termvar),
    wf(env ::x x :- sch)
  -> wf(env ::o ⟦sch⟧).
Proof. apply wf_Env_Obj_noa_x. Qed.
#[export] Hint Resolve wf_Env_Obj_noa_x1 wf_Env_Obj_noa_x2 : slow.

Corollary wf_Env_Obj_move_a1 : forall (env : Env) (sch : Sch) (a : A),
    wf(env ::a a ::o ⟦sch⟧)
  -> wf(env ::o ⟦⟨a⟩ sch⟧).
Proof. intros. fresh_atom' empty. apply (wf_Env_Obj_x _ _ x). auto using wf_Env_Obj_noa_x1. Qed.
Corollary wf_Env_Obj_move_a2 : forall (env : Env) (sch : Sch) (a : A),
    wf(env ::o ⟦⟨a⟩ sch⟧)
  -> wf(env ::a a ::o ⟦sch⟧).
Proof. intros. fresh_atom' empty. apply (wf_Env_Obj_noa_x _ _ x). eauto using wf_Env_Obj_x1. Qed.

(*** Unsorted *)
Theorem in_wf_env_impls_wf : forall (sch : Sch) (env : Env),
    SchSI.In sch (Env_Schs env)
  -> wf(env)
  -> env |=ty sch.
Proof.
  introv IN WF. induction WF; rewr in IN. crush. 1,3:eauto.
  indestr. eauto. rewr*. subst. eauto.
Qed.

Theorem fv_sch_in_wfenv_subset : forall (sch : Sch) (env : Env),
    SchSI.In sch (Env_Obj_Schs env)
  -> wf(env)
  -> free_exvars_Sch sch [<=] Env_Obj_exvars env.
Proof.
  introv IN WF. induction WF; rewr in IN.
  - crush.
  - crush.
  - indestr. eauto. rewr*. subst.
    transitivity (Env_exvars Env5). auto using fv_sch_wfty_subset. conv. reflexivity.
  - indestr. rewr. crush. rewr*. subst.
    transitivity (Env_exvars (Env5 ::a A5)). auto using fv_sch_wfty_subset. rewr. conv. crush.
Qed.

Theorem wf_Env_exvar_disj : forall (env1 env2 : Env),
    wf(env1 +++ env2)
  -> Env_Obj_exvars env1 [><] Env_Obj_exvars env2.
Proof.
  introv WF. induction env2.
  - crush.
  - inverts WF.
  - inverts WF. forwards IH: IHenv2. assumption.
    symmetry. rewr. apply disjoint_extend''.
    forwards [? ?]: FrA_props1. eassumption. rewr*. eapply disj_equiv_proper. reflexivity. 2:eassumption. crush.
    crush.
  - inverts WF. rewr. crush.
  - inverts WF. forwards IH: IHenv2. assumption.
    symmetry. rewr. apply disjoint_extend''.
    forwards [? ?]: FrA_props1. eassumption. rewr*. eapply disj_equiv_proper. reflexivity. 2:eassumption. crush.
    crush.
Qed.

Theorem subst_exvar_Env_notin_Env_idempotent : forall (env : Env) (ty : Ty) (exA : exvar),
    exA \notin Env_Obj_exvars env
  -> wf(env)
  -> subst_exvar_Env ty exA env = env.
Proof.
  introv NIE WF. induction WF.
  - crush.
  - crush.
  - simpl. rewr in NIE. rewrite IHWF; auto.
    forwards: fv_sch_wfty_subset. eassumption.
    rewrite subst_exvar_Sch_not_in_Sch_idempotent; auto.
  - simpl. rewr*. rewrite IHWF; auto.
    forwards: fv_sch_wfty_subset. eassumption.
    rewrite subst_exvar_Sch_not_in_Sch_idempotent. reflexivity.
    unfold not. intros. indestr. apply NIE. rewrite H in H0. indestr'.
Qed.

Theorem subst_exvar_Env_notinenv : forall (ty : Ty) (exA : exvar) (env : Env),
    exA \notin Env_Obj_exvars env
  -> wf(env)
  -> subst_exvar_Env ty exA env = env.
Proof.
   introv NIE WF. induction WF.
   - crush.
   - crush.
   - simpl in *. rewrite subst_exvar_Sch_not_in_Sch_idempotent. crush.
     forwards: WfTy_impls_free_exvar_sub. eassumption. rewr in NIE. fsetdec.
   - simpl in *. rewrite subst_exvar_Sch_not_in_Sch_idempotent. crush.
     unfold not. intros IS.
     forwards SUB: WfTy_impls_free_exvar_sub. eassumption. rewrite SUB in IS.
     apply NIE. rewr*. indestr'.
Qed.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Matrix on Real numbers.
  author    : ZhengPu Shi
  date      : 2021.12
*)

Require Export Matrix RExt.

Open Scope R_scope.
Open Scope mat_scope.

(* ################################################################# *)
(** ** 由矩阵理论直接得到的 实数矩阵理论 *)

Definition mat r c := mat (A:=R) r c.

Definition mk_mat {r c} f : mat r c := mk_mat (A:=R) r c f.

Definition m2f {r c} (m : mat r c) := m2f m.

Definition f2m {r c} f : mat r c := f2m f.

Definition meq {r c} (m1 m2 : mat r c) := meq m1 m2.

Lemma meq_refl : forall {r c} (m : mat r c), m == m.
Proof. intros. apply meq_refl. Qed.

Lemma meq_sym : forall {r c} (m1 m2 : mat r c), m1 == m2 -> m2 == m1.
Proof. intros. apply meq_sym; auto. Qed.

Lemma meq_trans : forall {r c} (m1 m2 m3 : mat r c),
    m1 == m2 -> m2 == m3 -> m1 == m3.
Proof. intros. apply meq_trans with m2; auto. Qed.

Lemma meq_iff : forall {r c} (m1 m2 : mat r c),
  m1 == m2 <-> forall i j, (i < r)%nat -> (j < c)%nat -> m2f m1 i j = m2f m2 i j.
Proof. intros. apply meq_iff. Qed.

Lemma meq_dec : forall {r c} (m1 m2 : mat r c), {m1 == m2} + {~(m1 == m2)}.
Proof. intros. apply meq_dec. Qed.

Definition mnth {r c} (m : mat r c) i j := mnth m i j.

Definition mrow {r c} (m : mat r c) i := mrow i m.

Lemma mrow_length : forall {r c} (m : mat r c) i, length (mrow m i) = c.
Proof. intros. apply mrow_length. Qed.

Lemma mrow_nth : forall {r c} (m : mat r c) i j,
    (i < r)%nat -> (j < c)%nat -> nth j (mrow m i) 0 = m2f m i j.
Proof. intros. apply mrow_nth; auto. Qed.

Definition mcol {r c} (m : mat r c) j := mcol j m.

Lemma mcol_length : forall {r c} (m : mat r c) j, length (mcol m j) = r.
Proof. intros. apply mcol_length. Qed.

Lemma mcol_nth : forall {r c} (m : mat r c) i j,
    (i < r)%nat -> (j < c)%nat -> nth i (mcol m j) 0 = m2f m i j.
Proof. intros. apply mcol_nth; auto. Qed.

Definition l2m {r c} l : mat r c := l2m l (r:=r) (c:=c) (A0:=0).

Definition m2l {r c} (m : mat r c) := m2l m.

Lemma m2l_length : forall {r c} (m : mat r c), length (m2l m) = r.
Proof. intros. apply m2l_length. Qed.

Lemma m2l_width : forall {r c} (m : mat r c), width (m2l m) c.
Proof. intros. apply m2l_width. Qed.

Lemma l2m_m2l_id : forall {r c} (m : mat r c), l2m (m2l m) == m.
Proof. intros. apply l2m_m2l_id. Qed.

Lemma m2l_l2m_id : forall {r c} l,
    length l = r -> width l c -> m2l (l2m l (r:=r) (c:=c)) = l.
Proof. intros. apply m2l_l2m_id; auto. Qed.

Lemma l2m_inj : forall {r c} l1 l2,
    length l1 = r -> width l1 c -> length l2 = r -> width l2 c ->
    l1 <> l2 -> ~(l2m l1 (r:=r) (c:=c) == l2m l2).
Proof. intros. apply l2m_inj; auto. Qed.

Lemma m2l_inj : forall {r c} (m1 m2 : mat r c),
    ~(m1 == m2) -> m2l m1 <> m2l m2.
Proof. intros. apply m2l_inj; auto. Qed.

Definition mshiftc {r c} (m : mat r c) k : mat r c := mshiftc m k.

Lemma mshiftc_neq : exists r c (m1 m2 : mat r c) k,
    (m1 == m2) /\ (~(mshiftc m1 k == mshiftc m2 k)).
Proof. apply (mshiftc_neq (A1_neq_A0:=R1_neq_R0)). Qed.

Definition mk_mat_0_c c : mat 0 c := mk_mat_0_c c (A0:=0).

Definition mk_mat_1_1 a11 : mat 1 1 := mk_mat_1_1 (A0:=0) a11.

Definition mk_mat_1_2 a11 a12 : mat 1 2 :=
  mk_mat_1_2 (A0:=0) a11 a12.

Definition mk_mat_1_3 a11 a12 a13 : mat 1 3 :=
  mk_mat_1_3 (A0:=0) a11 a12 a13.

Definition mk_mat_1_4 a11 a12 a13 a14 : mat 1 4 :=
  mk_mat_1_4 (A0:=0) a11 a12 a13 a14.

Definition mk_mat_1_c c l : mat 1 c := mk_mat_1_c c l (A0:=0).

Definition mk_mat_2_1 a11 a21 : mat 2 1 :=
  mk_mat_2_1 (A0:=0) a11 a21.

Definition mk_mat_2_2 a11 a12 a21 a22 : mat 2 2 :=
  mk_mat_2_2 (A0:=0) a11 a12 a21 a22.

Definition mk_mat_3_1 a11 a21 a31 : mat 3 1 :=
  mk_mat_3_1 (A0:=0) a11 a21 a31.

Definition mk_mat_3_3 a11 a12 a13 a21 a22 a23 a31 a32 a33 : mat 3 3 :=
  mk_mat_3_3 (A0:=0) a11 a12 a13 a21 a22 a23 a31 a32 a33.

Definition mk_mat_4_1 a11 a21 a31 a41 : mat 4 1 :=
  mk_mat_4_1 (A0:=0) a11 a21 a31 a41.

Definition mk_mat_4_4 a11 a12 a13 a14 a21 a22 a23 a24 a31 a32 a33 a34
  a41 a42 a43 a44 : mat 4 4 :=
  mk_mat_4_4 (A0:=0) a11 a12 a13 a14 a21 a22 a23 a24 a31 a32 a33 a34
    a41 a42 a43 a44.

Definition mk_mat_r_0 r : mat r 0 := mk_mat_r_0 (A0:=0) r.

Definition mk_mat_r_1 r l : mat r 1 := mk_mat_r_1 (A0:=0) r l.

Definition mmap {r c} f (m : mat r c) : mat r c := mmap f m.

Definition mmap2 {r c} f (m1 m2 : mat r c) : mat r c := mmap2 f m1 m2.

Lemma mmap2_comm : forall {r c} (m1 m2 : mat r c) f,
    (forall a b, f a b = f b a) ->
    mmap2 f m1 m2 == mmap2 f m2 m1.
Proof. intros. apply mmap2_comm; auto. Qed.

Lemma mmap2_assoc : forall {r c} (m1 m2 m3 : mat r c) f,
    (forall a b c, f (f a b) c = f a (f b c)) ->
    mmap2 f (mmap2 f m1 m2) m3 == mmap2 f m1 (mmap2 f m2 m3).
Proof. intros. apply mmap2_assoc; auto. Qed.

Definition mat0 r c : mat r c := mat0 r c (A0:=0).

Definition mat1 n : mat n n := mat1 n (A0:=0) (A1:=1).

Definition mdiag n l : mat n n := mdiag n l (A0:=0).

Definition madd {r c} (m1 m2 : mat r c) : mat r c := madd m1 m2 (op:=Rplus).
Global Infix "+" := madd : mat_scope.

Lemma madd_comm : forall {r c} (m1 m2 : mat r c), m1 + m2 == m2 + m1.
Proof. intros. apply madd_comm. Qed.

Lemma madd_assoc : forall {r c} (m1 m2 m3 : mat r c),
    (m1 + m2) + m3 == m1 + (m2 + m3).
Proof. intros. apply madd_assoc. Qed.

Lemma madd_0_l : forall {r c} (m : mat r c), (mat0 r c) + m == m.
Proof. intros. apply madd_0_l. Qed.

Lemma madd_0_r : forall {r c} (m : mat r c), m + (mat0 r c) == m.
Proof. intros. apply madd_0_r. Qed.

Lemma madd_nth : forall {r c} (m1 m2 : mat r c) i j,
    mnth (m1 + m2) i j = (mnth m1 i j + mnth m2 i j)%R.
Proof. intros. apply madd_nth. Qed.

Definition mopp {r c} (m : mat r c) : mat r c := mopp m (inv:=Ropp).
Global Notation "- m" := (mopp m) : mat_scope.

Definition msub {r c} (m1 m2 : mat r c) : mat r c :=
  msub m1 m2 (op:=Rplus) (inv:=Ropp).
Global Infix "-" := msub : mat_scope.

Lemma mopp_opp : forall {r c} (m : mat r c), --m == m.
Proof. intros. apply mopp_opp. Qed.

Lemma msub_comm : forall {r c} (m1 m2 : mat r c), m1 - m2 == - (m2 - m1).
Proof. intros. apply msub_comm. Qed.

Lemma msub_assoc : forall {r c} (m1 m2 m3 : mat r c),
    (m1 - m2) - m3 == m1 - (m2 + m3).
Proof. intros. apply msub_assoc. Qed.

Lemma msub_0_l : forall {r c} (m : mat r c), (mat0 r c) - m == - m.
Proof. intros. apply msub_0_l. Qed.

Lemma msub_0_r : forall {r c} (m : mat r c), m - (mat0 r c) == m.
Proof. intros. apply msub_0_r. Qed.

Lemma madd_opp : forall {r c} (m : mat r c), m + (-m) == mat0 r c.
Proof. intros. apply madd_opp. Qed.

Lemma msub_self : forall {r c} (m : mat r c), m - m == mat0 r c.
Proof. intros. apply msub_self. Qed.

Definition mcmul {r c} a (m : mat r c) : mat r c := mcmul a m (mul0:=Rmult).
Global Infix "c*" := mcmul : mat_scope.

Definition mmulc {r c} (m : mat r c) a : mat r c := mmulc m a (mul0:=Rmult).
Global Infix "*c" := mmulc : mat_scope.

Lemma mmulc_eq_mcmul : forall {r c} a (m : mat r c), m *c a == a c* m.
Proof. intros. apply mmulc_eq_mcmul. Qed.

Lemma mcmul_0_l : forall {r c} (m : mat r c), 0 c* m == mat0 r c.
Proof. intros. apply mcmul_0_l. Qed.

Lemma mcmul_0_r : forall {r c} a, a c* (mat0 r c) == mat0 r c.
Proof. intros. apply mcmul_0_r. Qed.

Lemma mcmul_1_l : forall {r c} (m : mat r c), 1 c* m == m.
Proof. intros. apply mcmul_1_l. Qed.

Lemma mcmul_1_r : forall {n} a,
    a c* (mat1 n) == f2m (fun i j => if (i =? j)%nat then a else 0).
Proof. intros. apply mcmul_1_r. Qed.

Lemma mcmul_assoc : forall {r c} a b (m : mat r c),
    a c* (b c* m) == (a * b)%R c* m.
Proof. intros. apply mcmul_assoc. Qed.

Lemma mcmul_perm : forall {r c} a b (m : mat r c),
    a c* (b c* m) == b c* (a c* m).
Proof. intros. apply mcmul_perm. Qed.

Lemma mcmul_add_distr_l : forall {r c} a (m1 m2 : mat r c),
    a c* (m1 + m2) == a c* m1 + a c* m2.
Proof. intros. apply mcmul_add_distr_l. Qed.

Lemma mcmul_add_distr_r : forall {r c} a b (m : mat r c),
    (a + b)%R c* m == a c* m + b c* m.
Proof. intros. apply mcmul_add_distr_r. Qed.

Definition mtrans {r c} (m : mat r c) : mat c r := mtrans m.
Global Notation "m '''" := (mtrans m) (at level 30) : mat_scope.

Lemma mtrans_trans : forall {r c} (m : mat r c), m '' == m.
Proof. intros. apply mtrans_trans. Qed.

Lemma mat1_trans_eq : forall {n}, (mat1 n) ' == mat1 n.
Proof. intros. apply mat1_trans_eq. Qed.

Lemma mat0_trans_eq : forall {r c}, (mat0 r c) ' == mat0 c r.
Proof. intros. apply mat0_trans_eq. Qed.

Definition mmul {r c s} (m1 : mat r c) (m2 : mat c s) : mat r s :=
  mmul m1 m2 (add0:=Rplus) (zero0:=0) (mul0:=Rmult).
Global Infix "*" := mmul : mat_scope.

Lemma mmul_assoc : forall {r c s t} (m1 : mat r c) (m2 : mat c s) (m3 : mat s t),
    (m1 * m2) * m3 == m1 * (m2 * m3).
Proof. intros. apply mmul_assoc. Qed.

Lemma mmul_add_distr_l : forall {r c s} (m1 : mat r c) (m2 m3 : mat c s),
    m1 * (m2 + m3) == m1 * m2 + m1 * m3.
Proof. intros. apply mmul_add_distr_l. Qed.

Lemma mmul_add_distr_r : forall {r c s} (m1 m2 : mat r c) (m3 : mat c s),
    (m1 + m2) * m3 == m1 * m3 + m2 * m3.
Proof. intros. apply mmul_add_distr_r. Qed.

Lemma mmul_0_l : forall {r c s} (m : mat c s), (mat0 r c) * m == mat0 r s.
Proof. intros. apply mmul_0_l. Qed.

Lemma mmul_0_r : forall {r c s} (m : mat r c), m * (mat0 c s) == mat0 r s.
Proof. intros. apply mmul_0_r. Qed.

Lemma mmul_1_l : forall {r c} (m : mat r c), (mat1 r) * m == m.
Proof. intros. apply mmul_1_l. Qed.

Lemma mmul_1_r : forall {r c} (m : mat r c), m * (mat1 c) == m.
Proof. intros. apply mmul_1_r. Qed.

Lemma mcmul_mul : forall {r c s} a (m1 : mat r c) (m2 : mat c s),
    (a c* m1) * m2 == a c* (m1 * m2).
Proof. intros. apply mcmul_mul. Qed.

Lemma mmul_mcmul : forall {r c s} a (m1 : mat r c) (m2 : mat c s),
    m1 * (a c* m2) == a c* (m1 * m2).
Proof. intros. apply mmul_mcmul. Qed.

Definition Square n := mat n n.

Definition trace {n} (m : Square n) := trace m (add:=Rplus) (zero:=0).

Definition t2m_1x1 a11 : mat 1 1 := t2m_1x1 (A0:=0) a11.

Definition m2t_1x1 (m : mat 1 1) := m2t_1x1 m.

Definition t2m_2x2 (t : T_2x2) : mat 2 2 := t2m_2x2 (A0:=0) t.

Definition m2t_2x2 (m : mat 2 2) := m2t_2x2 m.

Definition t2m_3x3 (t : T_3x3) : mat 3 3 := t2m_3x3 (A0:=0) t.

Definition m2t_3x3 (m : mat 3 3) := m2t_3x3 m.

(* ################################################################# *)
(** ** 新增的 实数矩阵理论 *)

(** 3阶方阵的行列式 *)
Definition det3 (m : mat 3 3) :=
  let '((a11,a12,a13),(a21,a22,a23),(a31,a32,a33)) :=
    m2t_3x3 m in
  (let b1 := (a11 * a22 * a33) in
  let b2 := (a12 * a23 * a31) in
  let b3 := (a13 * a21 * a32) in
  let c1 := (a11 * a23 * a32) in
  let c2 := (a12 * a21 * a33) in
  let c3 := (a13 * a22 * a31) in
  let b := (b1 + b2 + b3) in
  let c := (c1 + c2 + c3) in
  (b - c))%R.


Require Import Axioms.
Require Import Tactics.
Require Import Sigma.
Require Import Equality.
Require Import Relation.
Require Import Syntax.
Require Import Ofe.
Require Import Uniform.
Require Import Spaces.
Require Import Dynamic.
Require Import Hygiene.
Require Import Equivalence.
Require Import Intensional.
Require Import Ordinal.
Require Import Candidate.
Require Import System.
Require Import MapTerm.
Require Import Extend.
Require Import Model.
Require Import Standard.
Require Import Truncate.
Require Import Equivalences.
Require Import Ceiling.
Require Import SemanticsProperty.

Definition subtype_property w (R R' : wurel w) : nat -> Prop
  :=
  fun j =>
    forall k m p,
      k <= j
      -> rel R k m p
      -> rel R' k m p.

Lemma subtype_property_downward :
  forall w R R' j,
    subtype_property w R R' (S j)
    -> subtype_property w R R' j.
Proof.
unfold subtype_property.
intros w R R' j Hsub.
intros k m p Hk Hmp.
apply Hsub; auto.
Qed.

Definition subtype_urel w i (R R' : wurel w) : wurel w :=
  property_urel (subtype_property w R R') w i (subtype_property_downward w R R').

Definition iusubtype w i (R R' : wiurel w) : wiurel w
  :=
  (subtype_urel w i (den R) (den R'),
   meta_pair
     (meta_iurel R)
     (meta_iurel R')).

Lemma iusubtype_inj :
  forall w i R1 R1' R2 R2',
    iusubtype w i R1 R2 = iusubtype w i R1' R2'
    -> R1 = R1' /\ R2 = R2'.
Proof.
intros w i R1 R1' R2 R2' Heq.
so (f_equal snd Heq) as Heq'.
cbn in Heq'.
so (meta_pair_inj _#5 Heq') as (Heq1 & Heq2).
split.
  {
  eapply meta_iurel_inj; eauto.
  }

  {
  eapply meta_iurel_inj; eauto.
  }
Qed.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model PPC *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition X := unknown_set "X".
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition cobase := co0.
Variable co : relation events.
Definition coi := co ⊓ int.
Definition coe := co ⊓ !coi.
Definition fr := rf° ⋅ co ⊓ !id.
Definition fri := fr ⊓ int.
Definition fre := fr ⊓ !fri.
Definition scperlocation := acyclic (po_loc ⊔ (rf ⊔ (fr ⊔ co))).
Definition atomic := is_empty (rmw ⊓ fre ⋅ coe).
Definition dd := addr ⊔ data.
Definition rdw := po_loc ⊓ fre ⋅ rfe.
Definition detour := po_loc ⊓ coe ⋅ rfe.
Definition addrpo := addr ⋅ po.
Definition sync : relation events := (*failed: try fencerel SYNC with 0*) 0.
Definition lwsync : relation events := (*failed: try fencerel LWSYNC with 0*) 0.
Definition eieio : relation events := (*failed: try fencerel EIEIO with 0*) 0.
Definition isync : relation events := (*failed: try fencerel ISYNC with 0*) 0.
Definition ctrlisync : relation events := (*failed: try ctrlcfence ISYNC with 0*) 0.
Definition ci0 := ctrlisync ⊔ detour.
Definition ii0 := dd ⊔ (rfi ⊔ rdw).
Definition cc0 := dd ⊔ (po_loc ⊔ (ctrl ⊔ addrpo)).
Definition ic0 : relation events := 0.
Inductive ci : relation _ := ci_c : incl (ci0 ⊔ (ci ⋅ ii ⊔ cc ⋅ ci)) ci
     with ii : relation _ := ii_c : incl (ii0 ⊔ (ci ⊔ (ic ⋅ ci ⊔ ii ⋅ ii))) ii
     with cc : relation _ := cc_c : incl (cc0 ⊔ (ci ⊔ (ci ⋅ ic ⊔ cc ⋅ cc))) cc
     with ic : relation _ := ic_c : incl (ic0 ⊔ (ii ⊔ (cc ⊔ (ic ⋅ cc ⊔ ii ⋅ ic)))) ic.
Section scheme.
Variables ci' ii' cc' ic' : relation events.
Variable Hci' : incl (ci0 ⊔ (ci' ⋅ ii' ⊔ cc' ⋅ ci')) ci'.
Variable Hii' : incl (ii0 ⊔ (ci' ⊔ (ic' ⋅ ci' ⊔ ii' ⋅ ii'))) ii'.
Variable Hcc' : incl (cc0 ⊔ (ci' ⊔ (ci' ⋅ ic' ⊔ cc' ⋅ cc'))) cc'.
Variable Hic' : incl (ic0 ⊔ (ii' ⊔ (cc' ⊔ (ic' ⋅ cc' ⊔ ii' ⋅ ic')))) ic'.

  Fixpoint ci_ind' x y (r : ci x y) : ci' x y
      with ii_ind' x y (r : ii x y) : ii' x y
      with cc_ind' x y (r : cc x y) : cc' x y
      with ic_ind' x y (r : ic x y) : ic' x y.
  Proof.
    destruct r as [x y r]; apply Hci'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      destruct r as [x_y r1 r2]; exists x_y.
       apply ci_ind'; exact r1.
       apply ii_ind'; exact r2.
      destruct r as [x_y r1 r2]; exists x_y.
       apply cc_ind'; exact r1.
       apply ci_ind'; exact r2.
    destruct r as [x y r]; apply Hii'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ci_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       destruct r as [x_y r1 r2]; exists x_y.
        apply ic_ind'; exact r1.
        apply ci_ind'; exact r2.
       destruct r as [x_y r1 r2]; exists x_y.
        apply ii_ind'; exact r1.
        apply ii_ind'; exact r2.
    destruct r as [x y r]; apply Hcc'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ci_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       destruct r as [x_y r1 r2]; exists x_y.
        apply ci_ind'; exact r1.
        apply ic_ind'; exact r2.
       destruct r as [x_y r1 r2]; exists x_y.
        apply cc_ind'; exact r1.
        apply cc_ind'; exact r2.
    destruct r as [x y r]; apply Hic'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ii_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       apply cc_ind'; exact r.
       destruct r as [r | r]; [ left | right ].
        destruct r as [x_y r1 r2]; exists x_y.
         apply ic_ind'; exact r1.
         apply cc_ind'; exact r2.
        destruct r as [x_y r1 r2]; exists x_y.
         apply ii_ind'; exact r1.
         apply ic_ind'; exact r2.
  Qed.
End scheme.
Definition ppo := let ppoR := ii ⊓ [R] ⋅ top ⋅ [R] in let ppoW := ic ⊓ [R] ⋅ top ⋅ [W] in ppoR ⊔ ppoW.
Definition lwsync_0 := lwsync ⊓ !([W] ⋅ top ⋅ [R]).
Definition eieio_0 := eieio ⊓ [W] ⋅ top ⋅ [W].
Definition strong := sync.
Definition light := lwsync_0 ⊔ eieio_0.
Definition fence := strong ⊔ light.
Definition hb := ppo ⊔ (fence ⊔ rfe).
Definition thinair := acyclic hb.
Definition hbstar := hb^*.
Definition propbase := (fence ⊔ rfe ⋅ fence) ⋅ hbstar.
Definition chapo := rfe ⊔ (fre ⊔ (coe ⊔ (fre ⋅ rfe ⊔ coe ⋅ rfe))).
Definition prop := propbase ⊓ [W] ⋅ top ⋅ [W] ⊔ (chapo ⊔ 1) ⋅ (propbase^* ⋅ (strong ⋅ hbstar)).
Definition propagation := acyclic (co ⊔ prop).
Definition observation := irreflexive (fre ⋅ (prop ⋅ hbstar)).
Definition xx := po ⊓ [X] ⋅ top ⋅ [X].
Definition scXX := acyclic (co ⊔ xx).
Definition witness_conditions := generate_cos cobase co.
Definition model_conditions := scperlocation /\ (atomic /\ (thinair /\ (propagation /\ (observation /\ scXX)))).
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc X tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW generate_orders generate_cos cobase coi coe fr fri fre scperlocation atomic dd rdw detour addrpo sync lwsync eieio isync ctrlisync ci0 ii0 cc0 ic0 ppo lwsync_0 eieio_0 strong light fence hb thinair hbstar propbase chapo prop propagation observation xx scXX witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    model_conditions c co.

(* End of translation of model PPC *)


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Limit.
Require Export Category.Instance.Parallel.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Definition Equalizer {C : Category} (F : Parallel ⟶ C) := Limit F.

Definition Coequalizer {C : Category} (F : Parallel ⟶ C) := Colimit F.


(* Not considering singleton template-polymorphic inductive types as
   propositions for injection/inversion *)

(* This is also #4560 and #6273 *)

Inductive foo := foo_1.

Goal forall (a b : foo), Some a = Some b -> a = b.
Proof.
  intros a b H.
  inversion H.
  reflexivity.
Qed.

(* Check that Prop is not concerned *)

Inductive bar : Prop := bar_1.

Goal
  forall (a b : bar),
    Some a = Some b ->
    a = b.
Proof.
  intros a b H.
  inversion H.
  Fail reflexivity.
Abort.