(* 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.

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

(* Why3 assumption *)
Definition state := (map.Map.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.Map.map id Z)) (e:aexpr) {struct e}: Z :=
  match e with
  | (Anum n) => n
  | (Avar x) => (map.Map.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.Map.map id Z) -> bexpr -> bool.

Axiom beval_def : forall (st:(map.Map.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.Map.map id Z) -> com -> (map.Map.map id Z) -> Prop :=
  | E_Skip : forall (m:(map.Map.map id Z)), (ceval m Cskip m)
  | E_Ass : forall (m:(map.Map.map id Z)) (a:aexpr) (x:id), (ceval m
      (Cassign x a) (map.Map.set m x (aeval m a)))
  | E_Seq : forall (cmd1:com) (cmd2:com) (m0:(map.Map.map id Z))
      (m1:(map.Map.map id Z)) (m2:(map.Map.map id Z)), (ceval m0 cmd1 m1) ->
      ((ceval m1 cmd2 m2) -> (ceval m0 (Cseq cmd1 cmd2) m2))
  | E_IfTrue : forall (m0:(map.Map.map id Z)) (m1:(map.Map.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.Map.map id Z)) (m1:(map.Map.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.Map.map id Z)) (body:com),
      (~ ((beval m cond) = true)) -> (ceval m (Cwhile cond body) m)
  | E_WhileLoop : forall (mi:(map.Map.map id Z)) (mj:(map.Map.map id Z))
      (mf:(map.Map.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.Map.map id Z))
  (mf1:(map.Map.map id Z)), (ceval mi c mf1) -> forall (mf2:(map.Map.map id
  Z)), (ceval mi c mf2) -> (mf1 = mf2).

Axiom ceval_deterministic : forall (c:com) (mi:(map.Map.map id Z))
  (mf1:(map.Map.map id Z)) (mf2:(map.Map.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.Map.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.Map.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.Map.map id Z)), (transition c
      (VMS p s m) (VMS (p + 1%Z)%Z (Init.Datatypes.cons (map.Map.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.Map.map id Z)),
      (transition c (VMS p (Init.Datatypes.cons n s) m) (VMS (p + 1%Z)%Z s
      (map.Map.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.Map.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.Map.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.Map.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.Map.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.Map.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.Map.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.Map.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.Map.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.Map.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.Map.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.Map.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.Map.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.Map.map id Z))
  (mf:(map.Map.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.Map.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.Map.map id Z)), (ms = (VMS p s
  m)) -> (ms' = (VMS (p + 1%Z)%Z (Init.Datatypes.cons (map.Map.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 (map.Map.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.Map.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.Map.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.Map.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.Map.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.Map.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.Map.map id Z)), (ms = (VMS p (Init.Datatypes.cons n s) m)) ->
  (ms' = (VMS (p + 1%Z)%Z s (map.Map.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 (map.Map.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.Map.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.Map.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,1.01," 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.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Coq - Calculus of Inductive Constructions V5.10           *)
(*****************************************************************************)
(*                                                                           *)
(*          Category Product : Projection Functors                           *)
(*                                                                           *)
(*          Amokrane Saibi,  May 1994                                        *)
(*                                                                           *)
(*****************************************************************************)

Require Export PROD.
Require Export Functor.

Set Implicit Arguments.
Unset Strict Implicit.

(* Projection Functors *)

Section prod_proj.

Variable A B : Category.

(* Fst *)

Lemma Fst_map_law : forall a b : PROD A B, Map_law (Hom_l (u:=a) (t:=b)).
Proof.
unfold Map_law in |- *.
intros a b; unfold Equal at 1 in |- *; simpl in |- *.
unfold Equal_Pmor in |- *; intros f g H.
elim H; intros; assumption.
Qed.

Canonical Structure Fst_map (a b : PROD A B) :=
  Build_Map (Fst_map_law (a:=a) (b:=b)).

Lemma Fst_comp_law : Fcomp_law Fst_map.
Proof.
unfold Fcomp_law in |- *; simpl in |- *.
intros a b c f g.
apply Refl.
Qed.

Lemma Fst_id_law : Fid_law Fst_map.
Proof.
unfold Fid_law in |- *; simpl in |- *.
intro a; apply Refl.
Qed.

Canonical Structure Fst := Build_Functor Fst_comp_law Fst_id_law.

(* Snd *)

Lemma Snd_map_law : forall a b : PROD A B, Map_law (Hom_r (u:=a) (t:=b)).
Proof.
unfold Map_law in |- *.
intros a b; unfold Equal at 1 in |- *; simpl in |- *.
unfold Equal_Pmor in |- *; intros f g H.
elim H; intros; assumption.
Qed.

Canonical Structure Snd_map (a b : PROD A B) :=
  Build_Map (Snd_map_law (a:=a) (b:=b)).

Lemma Snd_comp_law : Fcomp_law Snd_map.
Proof.
unfold Fcomp_law in |- *; simpl in |- *.
intros a b c f g.
apply Refl.
Qed.

Lemma Snd_id_law : Fid_law Snd_map.
Proof.
unfold Fid_law in |- *; simpl in |- *.
intro a; apply Refl.
Qed.

Canonical Structure Snd := Build_Functor Snd_comp_law Snd_id_law.

End prod_proj.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This files implements an efficient implementation of finite maps whose keys
range over Coq's data type of positive binary naturals [positive]. The
implementation is based on Xavier Leroy's implementation of radix-2 search
trees (uncompressed Patricia trees) and guarantees logarithmic-time operations.
However, we extend Leroy's implementation by packing the trees into a Sigma
type such that canonicity of representation is ensured. This is necesarry for
Leibniz equality to become extensional. *)
From Coq Require Import PArith.
From prelude Require Import mapset.
From prelude Require Export fin_maps.

Local Open Scope positive_scope.
Local Hint Extern 0 (@eq positive _ _) => congruence.
Local Hint Extern 0 (¬@eq positive _ _) => congruence.

(** * The tree data structure *)
(** The data type [Pmap_raw] specifies radix-2 search trees. These trees do
not ensure canonical representations of maps. For example the empty map can
be represented as a binary tree of an arbitrary size that contains [None] at
all nodes. *)
Inductive Pmap_raw (A : Type) : Type :=
  | PLeaf: Pmap_raw A
  | PNode: option A → Pmap_raw A → Pmap_raw A → Pmap_raw A.
Arguments PLeaf {_}.
Arguments PNode {_} _ _ _.

Instance Pmap_raw_eq_dec `{∀ x y : A, Decision (x = y)} (x y : Pmap_raw A) :
  Decision (x = y).
Proof. solve_decision. Defined.

Fixpoint Pmap_wf {A} (t : Pmap_raw A) : bool :=
  match t with
  | PLeaf => true
  | PNode None PLeaf PLeaf => false
  | PNode _ l r => Pmap_wf l && Pmap_wf r
  end.
Arguments Pmap_wf _ !_ / : simpl nomatch.
Lemma Pmap_wf_l {A} o (l r : Pmap_raw A) : Pmap_wf (PNode o l r) → Pmap_wf l.
Proof. destruct o, l, r; simpl; rewrite ?andb_True; tauto. Qed.
Lemma Pmap_wf_r {A} o (l r : Pmap_raw A) : Pmap_wf (PNode o l r) → Pmap_wf r.
Proof. destruct o, l, r; simpl; rewrite ?andb_True; tauto. Qed.
Local Hint Immediate Pmap_wf_l Pmap_wf_r.
Definition PNode' {A} (o : option A) (l r : Pmap_raw A) :=
  match l, o, r with PLeaf, None, PLeaf => PLeaf | _, _, _ => PNode o l r end.
Arguments PNode' _ _ _ _ : simpl never.
Lemma PNode_wf {A} o (l r : Pmap_raw A) :
  Pmap_wf l → Pmap_wf r → Pmap_wf (PNode' o l r).
Proof. destruct o, l, r; simpl; auto. Qed.
Local Hint Resolve PNode_wf.

(** Operations *)
Instance Pempty_raw {A} : Empty (Pmap_raw A) := PLeaf.
Instance Plookup_raw {A} : Lookup positive A (Pmap_raw A) :=
  fix go (i : positive) (t : Pmap_raw A) {struct t} : option A :=
  let _ : Lookup _ _ _ := @go in
  match t with
  | PLeaf => None
  | PNode o l r => match i with 1 => o | i~0 => l !! i | i~1 => r !! i end
  end.
Local Arguments lookup _ _ _ _ _ !_ / : simpl nomatch.
Fixpoint Psingleton_raw {A} (i : positive) (x : A) : Pmap_raw A :=
  match i with
  | 1 => PNode (Some x) PLeaf PLeaf
  | i~0 => PNode None (Psingleton_raw i x) PLeaf
  | i~1 => PNode None PLeaf (Psingleton_raw i x)
  end.
Fixpoint Ppartial_alter_raw {A} (f : option A → option A)
    (i : positive) (t : Pmap_raw A) {struct t} : Pmap_raw A :=
  match t with
  | PLeaf => match f None with None => PLeaf | Some x => Psingleton_raw i x end
  | PNode o l r =>
     match i with
     | 1 => PNode' (f o) l r
     | i~0 => PNode' o (Ppartial_alter_raw f i l) r
     | i~1 => PNode' o l (Ppartial_alter_raw f i r)
     end
  end.
Fixpoint Pfmap_raw {A B} (f : A → B) (t : Pmap_raw A) : Pmap_raw B :=
  match t with
  | PLeaf => PLeaf
  | PNode o l r => PNode (f <$> o) (Pfmap_raw f l) (Pfmap_raw f r)
  end.
Fixpoint Pto_list_raw {A} (j : positive) (t : Pmap_raw A)
    (acc : list (positive * A)) : list (positive * A) :=
  match t with
  | PLeaf => acc
  | PNode o l r => default [] o (λ x, [(Preverse j, x)]) ++
     Pto_list_raw (j~0) l (Pto_list_raw (j~1) r acc)
  end%list.
Fixpoint Pomap_raw {A B} (f : A → option B) (t : Pmap_raw A) : Pmap_raw B :=
  match t with
  | PLeaf => PLeaf
  | PNode o l r => PNode' (o ≫= f) (Pomap_raw f l) (Pomap_raw f r)
  end.
Fixpoint Pmerge_raw {A B C} (f : option A → option B → option C)
    (t1 : Pmap_raw A) (t2 : Pmap_raw B) : Pmap_raw C :=
  match t1, t2 with
  | PLeaf, t2 => Pomap_raw (f None ∘ Some) t2
  | t1, PLeaf => Pomap_raw (flip f None ∘ Some) t1
  | PNode o1 l1 r1, PNode o2 l2 r2 =>
      PNode' (f o1 o2) (Pmerge_raw f l1 l2) (Pmerge_raw f r1 r2)
  end.

(** Proofs *)
Lemma Pmap_wf_canon {A} (t : Pmap_raw A) :
  (∀ i, t !! i = None) → Pmap_wf t → t = PLeaf.
Proof.
  induction t as [|o l IHl r IHr]; intros Ht ?; auto.
  assert (o = None) as -> by (apply (Ht 1)).
  assert (l = PLeaf) as -> by (apply IHl; try apply (λ i, Ht (i~0)); eauto).
  by assert (r = PLeaf) as -> by (apply IHr; try apply (λ i, Ht (i~1)); eauto).
Qed.
Lemma Pmap_wf_eq {A} (t1 t2 : Pmap_raw A) :
  (∀ i, t1 !! i = t2 !! i) → Pmap_wf t1 → Pmap_wf t2 → t1 = t2.
Proof.
  revert t2.
  induction t1 as [|o1 l1 IHl r1 IHr]; intros [|o2 l2 r2] Ht ??; simpl; auto.
  - discriminate (Pmap_wf_canon (PNode o2 l2 r2)); eauto.
  - discriminate (Pmap_wf_canon (PNode o1 l1 r1)); eauto.
  - f_equal; [apply (Ht 1)| |].
    + apply IHl; try apply (λ x, Ht (x~0)); eauto.
    + apply IHr; try apply (λ x, Ht (x~1)); eauto.
Qed.
Lemma PNode_lookup {A} o (l r : Pmap_raw A) i :
  PNode' o l r !! i = PNode o l r !! i.
Proof. by destruct i, o, l, r. Qed.

Lemma Psingleton_wf {A} i (x : A) : Pmap_wf (Psingleton_raw i x).
Proof. induction i as [[]|[]|]; simpl; rewrite ?andb_true_r; auto. Qed.
Lemma Ppartial_alter_wf {A} f i (t : Pmap_raw A) :
  Pmap_wf t → Pmap_wf (Ppartial_alter_raw f i t).
Proof.
  revert i; induction t as [|o l IHl r IHr]; intros i ?; simpl.
  - destruct (f None); auto using Psingleton_wf.
  - destruct i; simpl; eauto.
Qed.
Lemma Pfmap_wf {A B} (f : A → B) t : Pmap_wf t → Pmap_wf (Pfmap_raw f t).
Proof.
  induction t as [|[x|] [] ? [] ?]; simpl in *; rewrite ?andb_True; intuition.
Qed.
Lemma Pomap_wf {A B} (f : A → option B) t : Pmap_wf t → Pmap_wf (Pomap_raw f t).
Proof. induction t; simpl; eauto. Qed.
Lemma Pmerge_wf {A B C} (f : option A → option B → option C) t1 t2 :
  Pmap_wf t1 → Pmap_wf t2 → Pmap_wf (Pmerge_raw f t1 t2).
Proof. revert t2. induction t1; intros []; simpl; eauto using Pomap_wf. Qed.

Lemma Plookup_empty {A} i : (∅ : Pmap_raw A) !! i = None.
Proof. by destruct i. Qed.
Lemma Plookup_singleton {A} i (x : A) : Psingleton_raw i x !! i = Some x.
Proof. by induction i. Qed.
Lemma Plookup_singleton_ne {A} i j (x : A) :
  i ≠ j → Psingleton_raw i x !! j = None.
Proof. revert j. induction i; intros [?|?|]; simpl; auto with congruence. Qed.
Lemma Plookup_alter {A} f i (t : Pmap_raw A) :
  Ppartial_alter_raw f i t !! i = f (t !! i).
Proof.
  revert i; induction t as [|o l IHl r IHr]; intros i; simpl.
  - by destruct (f None); rewrite ?Plookup_singleton.
  - destruct i; simpl; rewrite PNode_lookup; simpl; auto.
Qed.
Lemma Plookup_alter_ne {A} f i j (t : Pmap_raw A) :
  i ≠ j → Ppartial_alter_raw f i t !! j = t !! j.
Proof.
  revert i j; induction t as [|o l IHl r IHr]; simpl.
  - by intros; destruct (f None); rewrite ?Plookup_singleton_ne.
  - by intros [?|?|] [?|?|] ?; simpl; rewrite ?PNode_lookup; simpl; auto.
Qed.
Lemma Plookup_fmap {A B} (f : A → B) t i : (Pfmap_raw f t) !! i = f <$> t !! i.
Proof. revert i. by induction t; intros [?|?|]; simpl. Qed.
Lemma Pelem_of_to_list {A} (t : Pmap_raw A) j i acc x :
  (i,x) ∈ Pto_list_raw j t acc ↔
    (∃ i', i = i' ++ Preverse j ∧ t !! i' = Some x) ∨ (i,x) ∈ acc.
Proof.
  split.
  { revert j acc. induction t as [|[y|] l IHl r IHr]; intros j acc; simpl.
    - by right.
    - rewrite elem_of_cons. intros [?|?]; simplify_eq.
      { left; exists 1. by rewrite (left_id_L 1 (++))%positive. }
      destruct (IHl (j~0) (Pto_list_raw j~1 r acc)) as [(i'&->&?)|?]; auto.
      { left; exists (i' ~ 0). by rewrite Preverse_xO, (assoc_L _). }
      destruct (IHr (j~1) acc) as [(i'&->&?)|?]; auto.
      left; exists (i' ~ 1). by rewrite Preverse_xI, (assoc_L _).
    - intros.
      destruct (IHl (j~0) (Pto_list_raw j~1 r acc)) as [(i'&->&?)|?]; auto.
      { left; exists (i' ~ 0). by rewrite Preverse_xO, (assoc_L _). }
      destruct (IHr (j~1) acc) as [(i'&->&?)|?]; auto.
      left; exists (i' ~ 1). by rewrite Preverse_xI, (assoc_L _). }
  revert t j i acc. assert (∀ t j i acc,
    (i, x) ∈ acc → (i, x) ∈ Pto_list_raw j t acc) as help.
  { intros t; induction t as [|[y|] l IHl r IHr]; intros j i acc;
      simpl; rewrite ?elem_of_cons; auto. }
  intros t j ? acc [(i&->&Hi)|?]; [|by auto]. revert j i acc Hi.
  induction t as [|[y|] l IHl r IHr]; intros j i acc ?; simpl.
  - done.
  - rewrite elem_of_cons. destruct i as [i|i|]; simplify_eq/=.
    + right. apply help. specialize (IHr (j~1) i).
      rewrite Preverse_xI, (assoc_L _) in IHr. by apply IHr.
    + right. specialize (IHl (j~0) i).
      rewrite Preverse_xO, (assoc_L _) in IHl. by apply IHl.
    + left. by rewrite (left_id_L 1 (++))%positive.
  - destruct i as [i|i|]; simplify_eq/=.
    + apply help. specialize (IHr (j~1) i).
      rewrite Preverse_xI, (assoc_L _) in IHr. by apply IHr.
    + specialize (IHl (j~0) i).
      rewrite Preverse_xO, (assoc_L _) in IHl. by apply IHl.
Qed.
Lemma Pto_list_nodup {A} j (t : Pmap_raw A) acc :
  (∀ i x, (i ++ Preverse j, x) ∈ acc → t !! i = None) →
  NoDup acc → NoDup (Pto_list_raw j t acc).
Proof.
  revert j acc. induction t as [|[y|] l IHl r IHr]; simpl; intros j acc Hin ?.
  - done.
  - repeat constructor.
    { rewrite Pelem_of_to_list. intros [(i&Hi&?)|Hj].
      { apply (f_equal Plength) in Hi.
        rewrite Preverse_xO, !Papp_length in Hi; simpl in *; lia. }
      rewrite Pelem_of_to_list in Hj. destruct Hj as [(i&Hi&?)|Hj].
      { apply (f_equal Plength) in Hi.
        rewrite Preverse_xI, !Papp_length in Hi; simpl in *; lia. }
      specialize (Hin 1 y). rewrite (left_id_L 1 (++))%positive in Hin.
      discriminate (Hin Hj). }
    apply IHl.
    { intros i x. rewrite Pelem_of_to_list. intros [(?&Hi&?)|Hi].
      + rewrite Preverse_xO, Preverse_xI, !(assoc_L _) in Hi.
        by apply (inj (++ _)) in Hi.
      + apply (Hin (i~0) x). by rewrite Preverse_xO, (assoc_L _) in Hi. }
    apply IHr; auto. intros i x Hi.
    apply (Hin (i~1) x). by rewrite Preverse_xI, (assoc_L _) in Hi.
  - apply IHl.
    { intros i x. rewrite Pelem_of_to_list. intros [(?&Hi&?)|Hi].
      + rewrite Preverse_xO, Preverse_xI, !(assoc_L _) in Hi.
        by apply (inj (++ _)) in Hi.
      + apply (Hin (i~0) x). by rewrite Preverse_xO, (assoc_L _) in Hi. }
    apply IHr; auto. intros i x Hi.
    apply (Hin (i~1) x). by rewrite Preverse_xI, (assoc_L _) in Hi.
Qed.
Lemma Pomap_lookup {A B} (f : A → option B) t i :
  Pomap_raw f t !! i = t !! i ≫= f.
Proof.
  revert i. induction t as [|o l IHl r IHr]; intros [i|i|]; simpl;
    rewrite ?PNode_lookup; simpl; auto.
Qed.
Lemma Pmerge_lookup {A B C} (f : option A → option B → option C)
    (Hf : f None None = None) t1 t2 i :
  Pmerge_raw f t1 t2 !! i = f (t1 !! i) (t2 !! i).
Proof.
  revert t2 i; induction t1 as [|o1 l1 IHl1 r1 IHr1]; intros t2 i; simpl.
  { rewrite Pomap_lookup. by destruct (t2 !! i). }
  unfold compose, flip.
  destruct t2 as [|l2 o2 r2]; rewrite PNode_lookup.
  - by destruct i; rewrite ?Pomap_lookup; simpl; rewrite ?Pomap_lookup;
      match goal with |- ?o ≫= _ = _ => destruct o end.
  - destruct i; rewrite ?Pomap_lookup; simpl; auto.
Qed.

(** Packed version and instance of the finite map type class *)
Inductive Pmap (A : Type) : Type :=
  PMap { pmap_car : Pmap_raw A; pmap_prf : Pmap_wf pmap_car }.
Arguments PMap {_} _ _.
Arguments pmap_car {_} _.
Arguments pmap_prf {_} _.
Lemma Pmap_eq {A} (m1 m2 : Pmap A) : m1 = m2 ↔ pmap_car m1 = pmap_car m2.
Proof.
  split; [by intros ->|intros]; destruct m1 as [t1 ?], m2 as [t2 ?].
  simplify_eq/=; f_equal; apply proof_irrel.
Qed.
Instance Pmap_eq_dec `{∀ x y : A, Decision (x = y)}
    (m1 m2 : Pmap A) : Decision (m1 = m2) :=
  match Pmap_raw_eq_dec (pmap_car m1) (pmap_car m2) with
  | left H => left (proj2 (Pmap_eq m1 m2) H)
  | right H => right (H ∘ proj1 (Pmap_eq m1 m2))
  end.
Instance Pempty {A} : Empty (Pmap A) := PMap ∅ I.
Instance Plookup {A} : Lookup positive A (Pmap A) := λ i m, pmap_car m !! i.
Instance Ppartial_alter {A} : PartialAlter positive A (Pmap A) := λ f i m,
  let (t,Ht) := m in PMap (partial_alter f i t) (Ppartial_alter_wf f i _ Ht).
Instance Pfmap : FMap Pmap := λ A B f m,
  let (t,Ht) := m in PMap (f <$> t) (Pfmap_wf f _ Ht).
Instance Pto_list {A} : FinMapToList positive A (Pmap A) := λ m,
  let (t,Ht) := m in Pto_list_raw 1 t [].
Instance Pomap : OMap Pmap := λ A B f m,
  let (t,Ht) := m in PMap (omap f t) (Pomap_wf f _ Ht).
Instance Pmerge : Merge Pmap := λ A B C f m1 m2,
  let (t1,Ht1) := m1 in let (t2,Ht2) := m2 in PMap _ (Pmerge_wf f _ _ Ht1 Ht2).

Instance Pmap_finmap : FinMap positive Pmap.
Proof.
  split.
  - by intros ? [t1 ?] [t2 ?] ?; apply Pmap_eq, Pmap_wf_eq.
  - by intros ? [].
  - intros ?? [??] ?. by apply Plookup_alter.
  - intros ?? [??] ??. by apply Plookup_alter_ne.
  - intros ??? [??]. by apply Plookup_fmap.
  - intros ? [??]. apply Pto_list_nodup; [|constructor].
    intros ??. by rewrite elem_of_nil.
  - intros ? [??] i x; unfold map_to_list, Pto_list.
    rewrite Pelem_of_to_list, elem_of_nil.
    split. by intros [(?&->&?)|]. by left; exists i.
  - intros ?? ? [??] ?. by apply Pomap_lookup.
  - intros ??? ?? [??] [??] ?. by apply Pmerge_lookup.
Qed.

(** * Finite sets *)
(** We construct sets of [positives]s satisfying extensional equality. *)
Notation Pset := (mapset Pmap).
Instance Pmap_dom {A} : Dom (Pmap A) Pset := mapset_dom.
Instance: FinMapDom positive Pmap Pset := mapset_dom_spec.

(** * Fresh numbers *)
Fixpoint Pdepth {A} (m : Pmap_raw A) : nat :=
  match m with
  | PLeaf | PNode None _ _ => O | PNode _ l _ => S (Pdepth l)
  end.
Fixpoint Pfresh_at_depth {A} (m : Pmap_raw A) (d : nat) : option positive :=
  match d, m with
  | O, (PLeaf | PNode None _ _) => Some 1
  | S d, PNode _ l r =>
     match Pfresh_at_depth l d with
     | Some i => Some (i~0) | None => (~1) <$> Pfresh_at_depth r d
     end
  | _, _ => None
  end.
Fixpoint Pfresh_go {A} (m : Pmap_raw A) (d : nat) : option positive :=
  match d with
  | O => None
  | S d =>
     match Pfresh_go m d with
     | Some i => Some i | None => Pfresh_at_depth m d
     end
  end.
Definition Pfresh {A} (m : Pmap A) : positive :=
  let d := Pdepth (pmap_car m) in
  match Pfresh_go (pmap_car m) d with
  | Some i => i | None => Pos.shiftl_nat 1 d
  end.

Lemma Pfresh_at_depth_fresh {A} (m : Pmap_raw A) d i :
  Pfresh_at_depth m d = Some i → m !! i = None.
Proof.
  revert i m; induction d as [|d IH].
  { intros i [|[] l r] ?; naive_solver. }
  intros i [|o l r] ?; simplify_eq/=.
  destruct (Pfresh_at_depth l d) as [i'|] eqn:?,
    (Pfresh_at_depth r d) as [i''|] eqn:?; simplify_eq/=; auto.
Qed.
Lemma Pfresh_go_fresh {A} (m : Pmap_raw A) d i :
  Pfresh_go m d = Some i → m !! i = None.
Proof.
  induction d as [|d IH]; intros; simplify_eq/=.
  destruct (Pfresh_go m d); eauto using Pfresh_at_depth_fresh.
Qed.
Lemma Pfresh_depth {A} (m : Pmap_raw A) :
  m !! Pos.shiftl_nat 1 (Pdepth m) = None.
Proof. induction m as [|[x|] l IHl r IHr]; auto. Qed.
Lemma Pfresh_fresh {A} (m : Pmap A) : m !! Pfresh m = None.
Proof.
  destruct m as [m ?]; unfold lookup, Plookup, Pfresh; simpl.
  destruct (Pfresh_go m _) eqn:?; eauto using Pfresh_go_fresh, Pfresh_depth.
Qed.

Instance Pset_fresh : Fresh positive Pset := λ X,
  let (m) := X in Pfresh m.
Instance Pset_fresh_spec : FreshSpec positive Pset.
Proof.
  split.
  - apply _.
  - intros X Y; rewrite <-elem_of_equiv_L. by intros ->.
  - unfold elem_of, mapset_elem_of, fresh; intros [m]; simpl.
    by rewrite Pfresh_fresh.
Qed.


Require Import Common.Common.
Require Import LogRel.PseudoType.
Require Import LogRel.LemmasPseudoType.
Require Import LogRel.LR.
Require Import LogRel.LemmasLR.
Require Import LogRel.LemmasIntro.
Require Import Stlc.SpecSyntax.
Require Import Stlc.CanForm.
Require Import Stlc.SpecEvaluation.
Require Import Stlc.LemmasEvaluation.
Require Import Stlc.LemmasTyping.
Require Import Stlc.SpecTyping.
Require Import Utlc.SpecSyntax.
Require Import Utlc.SpecEvaluation.
Require Import Utlc.LemmasEvaluation.
Require Import Utlc.Inst.
Require Import UVal.UVal.

Require Import Omega.
Require Import Min.

Section ValrelInversion.

  Local Ltac crush :=
    repeat
      (cbn in * |-; cbn;
       try assumption;
       crushOfType;
       repeat crushTyping;
       repeat crushStlcSyntaxMatchH;
       repeat crushUtlcSyntaxMatchH;
       repeat crushUtlcScopingMatchH;
       repeat crushDbSyntaxMatchH;
       try subst;
       destruct_conjs;
       repeat match goal with
                  [ |- _ ∧ _ ] => split
              end;
       eauto
      );
    try discriminate;
    eauto with eval;
    try omega.

  Lemma valrel_ptunit_inversion {d w vs vu} :
    valrel d w ptunit vs vu →
    vs = S.unit ∧ vu = U.unit.
  Proof.
    rewrite valrel_fixp; unfold valrel'.
    tauto.
  Qed.

  Lemma valrel_ptbool_inversion {d w vs vu} :
    valrel d w ptbool vs vu →
    (vs = S.true ∧ vu = U.true) ∨ (vs = S.false ∧ vu = U.false).
  Proof.
    rewrite valrel_fixp; unfold valrel'.
    crush.
  Qed.

  Lemma valrel_ptprod_inversion {d w τ₁ τ₂ vs vu} :
    valrel d w (ptprod τ₁ τ₂) vs vu →
    exists vs₁ vs₂ vu₁ vu₂,
      (vs = S.pair vs₁ vs₂ ∧ vu = U.pair vu₁ vu₂ ∧
       OfType τ₁ vs₁ vu₁ ∧
       OfType τ₂ vs₂ vu₂ ∧
       ∀ w', w' < w → valrel d w' τ₁ vs₁ vu₁ ∧ valrel d w' τ₂ vs₂ vu₂).
  Proof.
    intros vr.
    destruct (OfType_inversion_ptprod (valrel_implies_OfType vr))
      as (ts1' & tu1' & ts2' & tu2' & Hvs & Hvu & oft1 & oft2).
    exists ts1', ts2', tu1', tu2';
    rewrite -> valrel_fixp in vr;
    unfold valrel' in vr; crush.
  Qed.

  Lemma valrel_ptsum_inversion {d w τ₁ τ₂ vs vu} :
    valrel d w (ptsum τ₁ τ₂) vs vu →
    exists vs' vu',
      (vs = S.inl vs' ∧ vu = U.inl vu' ∧
       OfType τ₁ vs' vu' ∧
       ∀ w', w' < w → valrel d w' τ₁ vs' vu') ∨
      (vs = S.inr vs' ∧ vu = U.inr vu' ∧
       OfType τ₂ vs' vu' ∧
       ∀ w', w' < w → valrel d w' τ₂ vs' vu').
  Proof.
    intros vr.
    rewrite -> valrel_fixp in vr; destruct vr as [oft sumrel];
    apply OfType_inversion_ptsum in oft;
    destruct oft as (tsb & tub & Hvs); intuition; crush;
    exists tsb, tub; crush.
  Qed.

  Lemma valrel_ptarr_inversion {d w τ₁ τ₂ vs vu} :
    valrel d w (ptarr τ₁ τ₂) vs vu →
    ∃ tsb tub,
      vs = S.abs (repEmul τ₁) tsb ∧ vu = U.abs tub ∧
      ⟪ empty ▻ repEmul τ₁ ⊢ tsb : repEmul τ₂ ⟫ ∧
      ⟨ 1 ⊢ tub ⟩ ∧
      ∀ w' vs' vu',
        w' < w → valrel d w' τ₁ vs' vu' →
        termrel d w' τ₂ (tsb[beta1 vs']) (tub[beta1 vu']).
  Proof.
    intros vr.
    destruct (valrel_implies_Value vr) as [? ?].
    destruct (OfType_inversion_ptarr (valrel_implies_OfType vr))
      as (tsb & tub & ? & ? & ?).
    exists tsb, tub; crush.
    rewrite -> valrel_fixp in vr.
    unfold valrel' in vr; unfold termrel; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_zero {dir w p vs vu} :
    valrel dir w (pEmulDV 0 p) vs vu →
    OfType (pEmulDV 0 p) vs vu ∧ vs = S.unit ∧ p = imprecise.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    tauto.
  Qed.

  Lemma invert_valrel_pEmulDV_unk {dir w n p vu} :
    valrel dir w (pEmulDV (S n) p) (S.inl S.unit) vu →
    p = imprecise.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as [_ [[? ?] |[? [(? & ? & ?)| [[? ?] |[[? ?]|[[? ?]|[? ?]]]]]]]];
      crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inUnit' {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p) (inUnit n vs) vu →
    vs = S.unit ∧ vu = U.unit.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr.
    unfold valrel' in vr.
    destruct vr as [_ [[? ?] |[? [(? & ? & ?)| [[? ?] |[[? ?]|[[? ?]|[? ?]]]]]]]];
      crush; inversion H; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inUnit {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p) (inUnit n vs) vu →
    valrel dir w ptunit vs vu.
  Proof.
    intros vr.
    destruct (invert_valrel_pEmulDV_inUnit' vr); subst.
    apply valrel_unit.
  Qed.

  Lemma invert_valrel_pEmulDV_inBool' {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p) (inBool n vs) vu →
    (vs = S.true ∧ vu = U.true) ∨ (vs = S.false ∧ vu = U.false).
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as [_ [[? ?] |[? [(? & ? & ?)| [[? ?] |[[? ?]|[[? ?]|[? ?]]]]]]]];
      crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inBool {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p) (inBool n vs) vu →
    valrel dir w ptbool vs vu.
  Proof.
    intros vr.
    destruct (invert_valrel_pEmulDV_inBool' vr) as [[? ?]|[? ?]]; subst;
    auto using valrel_true, valrel_false.
  Qed.

  Lemma invert_valrel_pEmulDV_inProd' {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p) (inProd n vs) vu →
    ∃ vs₁ vs₂ vu₁ vu₂, vs = S.pair vs₁ vs₂ ∧ vu = U.pair vu₁ vu₂ ∧
                       (∀ w', w' < w → valrel dir w' (pEmulDV n p) vs₁ vu₁) ∧
                       (∀ w', w' < w → valrel dir w' (pEmulDV n p) vs₂ vu₂).
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as [[[vv ty] vvu] [[? ?] |[? [(? & ? & ?)| [[? ?] |[[? ?]|[[? ?]|[? ?]]]]]]]]; simpl in *; crush.
    assert (S.Value (inProd n x)) by crush.
    stlcCanForm.
    exists x0, x1, H0, H1; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inProd {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p) (inProd n vs) vu →
    valrel dir w (ptprod (pEmulDV n p) (pEmulDV n p)) vs vu.
  Proof.
    intros vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    destruct (invert_valrel_pEmulDV_inProd' vr) as (? & ? & ? & ? & ? & ? & ? & ?); subst.
    apply valrel_pair''; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inSum' {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p) (inSum n vs) vu →
    ∃ vs' vu', ((vs = S.inl vs' ∧ vu = U.inl vu') ∨ (vs = S.inr vs' ∧ vu = U.inr vu')) ∧
               (∀ w', w' < w → valrel dir w' (pEmulDV n p) vs' vu').
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as [[[vv ty] vvu] [[? ?] |[? [(? & ? & ?)| [[? ?] |[[? ?]|[[? ?]|[? ?]]]]]]]]; crush.
    assert (S.Value (inSum n x)) by crush.
    unfold sum_rel in H0; simpl in H0.
    stlcCanForm;
      destruct H1 as [[? ?]|[? ?]]; crush;
      exists x0, H0; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inSum {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p) (inSum n vs) vu →
    valrel dir w (ptsum (pEmulDV n p) (pEmulDV n p)) vs vu.
  Proof.
    intros vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    destruct (invert_valrel_pEmulDV_inSum' vr) as (? & ? & [[? ?]|[? ?]] & ?);
      subst; [apply valrel_inl''| apply valrel_inr''];
      crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inArr {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p) (inArr n vs) vu →
    valrel dir w (ptarr (pEmulDV n p) (pEmulDV n p)) vs vu.
  Proof.
    rewrite valrel_fixp; unfold valrel'.
    intros vr.
    destruct vr as [[[? ?] ?] [[? ?] |[? [(? & ? & ?)| [[? ?] |[[? ?]|[[? ?]|[? [? ?]]]]]]]]]; crush;
    stlcCanForm; crush.
  Qed.

  Lemma invert_valrel_pEmulDV {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p) vs vu →
    (vs = unkUVal (S n) ∧ p = imprecise) ∨
    ∃ vs',
      (vs = inUnit n vs' ∧ valrel dir w ptunit vs' vu) ∨
      (vs = inBool n vs' ∧ valrel dir w ptbool vs' vu) ∨
      (vs = inProd n vs' ∧ valrel dir w (ptprod (pEmulDV n p) (pEmulDV n p)) vs' vu) ∨
      (vs = inSum n vs' ∧ valrel dir w (ptsum (pEmulDV n p) (pEmulDV n p)) vs' vu) ∨
      (vs = inArr n vs' ∧ valrel dir w (ptarr (pEmulDV n p) (pEmulDV n p)) vs' vu).
  Proof.
    intros vr.
    destruct (valrel_implies_OfType vr) as [[? ?] _].
    simpl in H0.
    canonUVal.
    - left; crush.
      exact (invert_valrel_pEmulDV_unk vr).
    - right. exists x. left. crush.
      exact (invert_valrel_pEmulDV_inUnit vr).
    - right. exists x. right. left. crush.
      exact (invert_valrel_pEmulDV_inBool vr).
    - right. exists x. right. right. left. crush.
      exact (invert_valrel_pEmulDV_inProd vr).
    - right. exists x. right. right. right. left. crush.
      exact (invert_valrel_pEmulDV_inSum vr).
    - right. exists x. right. right. right. right. crush.
      exact (invert_valrel_pEmulDV_inArr vr).
  Qed.

End ValrelInversion.

Ltac invert_valrel_pEmulDV :=
  match goal with
      [ H : valrel _ _ (pEmulDV (S _) _) _ _ |- _ ] =>
      destruct (invert_valrel_pEmulDV H)
               as [[? ?]|(? & [(?&?)|[(?&?)|[(?&?)|[(?&?)|(?&?)]]]])]
  end.


Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Relations.Relations.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Arith.Arith.
Require Import MyPermutations.
Require Import PProp.

Inductive LJ_provable : list PProp -> PProp -> Prop :=
  | LJ_perm P1 L1 L2 :
      Permutation L1 L2 ->
      LJ_provable L1 P1 ->
      LJ_provable L2 P1
  | LJ_weak P1 P2 L1 :
      LJ_provable L1 P2 ->
      LJ_provable (P1::L1) P2
  | LJ_contr P1 P2 L1 :
      LJ_provable (P1::P1::L1) P2 ->
      LJ_provable (P1::L1) P2
  | LJ_axiom P1 :
      LJ_provable (P1::nil) P1
  | LJ_exfalso P1 :
      LJ_provable (PPbot::nil) P1
  | LJ_impl_antecedent P1 P2 P3 L1 :
      LJ_provable (L1) P1 ->
      LJ_provable (P2::L1) P3 ->
      LJ_provable (PPimpl P1 P2::L1) P3
  | LJ_impl_succedent P1 P2 L1 :
      LJ_provable (P1::L1) P2 ->
      LJ_provable L1 (PPimpl P1 P2)
  | LJ_conj_antecedent P1 P2 P3 L1 :
      LJ_provable (P1::P2::L1) P3 ->
      LJ_provable (PPconj P1 P2::L1) P3
  | LJ_conj_succedent P1 P2 L1 :
      LJ_provable L1 P1 ->
      LJ_provable L1 P2 ->
      LJ_provable L1 (PPconj P1 P2)
  | LJ_disj_antecedent P1 P2 P3 L1 :
      LJ_provable (P1::L1) P3 ->
      LJ_provable (P2::L1) P3 ->
      LJ_provable (PPdisj P1 P2::L1) P3
  | LJ_disj_succedent_l P1 P2 L1 :
      LJ_provable L1 P1 ->
      LJ_provable L1 (PPdisj P1 P2)
  | LJ_disj_succedent_r P1 P2 L1 :
      LJ_provable L1 P2 ->
      LJ_provable L1 (PPdisj P1 P2).

Ltac LJ_reorder_antecedent L :=
  apply (LJ_perm _ L); [perm|].

Instance LJ_provable_compat : Proper (@Permutation _==>eq==>iff) LJ_provable.
Proof.
unfold Proper,respectful.
intros L1 L2 HL P1 P2 HP.
split.
- intros H.
  rewrite <-HP.
  exact (LJ_perm P1 L1 L2 HL H).
- intros H.
  rewrite ->HP.
  exact (LJ_perm P2 L2 L1 (Permutation_sym HL) H).
Qed.

Lemma LJ_weakN: forall P1 L1 L2, LJ_provable L1 P1 -> LJ_provable (L2++L1) P1.
Proof.
intros P1 L1 L2 H.
induction L2.
- exact H.
- apply LJ_weak,IHL2.
Qed.

Lemma LJ_contrN: forall P1 L1 L2, LJ_provable (L2++L2++L1) P1 -> LJ_provable (L2++L1) P1.
Proof.
intros P1 L1 L2 H.
revert L1 H.
induction L2.
- intros L1 H.
  exact H.
- intros L1 H.
  LJ_reorder_antecedent (L2++(a::L1)).
  apply IHL2.
  LJ_reorder_antecedent (a::L2++L2++L1).
  apply LJ_contr.
  LJ_reorder_antecedent ((a::L2)++(a::L2)++L1).
  exact H.
Qed.

Lemma LJ_bot_elim: forall P1 L1, LJ_provable L1 PPbot -> LJ_provable L1 P1.
Proof.
intros P1 L1 H.
remember PPbot as P2 in H.
induction H.
- rewrite <-H.
  apply IHLJ_provable,HeqP2.
- apply LJ_weak,IHLJ_provable,HeqP2.
- apply LJ_contr,IHLJ_provable,HeqP2.
- rewrite HeqP2.
  apply LJ_exfalso.
- apply LJ_exfalso.
- apply LJ_impl_antecedent.
  + apply H.
  + apply IHLJ_provable2,HeqP2.
- congruence.
- apply LJ_conj_antecedent,IHLJ_provable,HeqP2.
- congruence.
- apply LJ_disj_antecedent.
  + apply IHLJ_provable1,HeqP2.
  + apply IHLJ_provable2,HeqP2.
- congruence.
- congruence.
Qed.

Lemma LJ_conj_elim_l:
  forall P1 P2 L1,
    LJ_provable L1 (PPconj P1 P2) -> LJ_provable L1 P1.
Proof.
intros P1 P2 L1 H.
remember (PPconj P1 P2) as P3 in H.
induction H.
- rewrite <-H.
  apply IHLJ_provable,HeqP3.
- apply LJ_weak,IHLJ_provable,HeqP3.
- apply LJ_contr,IHLJ_provable,HeqP3.
- rewrite HeqP3.
  apply LJ_conj_antecedent.
  LJ_reorder_antecedent (P2::P1::nil).
  apply LJ_weak.
  apply LJ_axiom.
- apply LJ_exfalso.
- apply LJ_impl_antecedent.
  + apply H.
  + apply IHLJ_provable2,HeqP3.
- congruence.
- apply LJ_conj_antecedent,IHLJ_provable,HeqP3.
- congruence.
- apply LJ_disj_antecedent.
  + apply IHLJ_provable1,HeqP3.
  + apply IHLJ_provable2,HeqP3.
- congruence.
- congruence.
Qed.

Lemma LJ_conj_elim_r:
  forall P1 P2 L1,
    LJ_provable L1 (PPconj P1 P2) -> LJ_provable L1 P2.
Proof.
intros P1 P2 L1 H.
remember (PPconj P1 P2) as P3 in H.
induction H.
- rewrite <-H.
  apply IHLJ_provable,HeqP3.
- apply LJ_weak,IHLJ_provable,HeqP3.
- apply LJ_contr,IHLJ_provable,HeqP3.
- rewrite HeqP3.
  apply LJ_conj_antecedent.
  apply LJ_weak.
  apply LJ_axiom.
- apply LJ_exfalso.
- apply LJ_impl_antecedent.
  + apply H.
  + apply IHLJ_provable2,HeqP3.
- congruence.
- apply LJ_conj_antecedent,IHLJ_provable,HeqP3.
- congruence.
- apply LJ_disj_antecedent.
  + apply IHLJ_provable1,HeqP3.
  + apply IHLJ_provable2,HeqP3.
- congruence.
- congruence.
Qed.

Lemma LJ_impl_elim:
  forall P1 P2 L1,
    LJ_provable L1 (PPimpl P1 P2) -> LJ_provable (P1::L1) P2.
Proof.
intros P1 P2 L1 H.
remember (PPimpl P1 P2) as P3 in H.
induction H.
- rewrite <-H.
  apply IHLJ_provable,HeqP3.
- LJ_reorder_antecedent (P0::P1::L1).
  apply LJ_weak,IHLJ_provable,HeqP3.
- LJ_reorder_antecedent (P0::P1::L1).
  apply LJ_contr.
  LJ_reorder_antecedent (P1::P0::P0::L1).
  apply IHLJ_provable,HeqP3.
- rewrite HeqP3.
  LJ_reorder_antecedent (PPimpl P1 P2::P1::nil).
  apply LJ_impl_antecedent.
  + apply LJ_axiom.
  + LJ_reorder_antecedent (P1::P2::nil).
    apply LJ_weak,LJ_axiom.
- apply LJ_weak,LJ_exfalso.
- LJ_reorder_antecedent (PPimpl P0 P3::P1::L1).
  apply LJ_impl_antecedent.
  + apply LJ_weak,H.
  + LJ_reorder_antecedent (P1::P3::L1).
    apply IHLJ_provable2,HeqP3.
- congruence.
- LJ_reorder_antecedent (PPconj P0 P3::P1::L1).
  apply LJ_conj_antecedent.
  LJ_reorder_antecedent (P1::P0::P3::L1).
  apply IHLJ_provable,HeqP3.
- congruence.
- LJ_reorder_antecedent (PPdisj P0 P3::P1::L1).
  apply LJ_disj_antecedent.
  + LJ_reorder_antecedent (P1::P0::L1).
    apply IHLJ_provable1,HeqP3.
  + LJ_reorder_antecedent (P1::P3::L1).
    apply IHLJ_provable2,HeqP3.
- congruence.
- congruence.
Qed.

Fixpoint replicate{A:Type} (n:nat) (a:A):list A :=
  match n with
  | O => nil
  | S n' => a :: replicate n' a
  end.

Lemma In_replicate_eq: forall{A:Type} (a b:A) (n:nat), In a (replicate n b) -> a = b.
Proof.
intros A a b n.
induction n.
- intros [].
- intros [H|H].
  + congruence.
  + apply IHn,H.
Qed.

Lemma LJ_cut_permselect:
  forall(P1 P2:PProp) (L1 L2:list PProp) (n:nat),
    Permutation (P1::L1) (replicate n P2++L2) ->
      (
        P1 = P2 /\ match n with
        | O => False
        | S n' => Permutation L1 (replicate n' P2++L2)
        end
      ) \/ (
        exists L2',
          Permutation L2 (P1::L2') /\
          Permutation L1 (replicate n P2++L2')
      ).
Proof.
intros P1 P2 L1 L2 n HP.
assert (HI:=in_eq P1 L1).
rewrite HP in HI.
rewrite in_app_iff in HI.
destruct HI as [HI|HI].
- left.
  split.
  + apply In_replicate_eq in HI.
    exact HI.
  + destruct n as [|n].
    * contradict HI.
    * apply In_replicate_eq in HI.
      rewrite HI in HP.
      apply Permutation_cons_inv with (a:=P2).
      exact HP.
- right.
  destruct (in_split _ _ HI) as (L2A,(L2B,HL2)).
  exists (L2A++L2B).
  split.
  + rewrite HL2.
    perm.
  + apply Permutation_cons_inv with (a:=P1).
    rewrite HP.
    rewrite HL2.
    perm.
Qed.

Lemma LJ_cut_permselect_nil:
  forall(P1 P2:PProp) (L2:list PProp) (n:nat),
    Permutation (P1::nil) (replicate n P2++L2) ->
      (
        P1 = P2 /\ n = 1 /\ L2 = nil
      ) \/ (
        n = 0 /\ L2 = (P1::nil)
      ).
intros P1 P2 L2 n HP.
apply Permutation_length_1_inv in HP.
destruct n as [|n].
- right.
  split.
  + reflexivity.
  + exact HP.
- left.
  change (P2::(replicate n P2++L2) = P1::nil) in HP.
  split.
  {
    congruence.
  }
  assert (HP2: replicate n P2++L2 = nil) by congruence.
  destruct n as [|n]; simpl in HP2; [|congruence].
  split.
  + reflexivity.
  + exact HP2.
Qed.

Lemma LJ_disj_elim2_withcut:
  forall P1 P2 P3 L1 L2,
    (forall PA LA1 LA2,
      LJ_provable LA1 P1 -> LJ_provable (P1::LA2) PA -> LJ_provable (LA1++LA2) PA) ->
    (forall PA LA1 LA2,
      LJ_provable LA1 P2 -> LJ_provable (P2::LA2) PA -> LJ_provable (LA1++LA2) PA) ->
    LJ_provable L1 (PPdisj P1 P2) ->
    LJ_provable (P1::L2) P3 ->
    LJ_provable (P2::L2) P3 ->
    LJ_provable (L1++L2) P3.
Proof.
intros P1 P2 P3 L1 L2 Hcut1 Hcut2 HC HP1 HP2.
remember (PPdisj P1 P2) as P4 in HC.
induction HC.
- rewrite <-H.
  apply IHHC,HeqP4.
- apply LJ_weak,IHHC,HeqP4.
- apply LJ_contr,IHHC,HeqP4.
- rewrite HeqP4; simpl.
  apply LJ_disj_antecedent.
  + exact HP1.
  + exact HP2.
- setoid_replace ((PPbot::nil)++L2) with (L2++(PPbot::nil)); [|perm].
  apply LJ_weakN.
  apply LJ_exfalso.
- apply LJ_impl_antecedent.
  + change (LJ_provable (L1++L2) P0).
    setoid_replace (L1++L2) with (L2++L1); [|perm].
    apply LJ_weakN.
    exact HC1.
  + change (LJ_provable (P4::L1++L2) P3).
    apply IHHC2,HeqP4.
- congruence.
- apply LJ_conj_antecedent.
  apply IHHC,HeqP4.
- congruence.
- apply LJ_disj_antecedent.
  + apply IHHC1,HeqP4.
  + apply IHHC2,HeqP4.
- apply Hcut1.
  + replace P1 with P0 by congruence.
    exact HC.
  + exact HP1.
- apply Hcut2.
  + replace P2 with P4 by congruence.
    exact HC.
  + exact HP2.
Qed.

Lemma LJ_cut_general:
  forall P1 P2 L1 L2 n,
    LJ_provable L1 P1 ->
    LJ_provable (replicate n P1++L2) P2 ->
    LJ_provable (L1++L2) P2.
Proof.
induction P1 as (KP1,HI_rank) using (well_founded_ind PProp_small_wellfounded).
intros KP2 KL1 KL2 n HPrL HPrR.
remember (replicate n KP1 ++ KL2) as KL3 in HPrR.
assert (HKL3: Permutation KL3 (replicate n KP1 ++ KL2)) by (rewrite HeqKL3; reflexivity).
clear HeqKL3.
revert KL1 KL2 n HKL3 HPrL.
induction HPrR.
- intros KL1 KL2 n HKL3 HPrL.
  apply IHHPrR with (n:=n).
  + transitivity L2; tauto.
  + exact HPrL.
- intros KL1 KL2 n HKL3 HPrL.
  apply LJ_cut_permselect in HKL3.
  destruct HKL3 as [(PrA,PrB) | (KL2',(PrC,PrD))].
  + destruct n as [|n]; [contradict PrB|].
    apply IHHPrR with (n:=n).
    * exact PrB.
    * exact HPrL.
  + rewrite PrC.
    LJ_reorder_antecedent (P1::KL1++KL2').
    apply LJ_weak.
    apply IHHPrR with (n:=n).
    * exact PrD.
    * exact HPrL.
- intros KL1 KL2 n HKL3 HPrL.
  apply LJ_cut_permselect in HKL3.
  destruct HKL3 as [(PrA,PrB) | (KL2',(PrC,PrD))].
  + destruct n as [|n]; [contradict PrB|].
    apply IHHPrR with (n:=S (S n)).
    * rewrite PrA.
      do 2 apply Permutation_cons.
      exact PrB.
    * exact HPrL.
  + rewrite PrC.
    LJ_reorder_antecedent (P1::KL1++KL2').
    apply LJ_contr.
    LJ_reorder_antecedent (KL1++(P1::P1::KL2')).
    apply IHHPrR with (n:=n).
    * rewrite PrD.
      perm.
    * exact HPrL.
- intros KL1 KL2 n HKL3 HPrL.
  apply LJ_cut_permselect_nil in HKL3.
  destruct HKL3 as [(PrA,(PrB,PrC)) | (PrD,PrE)].
  + rewrite PrA,PrC,app_nil_r.
    exact HPrL.
  + rewrite PrE.
    apply LJ_weakN.
    apply LJ_axiom.
- intros KL1 KL2 n HKL3 HPrL.
  apply LJ_cut_permselect_nil in HKL3.
  destruct HKL3 as [(PrA,(PrB,PrC)) | (PrD,PrE)].
  + rewrite PrC,app_nil_r.
    apply LJ_bot_elim.
    rewrite PrA.
    exact HPrL.
  + rewrite PrE.
    apply LJ_weakN.
    apply LJ_exfalso.
- intros KL1 KL2 n HKL3 HPrL.
  apply LJ_cut_permselect in HKL3.
  destruct HKL3 as [(PrA,PrB) | (KL2',(PrC,PrD))].
  + destruct n as [|n]; [contradict PrB|].
    {
      LJ_reorder_antecedent (KL1++KL2).
      do 2 apply LJ_contrN.
      LJ_reorder_antecedent (KL2++KL1++KL1++KL1).
      apply LJ_contrN.
      LJ_reorder_antecedent (((KL1++KL2)++KL1)++(KL1++KL2)).
      apply HI_rank with (y:=P2) (n:=1).
      - apply (PPsmall_impl_r _ (eq_sym PrA)).
      - apply HI_rank with (y:=P1) (n:=1).
        + apply (PPsmall_impl_l _ (eq_sym PrA)).
        + apply IHHPrR1 with (n:=n).
          * exact PrB.
          * exact HPrL.
        + apply LJ_impl_elim.
          rewrite PrA.
          exact HPrL.
      - simpl.
        LJ_reorder_antecedent (KL1 ++ (P2::KL2)).
        apply IHHPrR2 with (n:=n).
        + rewrite PrB; perm.
        + exact HPrL.
    }
  + rewrite PrC.
    LJ_reorder_antecedent (PPimpl P1 P2 :: KL1 ++ KL2').
    {
      apply LJ_impl_antecedent.
      - apply IHHPrR1 with (n:=n).
        + exact PrD.
        + exact HPrL.
      - LJ_reorder_antecedent (KL1 ++ P2 :: KL2').
        apply IHHPrR2 with (n:=n).
        + rewrite PrD; perm.
        + exact HPrL.
    }
- intros KL1 KL2 n HKL3 HPrL.
  apply LJ_impl_succedent.
  LJ_reorder_antecedent (KL1 ++ P1 :: KL2).
  apply IHHPrR with (n:=n).
  + rewrite HKL3; perm.
  + exact HPrL.
- intros KL1 KL2 n HKL3 HPrL.
  apply LJ_cut_permselect in HKL3.
  destruct HKL3 as [(PrA,PrB) | (KL2',(PrC,PrD))].
  + destruct n as [|n]; [contradict PrB|].
    {
      do 2 apply LJ_contrN.
      apply HI_rank with (y:=P2) (n:=1).
      - apply (PPsmall_conj_r _ (eq_sym PrA)).
      - apply LJ_conj_elim_r with (P1:=P1).
        rewrite PrA.
        exact HPrL.
      - simpl; LJ_reorder_antecedent (KL1 ++ P2 :: KL1 ++ KL2).
        apply HI_rank with (y:=P1) (n:=1).
        + apply (PPsmall_conj_l _ (eq_sym PrA)).
        + apply LJ_conj_elim_l with (P2:=P2).
          rewrite PrA.
          exact HPrL.
        + simpl; LJ_reorder_antecedent (KL1 ++ P1 :: P2 :: KL2).
          apply IHHPrR with (n:=n).
          * rewrite PrB; perm.
          * exact HPrL.
    }
  + rewrite PrC.
    LJ_reorder_antecedent (PPconj P1 P2 :: KL1 ++ KL2').
    apply LJ_conj_antecedent.
    LJ_reorder_antecedent (KL1 ++ P1 :: P2 :: KL2').
    apply IHHPrR with (n:=n).
    * rewrite PrD; perm.
    * exact HPrL.
- intros KL1 KL2 n HKL3 HPrL.
  apply LJ_conj_succedent.
  + apply IHHPrR1 with (n:=n).
    * exact HKL3.
    * exact HPrL.
  + apply IHHPrR2 with (n:=n).
    * exact HKL3.
    * exact HPrL.
- intros KL1 KL2 n HKL3 HPrL.
  apply LJ_cut_permselect in HKL3.
  destruct HKL3 as [(PrA,PrB) | (KL2',(PrC,PrD))].
  + destruct n as [|n]; [contradict PrB|].
    {
      apply LJ_contrN.
      apply LJ_disj_elim2_withcut with (P1:=P1) (P2:=P2).
      - intros PA LA1 LA2 HA1 HA2.
        apply HI_rank with (y:=P1) (n:=1).
        + apply (PPsmall_disj_l _ (eq_sym PrA)).
        + exact HA1.
        + exact HA2.
      - intros PA LA1 LA2 HA1 HA2.
        apply HI_rank with (y:=P2) (n:=1).
        + apply (PPsmall_disj_r _ (eq_sym PrA)).
        + exact HA1.
        + exact HA2.
      - rewrite PrA.
        exact HPrL.
      - LJ_reorder_antecedent (KL1 ++ P1 :: KL2).
        apply IHHPrR1 with (n:=n).
        + rewrite PrB; perm.
        + exact HPrL.
      - LJ_reorder_antecedent (KL1 ++ P2 :: KL2).
        apply IHHPrR2 with (n:=n).
        + rewrite PrB; perm.
        + exact HPrL.
    }
  + rewrite PrC.
    {
      LJ_reorder_antecedent (PPdisj P1 P2 :: KL1 ++ KL2').
      apply LJ_disj_antecedent.
      - LJ_reorder_antecedent (KL1 ++ P1 :: KL2').
        apply IHHPrR1 with (n:=n).
        + rewrite PrD; perm.
        + exact HPrL.
      - LJ_reorder_antecedent (KL1 ++ P2 :: KL2').
        apply IHHPrR2 with (n:=n).
        + rewrite PrD; perm.
        + exact HPrL.
    }
- intros KL1 KL2 n HKL3 HPrL.
  apply LJ_disj_succedent_l.
  apply IHHPrR with (n:=n).
  + exact HKL3.
  + exact HPrL.
- intros KL1 KL2 n HKL3 HPrL.
  apply LJ_disj_succedent_r.
  apply IHHPrR with (n:=n).
  + exact HKL3.
  + exact HPrL.
Qed.

Lemma LJ_cut2:
  forall P1 P2 L1 L2,
    LJ_provable L1 P1 ->
    LJ_provable (P1::L2) P2 ->
    LJ_provable (L1++L2) P2.
Proof.
intros P1 P2 L1 L2.
apply LJ_cut_general with (n:=1).
Qed.

Theorem LJ_cut:
  forall P1 P2 L1,
    LJ_provable L1 P1 ->
    LJ_provable (P1::L1) P2 ->
    LJ_provable L1 P2.
Proof.
intros P1 P2 L1 HPrL HPrR.
rewrite (app_nil_end L1).
apply LJ_contrN.
rewrite app_nil_r.
revert HPrL HPrR.
apply LJ_cut2.
Qed.

Lemma LJ_disj_elim2:
  forall P1 P2 P3 L1 L2,
    LJ_provable L1 (PPdisj P1 P2) ->
    LJ_provable (P1::L2) P3 ->
    LJ_provable (P2::L2) P3 ->
    LJ_provable (L1++L2) P3.
Proof.
intros P1 P2 P3 L1 L2.
apply LJ_disj_elim2_withcut.
- intros PA LA1 LA2.
  apply LJ_cut2.
- intros PA LA1 LA2.
  apply LJ_cut2.
Qed.

Lemma LJ_disj_elim:
  forall P1 P2 P3 L1,
    LJ_provable L1 (PPdisj P1 P2) ->
    LJ_provable (P1::L1) P3 ->
    LJ_provable (P2::L1) P3 ->
    LJ_provable L1 P3.
Proof.
intros P1 P2 P3 L1 HPrL HPrR1 HPrR2.
rewrite (app_nil_end L1).
apply LJ_contrN.
rewrite app_nil_r.
revert HPrL HPrR1 HPrR2.
apply LJ_disj_elim2.
Qed.

Definition LJ_tauto:PProp -> Prop := LJ_provable nil.

Lemma LJ_disjunction: forall P1 P2, LJ_tauto (PPdisj P1 P2) -> LJ_tauto P1 \/ LJ_tauto P2.
Proof.
unfold LJ_tauto.
intros P1 P2 H.
remember (@nil PProp) as L1 in H.
remember (PPdisj P1 P2) as P3 in H.
induction H.
- apply IHLJ_provable.
  + apply Permutation_nil.
    rewrite H,HeqL1.
    reflexivity.
  + exact HeqP3.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
- left.
  replace P1 with P0 by congruence.
  rewrite <-HeqL1.
  exact H.
- right.
  replace P2 with P3 by congruence.
  rewrite <-HeqL1.
  exact H.
Qed.

Lemma LJ_consistent: ~LJ_tauto PPbot.
Proof.
unfold LJ_tauto.
intros H.
remember (@nil PProp) as L1 in H.
remember (PPbot) as P1 in H.
induction H.
- apply IHLJ_provable.
  + apply Permutation_nil.
    rewrite H,HeqL1.
    reflexivity.
  + exact HeqP1.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
- congruence.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents2.
Require Export sequents_tacs.
Require Export Classical_Prop.
Require Export per_props_union.
Require Export per_props_equality.
Require Export per_props_squash.
Require Export subst_tacs_aeq.
Require Export cequiv_tacs.

(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)
(** printing mkc_axiom   $\mathtt{Ax}$ *)
(* begin hide *)

(* end hide*)

(**

I think Abhishek proved that to be inconsistent with Nuprl, but let's see
how far we can go just for the hell of it.

<<
   H |- squash(forall x : T. P x) ext Ax

     By SquashAll

     H |- isect x : T. squash(P x) ext Ax
>>

 *)

Definition rule_squash_all {o}
           (P T : NTerm)
           (x : NVar)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_squash (mk_function T x P))))
    [ mk_baresequent H (mk_conclax (mk_isect T x (mk_squash P)))
    ]
    [].

Lemma rule_squash_all_true3 {o} :
  forall lib (P T : NTerm),
  forall x : NVar,
  forall H : @barehypotheses o,
    rule_true3 lib (rule_squash_all P T x H).
Proof.
  unfold rule_squash_all, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [ws hyp1].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H) ||- (mk_conclax (mk_squash (mk_function T x P))))) as wfs.
  { prove_seq. }
  exists wfs.
  unfold wf_csequent, wf_sequent, wf_concl in wfs; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1; exrepnd.
  lsubst_tac.
  apply tequality_isect in hyp0.
  apply equality_in_isect in hyp1.
  repnd.

  apply implies_tequality_equality_mkc_squash.

  - apply tequality_function; dands; auto;[].
    introv equ.
    applydup hyp0 in equ.
    repeat (substc_lsubstc_vars3;[]).
    lsubst_tac.
    rw @tequality_mkc_squash in equ0; auto.

  - apply inhabited_function.
    dands; auto.

    + introv equ.
      applydup hyp3 in equ.
      repeat (substc_lsubstc_vars3;[]).
      lsubst_tac.
      rw @tequality_mkc_squash in equ0; auto.

    + assert (forall a, cover_vars P ((x, a) :: s1)) as cov.
      { introv.
        apply cover_vars_eq.
        unfold cover_vars_upto in c6; allsimpl.
        allrw @dom_csub_csub_filter.
        rw subvars_prop in c6; rw subvars_prop.
        introv i; apply c6 in i; allsimpl; repndors; subst; tcsp.
        allrw in_remove_nvars; tcsp. }

      assert (forall a a' : CTerm,
                equality lib a a' (lsubstc T w1 s1 c1)
                -> inhabited_type lib (lsubstc P w4 ((x,a) :: s1) (cov a))) as F.
      { introv equ.
        apply hyp1 in equ.
        repeat (substc_lsubstc_vars3;[]).
        remember (cov a) as ca; clear Heqca.
        lsubst_tac.
        apply equality_in_mkc_squash in equ; repnd; auto. }
      clear hyp1.

      unfold inhabited_type in F.
      pose proof (FunctionalChoice_on
                    {a : CTerm & {a' : CTerm & equality lib a a' (lsubstc T w1 s1 c1)}}
                    (@CTerm o)
                    (fun a t => member lib t (lsubstc P w4 ((x, (projT1 a)) :: s1) (cov (projT1 a)))))
        as fc; simpl in fc.
      autodimp fc hyp.
      { introv; exrepnd; allsimpl.
        pose proof (F a0 a' a2) as k; auto. }
      clear F.
      exrepnd.

      (* even if we could get a function from [CTerm] to [CTerm] from [f]
         (which we can't---right now we can at best get such functions when they're
          from nats to CTerms without atoms),
         we still don't get a function that functional over [(lsubstc T w1 s1 c1)] *)

Abort.

(* begin hide *)

(* end hide *)

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/" "../computation/" "../cequiv/" "../per/" "../close/")
*** End:
*)