From Hammer Require Import Hammer.

From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import omega.Omega.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

From PLF Require Import Smallstep.
From PLF Require Import Imp.

Definition pe_state := list (string * nat).

Fixpoint pe_lookup (pe_st : pe_state) (V:string) : option nat :=
match pe_st with
| [] => None
| (V',n')::pe_st => if eqb_string V V' then Some n'
else pe_lookup pe_st V
end.

Definition empty_pe_state : pe_state := [].

Tactic Notation "compare" ident(i) ident(j) :=
let H := fresh "Heq" i j in
destruct (eqb_stringP i j);
[ subst j | ].

Theorem pe_domain: forall pe_st V n,
pe_lookup pe_st V = Some n ->
In V (map (@fst _ _) pe_st).
Proof. hammer_hook "PE" "PE.pe_domain". intros pe_st V n H. induction pe_st as [| [V' n'] pe_st].
-  inversion H.
-  simpl in H. simpl. compare V V'; auto. Qed.

Print In.

Check filter_In.

Fixpoint inb {A : Type} (eqb : A -> A -> bool) (a : A) (l : list A) :=
match l with
| [] => false
| a'::l' => eqb a a' || inb eqb a l'
end.

Lemma inbP : forall A : Type, forall eqb : A->A->bool,
(forall a1 a2, reflect (a1 = a2) (eqb a1 a2)) ->
forall a l, reflect (In a l) (inb eqb a l).
Proof. hammer_hook "PE" "PE.inbP".
intros A eqb beqP a l.
induction l as [|a' l' IH].
- constructor. intros [].
- simpl. destruct (beqP a a').
+ subst. constructor. left. reflexivity.
+ simpl. destruct IH; constructor.
* right. trivial.
* intros [H1 | H2]; congruence.
Qed.

Fixpoint pe_aexp (pe_st : pe_state) (a : aexp) : aexp :=
match a with
| ANum n => ANum n
| AId i => match pe_lookup pe_st i with
| Some n => ANum n
| None => AId i
end
| APlus a1 a2 =>
match (pe_aexp pe_st a1, pe_aexp pe_st a2) with
| (ANum n1, ANum n2) => ANum (n1 + n2)
| (a1', a2') => APlus a1' a2'
end
| AMinus a1 a2 =>
match (pe_aexp pe_st a1, pe_aexp pe_st a2) with
| (ANum n1, ANum n2) => ANum (n1 - n2)
| (a1', a2') => AMinus a1' a2'
end
| AMult a1 a2 =>
match (pe_aexp pe_st a1, pe_aexp pe_st a2) with
| (ANum n1, ANum n2) => ANum (n1 * n2)
| (a1', a2') => AMult a1' a2'
end
end.

Example test_pe_aexp1:
pe_aexp [(X,3)] (X + 1 + Y)%imp
= (4 + Y)%imp.
Proof. hammer_hook "PE" "PE.test_pe_aexp1". reflexivity. Qed.

Example text_pe_aexp2:
pe_aexp [(Y,3)] (X + 1 + Y)%imp
= (X + 1 + 3)%imp.
Proof. hammer_hook "PE" "PE.text_pe_aexp2". reflexivity. Qed.

Definition pe_consistent (st:state) (pe_st:pe_state) :=
forall V n, Some n = pe_lookup pe_st V -> st V = n.

Theorem pe_aexp_correct_weak: forall st pe_st, pe_consistent st pe_st ->
forall a, aeval st a = aeval st (pe_aexp pe_st a).
Proof. hammer_hook "PE" "PE.pe_aexp_correct_weak". unfold pe_consistent. intros st pe_st H a.
induction a; simpl;
try reflexivity;
try (destruct (pe_aexp pe_st a1);
destruct (pe_aexp pe_st a2);
rewrite IHa1; rewrite IHa2; reflexivity).

-
remember (pe_lookup pe_st x) as l. destruct l.
+  rewrite H with (n:=n) by apply Heql. reflexivity.
+  reflexivity.
Qed.

Fixpoint pe_update (st:state) (pe_st:pe_state) : state :=
match pe_st with
| [] => st
| (V,n)::pe_st => t_update (pe_update st pe_st) V n
end.

Example test_pe_update:
pe_update (Y !-> 1) [(X,3);(Z,2)]
= (X !-> 3 ; Z !-> 2 ; Y !-> 1).
Proof. hammer_hook "PE" "PE.test_pe_update". reflexivity. Qed.

Theorem pe_update_correct: forall st pe_st V0,
pe_update st pe_st V0 =
match pe_lookup pe_st V0 with
| Some n => n
| None => st V0
end.
Proof. hammer_hook "PE" "PE.pe_update_correct". intros. induction pe_st as [| [V n] pe_st]. reflexivity.
simpl in *. unfold t_update.
compare V0 V; auto. rewrite <- eqb_string_refl; auto. rewrite false_eqb_string; auto. Qed.

Theorem pe_update_consistent: forall st pe_st,
pe_consistent (pe_update st pe_st) pe_st.
Proof. hammer_hook "PE" "PE.pe_update_consistent". intros st pe_st V n H. rewrite pe_update_correct.
destruct (pe_lookup pe_st V); inversion H. reflexivity. Qed.

Theorem pe_consistent_update: forall st pe_st,
pe_consistent st pe_st -> forall V, st V = pe_update st pe_st V.
Proof. hammer_hook "PE" "PE.pe_consistent_update". intros st pe_st H V. rewrite pe_update_correct.
remember (pe_lookup pe_st V) as l. destruct l; auto. Qed.

Theorem pe_aexp_correct: forall (pe_st:pe_state) (a:aexp) (st:state),
aeval (pe_update st pe_st) a = aeval st (pe_aexp pe_st a).
Proof. hammer_hook "PE" "PE.pe_aexp_correct".
intros pe_st a st.
induction a; simpl;
try reflexivity;
try (destruct (pe_aexp pe_st a1);
destruct (pe_aexp pe_st a2);
rewrite IHa1; rewrite IHa2; reflexivity).

rewrite pe_update_correct. destruct (pe_lookup pe_st x); reflexivity.
Qed.

Fixpoint pe_bexp (pe_st : pe_state) (b : bexp) : bexp :=
match b with
| BTrue        => BTrue
| BFalse       => BFalse
| BEq a1 a2 =>
match (pe_aexp pe_st a1, pe_aexp pe_st a2) with
| (ANum n1, ANum n2) => if n1 =? n2 then BTrue else BFalse
| (a1', a2') => BEq a1' a2'
end
| BLe a1 a2 =>
match (pe_aexp pe_st a1, pe_aexp pe_st a2) with
| (ANum n1, ANum n2) => if n1 <=? n2 then BTrue else BFalse
| (a1', a2') => BLe a1' a2'
end
| BNot b1 =>
match (pe_bexp pe_st b1) with
| BTrue => BFalse
| BFalse => BTrue
| b1' => BNot b1'
end
| BAnd b1 b2 =>
match (pe_bexp pe_st b1, pe_bexp pe_st b2) with
| (BTrue, BTrue) => BTrue
| (BTrue, BFalse) => BFalse
| (BFalse, BTrue) => BFalse
| (BFalse, BFalse) => BFalse
| (b1', b2') => BAnd b1' b2'
end
end.

Example test_pe_bexp1:
pe_bexp [(X,3)] (~(X <= 3))%imp
= false.
Proof. hammer_hook "PE" "PE.test_pe_bexp1". reflexivity. Qed.

Example test_pe_bexp2: forall b:bexp,
b = (~(X <= (X + 1)))%imp ->
pe_bexp [] b = b.
Proof. hammer_hook "PE" "PE.test_pe_bexp2". intros b H. rewrite -> H. reflexivity. Qed.

Theorem pe_bexp_correct: forall (pe_st:pe_state) (b:bexp) (st:state),
beval (pe_update st pe_st) b = beval st (pe_bexp pe_st b).
Proof. hammer_hook "PE" "PE.pe_bexp_correct".
intros pe_st b st.
induction b; simpl;
try reflexivity;
try (remember (pe_aexp pe_st a1) as a1';
remember (pe_aexp pe_st a2) as a2';
assert (H1: aeval (pe_update st pe_st) a1 = aeval st a1');
assert (H2: aeval (pe_update st pe_st) a2 = aeval st a2');
try (subst; apply pe_aexp_correct);
destruct a1'; destruct a2'; rewrite H1; rewrite H2;
simpl; try destruct (n =? n0);
try destruct (n <=? n0); reflexivity);
try (destruct (pe_bexp pe_st b); rewrite IHb; reflexivity);
try (destruct (pe_bexp pe_st b1);
destruct (pe_bexp pe_st b2);
rewrite IHb1; rewrite IHb2; reflexivity).
Qed.

Fixpoint pe_remove (pe_st:pe_state) (V:string) : pe_state :=
match pe_st with
| [] => []
| (V',n')::pe_st => if eqb_string V V' then pe_remove pe_st V
else (V',n') :: pe_remove pe_st V
end.

Theorem pe_remove_correct: forall pe_st V V0,
pe_lookup (pe_remove pe_st V) V0
= if eqb_string V V0 then None else pe_lookup pe_st V0.
Proof. hammer_hook "PE" "PE.pe_remove_correct". intros pe_st V V0. induction pe_st as [| [V' n'] pe_st].
-  destruct (eqb_string V V0); reflexivity.
-  simpl. compare V V'.
+  rewrite IHpe_st.
destruct (eqb_stringP V V0).  reflexivity.
rewrite false_eqb_string; auto.
+  simpl. compare V0 V'.
*  rewrite false_eqb_string; auto.
*  rewrite IHpe_st. reflexivity.
Qed.

Definition pe_add (pe_st:pe_state) (V:string) (n:nat) : pe_state :=
(V,n) :: pe_remove pe_st V.

Theorem pe_add_correct: forall pe_st V n V0,
pe_lookup (pe_add pe_st V n) V0
= if eqb_string V V0 then Some n else pe_lookup pe_st V0.
Proof. hammer_hook "PE" "PE.pe_add_correct". intros pe_st V n V0. unfold pe_add. simpl.
compare V V0.
-  rewrite <- eqb_string_refl; auto.
-  rewrite pe_remove_correct.
repeat rewrite false_eqb_string; auto.
Qed.

Theorem pe_update_update_remove: forall st pe_st V n,
t_update (pe_update st pe_st) V n =
pe_update (t_update st V n) (pe_remove pe_st V).
Proof. hammer_hook "PE" "PE.pe_update_update_remove". intros st pe_st V n. apply functional_extensionality.
intros V0. unfold t_update. rewrite !pe_update_correct.
rewrite pe_remove_correct. destruct (eqb_string V V0); reflexivity.
Qed.

Theorem pe_update_update_add: forall st pe_st V n,
t_update (pe_update st pe_st) V n =
pe_update st (pe_add pe_st V n).
Proof. hammer_hook "PE" "PE.pe_update_update_add". intros st pe_st V n. apply functional_extensionality. intros V0.
unfold t_update. rewrite !pe_update_correct. rewrite pe_add_correct.
destruct (eqb_string V V0); reflexivity. Qed.

Definition pe_disagree_at (pe_st1 pe_st2 : pe_state) (V:string) : bool :=
match pe_lookup pe_st1 V, pe_lookup pe_st2 V with
| Some x, Some y => negb (x =? y)
| None, None => false
| _, _ => true
end.

Theorem pe_disagree_domain: forall (pe_st1 pe_st2 : pe_state) (V:string),
true = pe_disagree_at pe_st1 pe_st2 V ->
In V (map (@fst _ _) pe_st1 ++ map (@fst _ _) pe_st2).
Proof. hammer_hook "PE" "PE.pe_disagree_domain". unfold pe_disagree_at. intros pe_st1 pe_st2 V H.
apply in_app_iff.
remember (pe_lookup pe_st1 V) as lookup1.
destruct lookup1 as [n1|]. left.  apply pe_domain with n1. auto.
remember (pe_lookup pe_st2 V) as lookup2.
destruct lookup2 as [n2|]. right. apply pe_domain with n2. auto.
inversion H. Qed.

Fixpoint pe_unique (l : list string) : list string :=
match l with
| [] => []
| x::l =>
x :: filter (fun y => if eqb_string x y then false else true) (pe_unique l)
end.

Theorem pe_unique_correct: forall l x,
In x l <-> In x (pe_unique l).
Proof. hammer_hook "PE" "PE.pe_unique_correct". intros l x. induction l as [| h t]. reflexivity.
simpl in *. split.
-
intros. inversion H; clear H.
left. assumption.
destruct (eqb_stringP h x).
left.  assumption.
right.  apply filter_In. split.
apply IHt. assumption.
rewrite false_eqb_string; auto.
-
intros. inversion H; clear H.
left. assumption.
apply filter_In in H0.  inversion H0. right. apply IHt. assumption.
Qed.

Definition pe_compare (pe_st1 pe_st2 : pe_state) : list string :=
pe_unique (filter (pe_disagree_at pe_st1 pe_st2)
(map (@fst _ _) pe_st1 ++ map (@fst _ _) pe_st2)).

Theorem pe_compare_correct: forall pe_st1 pe_st2 V,
pe_lookup pe_st1 V = pe_lookup pe_st2 V <->
~ In V (pe_compare pe_st1 pe_st2).
Proof. hammer_hook "PE" "PE.pe_compare_correct". intros pe_st1 pe_st2 V.
unfold pe_compare. rewrite <- pe_unique_correct. rewrite filter_In.
split; intros Heq.
-
intro. destruct H. unfold pe_disagree_at in H0. rewrite Heq in H0.
destruct (pe_lookup pe_st2 V).
rewrite <- beq_nat_refl in H0. inversion H0.
inversion H0.
-
assert (Hagree: pe_disagree_at pe_st1 pe_st2 V = false).
{
remember (pe_disagree_at pe_st1 pe_st2 V) as disagree.
destruct disagree; [| reflexivity].
apply  pe_disagree_domain in Heqdisagree.
exfalso. apply Heq. split. assumption. reflexivity. }
unfold pe_disagree_at in Hagree.
destruct (pe_lookup pe_st1 V) as [n1|];
destruct (pe_lookup pe_st2 V) as [n2|];
try reflexivity; try solve_by_invert.
rewrite negb_false_iff in Hagree.
apply eqb_eq in Hagree. subst. reflexivity. Qed.

Fixpoint pe_removes (pe_st:pe_state) (ids : list string) : pe_state :=
match ids with
| [] => pe_st
| V::ids => pe_remove (pe_removes pe_st ids) V
end.

Theorem pe_removes_correct: forall pe_st ids V,
pe_lookup (pe_removes pe_st ids) V =
if inb eqb_string V ids then None else pe_lookup pe_st V.
Proof. hammer_hook "PE" "PE.pe_removes_correct". intros pe_st ids V. induction ids as [| V' ids]. reflexivity.
simpl. rewrite pe_remove_correct. rewrite IHids.
compare V' V.
- rewrite <- eqb_string_refl. reflexivity.
- rewrite false_eqb_string; try congruence. reflexivity.
Qed.

Theorem pe_compare_removes: forall pe_st1 pe_st2 V,
pe_lookup (pe_removes pe_st1 (pe_compare pe_st1 pe_st2)) V =
pe_lookup (pe_removes pe_st2 (pe_compare pe_st1 pe_st2)) V.
Proof. hammer_hook "PE" "PE.pe_compare_removes".
intros pe_st1 pe_st2 V. rewrite !pe_removes_correct.
destruct (inbP _ _ eqb_stringP V (pe_compare pe_st1 pe_st2)).
- reflexivity.
- apply pe_compare_correct. auto. Qed.

Theorem pe_compare_update: forall pe_st1 pe_st2 st,
pe_update st (pe_removes pe_st1 (pe_compare pe_st1 pe_st2)) =
pe_update st (pe_removes pe_st2 (pe_compare pe_st1 pe_st2)).
Proof. hammer_hook "PE" "PE.pe_compare_update". intros. apply functional_extensionality. intros V.
rewrite !pe_update_correct. rewrite pe_compare_removes. reflexivity.
Qed.

Fixpoint assign (pe_st : pe_state) (ids : list string) : com :=
match ids with
| [] => SKIP
| V::ids => match pe_lookup pe_st V with
| Some n => (assign pe_st ids;; V ::= ANum n)
| None => assign pe_st ids
end
end.

Definition assigned (pe_st:pe_state) (ids : list string) (st:state) : state :=
fun V => if inb eqb_string V ids then
match pe_lookup pe_st V with
| Some n => n
| None => st V
end
else st V.

Theorem assign_removes: forall pe_st ids st,
pe_update st pe_st =
pe_update (assigned pe_st ids st) (pe_removes pe_st ids).
Proof. hammer_hook "PE" "PE.assign_removes". intros pe_st ids st. apply functional_extensionality. intros V.
rewrite !pe_update_correct. rewrite pe_removes_correct. unfold assigned.
destruct (inbP _ _ eqb_stringP V ids); destruct (pe_lookup pe_st V); reflexivity.
Qed.

Lemma ceval_extensionality: forall c st st1 st2,
st =[ c ]=> st1 -> (forall V, st1 V = st2 V) -> st =[ c ]=> st2.
Proof. hammer_hook "PE" "PE.ceval_extensionality". intros c st st1 st2 H Heq.
apply functional_extensionality in Heq. rewrite <- Heq. apply H. Qed.

Theorem eval_assign: forall pe_st ids st,
st =[ assign pe_st ids ]=> assigned pe_st ids st.
Proof. hammer_hook "PE" "PE.eval_assign". intros pe_st ids st. induction ids as [| V ids]; simpl.
-  eapply ceval_extensionality. apply E_Skip. reflexivity.
-
remember (pe_lookup pe_st V) as lookup. destruct lookup.
+  eapply E_Seq. apply IHids. unfold assigned. simpl.
eapply ceval_extensionality. apply E_Ass. simpl. reflexivity.
intros V0. unfold t_update.  compare V V0.
*  rewrite <- Heqlookup. rewrite <- eqb_string_refl. reflexivity.
*  rewrite false_eqb_string; simpl; congruence.
+  eapply ceval_extensionality. apply IHids.
unfold assigned. intros V0. simpl. compare V V0.
*  rewrite <- Heqlookup.
rewrite <- eqb_string_refl.
destruct (inbP _ _ eqb_stringP V ids); reflexivity.
*  rewrite false_eqb_string; simpl; congruence.
Qed.

Reserved Notation "c1 '/' st '\\' c1' '/' st'"
(at level 40, st at level 39, c1' at level 39).

Inductive pe_com : com -> pe_state -> com -> pe_state -> Prop :=
| PE_Skip : forall pe_st,
SKIP / pe_st \\ SKIP / pe_st
| PE_AssStatic : forall pe_st a1 n1 l,
pe_aexp pe_st a1 = ANum n1 ->
(l ::= a1) / pe_st \\ SKIP / pe_add pe_st l n1
| PE_AssDynamic : forall pe_st a1 a1' l,
pe_aexp pe_st a1 = a1' ->
(forall n, a1' <> ANum n) ->
(l ::= a1) / pe_st \\ (l ::= a1') / pe_remove pe_st l
| PE_Seq : forall pe_st pe_st' pe_st'' c1 c2 c1' c2',
c1 / pe_st  \\ c1' / pe_st' ->
c2 / pe_st' \\ c2' / pe_st'' ->
(c1 ;; c2) / pe_st \\ (c1' ;; c2') / pe_st''
| PE_IfTrue : forall pe_st pe_st' b1 c1 c2 c1',
pe_bexp pe_st b1 = BTrue ->
c1 / pe_st \\ c1' / pe_st' ->
(TEST b1 THEN c1 ELSE c2 FI) / pe_st \\ c1' / pe_st'
| PE_IfFalse : forall pe_st pe_st' b1 c1 c2 c2',
pe_bexp pe_st b1 = BFalse ->
c2 / pe_st \\ c2' / pe_st' ->
(TEST b1 THEN c1 ELSE c2 FI) / pe_st \\ c2' / pe_st'
| PE_If : forall pe_st pe_st1 pe_st2 b1 c1 c2 c1' c2',
pe_bexp pe_st b1 <> BTrue ->
pe_bexp pe_st b1 <> BFalse ->
c1 / pe_st \\ c1' / pe_st1 ->
c2 / pe_st \\ c2' / pe_st2 ->
(TEST b1 THEN c1 ELSE c2 FI) / pe_st
\\ (TEST pe_bexp pe_st b1
THEN c1' ;; assign pe_st1 (pe_compare pe_st1 pe_st2)
ELSE c2' ;; assign pe_st2 (pe_compare pe_st1 pe_st2) FI)
/ pe_removes pe_st1 (pe_compare pe_st1 pe_st2)

where "c1 '/' st '\\' c1' '/' st'" := (pe_com c1 st c1' st').

Hint Constructors pe_com.
Hint Constructors ceval.

Example pe_example1:
(X ::= 3 ;; Y ::= Z * (X + X))%imp
/ [] \\ (SKIP;; Y ::= Z * 6)%imp / [(X,3)].
Proof. hammer_hook "PE" "PE.pe_example1". eapply PE_Seq. eapply PE_AssStatic. reflexivity.
eapply PE_AssDynamic. reflexivity. intros n H. inversion H. Qed.

Example pe_example2:
(X ::= 3 ;; TEST X <= 4 THEN X ::= 4 ELSE SKIP FI)%imp
/ [] \\ (SKIP;; SKIP)%imp / [(X,4)].
Proof. hammer_hook "PE" "PE.pe_example2". eapply PE_Seq. eapply PE_AssStatic. reflexivity.
eapply PE_IfTrue. reflexivity.
eapply PE_AssStatic. reflexivity. Qed.

Example pe_example3:
(X ::= 3;;
TEST Y <= 4 THEN
Y ::= 4;;
TEST X = Y THEN Y ::= 999 ELSE SKIP FI
ELSE SKIP FI)%imp / []
\\ (SKIP;;
TEST Y <= 4 THEN
(SKIP;; SKIP);; (SKIP;; Y ::= 4)
ELSE SKIP;; SKIP FI)%imp
/ [(X,3)].
Proof. hammer_hook "PE" "PE.pe_example3". erewrite f_equal2 with (f := fun c st => _ / _ \\ c / st).
eapply PE_Seq. eapply PE_AssStatic. reflexivity.
eapply PE_If; intuition eauto; try solve_by_invert.
econstructor. eapply PE_AssStatic. reflexivity.
eapply PE_IfFalse. reflexivity. econstructor.
reflexivity. reflexivity. Qed.

Reserved Notation "c' '/' pe_st' '/' st '\\' st''"
(at level 40, pe_st' at level 39, st at level 39).

Inductive pe_ceval
(c':com) (pe_st':pe_state) (st:state) (st'':state) : Prop :=
| pe_ceval_intro : forall st',
st =[ c' ]=> st' ->
pe_update st' pe_st' = st'' ->
c' / pe_st' / st \\ st''
where "c' '/' pe_st' '/' st '\\' st''" := (pe_ceval c' pe_st' st st'').

Hint Constructors pe_ceval.

Theorem pe_com_complete:
forall c pe_st pe_st' c', c / pe_st \\ c' / pe_st' ->
forall st st'',
(pe_update st pe_st =[ c ]=> st'') ->
(c' / pe_st' / st \\ st'').
Proof. hammer_hook "PE" "PE.pe_com_complete". intros c pe_st pe_st' c' Hpe.
induction Hpe; intros st st'' Heval;
try (inversion Heval; subst;
try (rewrite -> pe_bexp_correct, -> H in *; solve_by_invert);
[]);
eauto.
-  econstructor. econstructor.
rewrite -> pe_aexp_correct. rewrite <- pe_update_update_add.
rewrite -> H. reflexivity.
-  econstructor. econstructor. reflexivity.
rewrite -> pe_aexp_correct. rewrite <- pe_update_update_remove.
reflexivity.
-
edestruct IHHpe1. eassumption. subst.
edestruct IHHpe2. eassumption.
eauto.
-  inversion Heval; subst.
+  edestruct IHHpe1. eassumption.
econstructor. apply E_IfTrue. rewrite <- pe_bexp_correct. assumption.
eapply E_Seq. eassumption. apply eval_assign.
rewrite <- assign_removes. eassumption.
+  edestruct IHHpe2. eassumption.
econstructor. apply E_IfFalse. rewrite <- pe_bexp_correct. assumption.
eapply E_Seq. eassumption. apply eval_assign.
rewrite -> pe_compare_update.
rewrite <- assign_removes. eassumption.
Qed.

Theorem pe_com_sound:
forall c pe_st pe_st' c', c / pe_st \\ c' / pe_st' ->
forall st st'',
(c' / pe_st' / st \\ st'') ->
(pe_update st pe_st =[ c ]=> st'').
Proof. hammer_hook "PE" "PE.pe_com_sound". intros c pe_st pe_st' c' Hpe.
induction Hpe;
intros st st'' [st' Heval Heq];
try (inversion Heval; []; subst); auto.
-  rewrite <- pe_update_update_add. apply E_Ass.
rewrite -> pe_aexp_correct. rewrite -> H. reflexivity.
-  rewrite <- pe_update_update_remove. apply E_Ass.
rewrite <- pe_aexp_correct. reflexivity.
-  eapply E_Seq; eauto.
-  apply E_IfTrue.
rewrite -> pe_bexp_correct. rewrite -> H. reflexivity. eauto.
-  apply E_IfFalse.
rewrite -> pe_bexp_correct. rewrite -> H. reflexivity. eauto.
-
inversion Heval; subst; inversion H7;
(eapply ceval_deterministic in H8; [| apply eval_assign]); subst.
+
apply E_IfTrue. rewrite -> pe_bexp_correct. assumption.
rewrite <- assign_removes. eauto.
+
rewrite -> pe_compare_update.
apply E_IfFalse. rewrite -> pe_bexp_correct. assumption.
rewrite <- assign_removes. eauto.
Qed.

Corollary pe_com_correct:
forall c pe_st pe_st' c', c / pe_st \\ c' / pe_st' ->
forall st st'',
(pe_update st pe_st =[ c ]=> st'') <->
(c' / pe_st' / st \\ st'').
Proof. hammer_hook "PE" "PE.pe_com_correct". intros c pe_st pe_st' c' H st st''. split.
-  apply pe_com_complete. apply H.
-  apply pe_com_sound. apply H.
Qed.

Module Loop.

Reserved Notation "c1 '/' st '\\' c1' '/' st' '/' c''"
(at level 40, st at level 39, c1' at level 39, st' at level 39).

Inductive pe_com : com -> pe_state -> com -> pe_state -> com -> Prop :=
| PE_Skip : forall pe_st,
SKIP / pe_st \\ SKIP / pe_st / SKIP
| PE_AssStatic : forall pe_st a1 n1 l,
pe_aexp pe_st a1 = ANum n1 ->
(l ::= a1) / pe_st \\ SKIP / pe_add pe_st l n1 / SKIP
| PE_AssDynamic : forall pe_st a1 a1' l,
pe_aexp pe_st a1 = a1' ->
(forall n, a1' <> ANum n) ->
(l ::= a1) / pe_st \\ (l ::= a1') / pe_remove pe_st l / SKIP
| PE_Seq : forall pe_st pe_st' pe_st'' c1 c2 c1' c2' c'',
c1 / pe_st  \\ c1' / pe_st' / SKIP ->
c2 / pe_st' \\ c2' / pe_st'' / c'' ->
(c1 ;; c2) / pe_st \\ (c1' ;; c2') / pe_st'' / c''
| PE_IfTrue : forall pe_st pe_st' b1 c1 c2 c1' c'',
pe_bexp pe_st b1 = BTrue ->
c1 / pe_st \\ c1' / pe_st' / c'' ->
(TEST b1 THEN c1 ELSE c2 FI) / pe_st \\ c1' / pe_st' / c''
| PE_IfFalse : forall pe_st pe_st' b1 c1 c2 c2' c'',
pe_bexp pe_st b1 = BFalse ->
c2 / pe_st \\ c2' / pe_st' / c'' ->
(TEST b1 THEN c1 ELSE c2 FI) / pe_st \\ c2' / pe_st' / c''
| PE_If : forall pe_st pe_st1 pe_st2 b1 c1 c2 c1' c2' c'',
pe_bexp pe_st b1 <> BTrue ->
pe_bexp pe_st b1 <> BFalse ->
c1 / pe_st \\ c1' / pe_st1 / c'' ->
c2 / pe_st \\ c2' / pe_st2 / c'' ->
(TEST b1 THEN c1 ELSE c2 FI) / pe_st
\\ (TEST pe_bexp pe_st b1
THEN c1' ;; assign pe_st1 (pe_compare pe_st1 pe_st2)
ELSE c2' ;; assign pe_st2 (pe_compare pe_st1 pe_st2) FI)
/ pe_removes pe_st1 (pe_compare pe_st1 pe_st2)
/ c''
| PE_WhileFalse : forall pe_st b1 c1,
pe_bexp pe_st b1 = BFalse ->
(WHILE b1 DO c1 END) / pe_st \\ SKIP / pe_st / SKIP
| PE_WhileTrue : forall pe_st pe_st' pe_st'' b1 c1 c1' c2' c2'',
pe_bexp pe_st b1 = BTrue ->
c1 / pe_st \\ c1' / pe_st' / SKIP ->
(WHILE b1 DO c1 END) / pe_st' \\ c2' / pe_st'' / c2'' ->
pe_compare pe_st pe_st'' <> [] ->
(WHILE b1 DO c1 END) / pe_st \\ (c1';;c2') / pe_st'' / c2''
| PE_While : forall pe_st pe_st' pe_st'' b1 c1 c1' c2' c2'',
pe_bexp pe_st b1 <> BFalse ->
pe_bexp pe_st b1 <> BTrue ->
c1 / pe_st \\ c1' / pe_st' / SKIP ->
(WHILE b1 DO c1 END) / pe_st' \\ c2' / pe_st'' / c2'' ->
pe_compare pe_st pe_st'' <> [] ->
(c2'' = SKIP%imp \/ c2'' = WHILE b1 DO c1 END%imp) ->
(WHILE b1 DO c1 END) / pe_st
\\ (TEST pe_bexp pe_st b1
THEN c1';; c2';; assign pe_st'' (pe_compare pe_st pe_st'')
ELSE assign pe_st (pe_compare pe_st pe_st'') FI)%imp
/ pe_removes pe_st (pe_compare pe_st pe_st'')
/ c2''
| PE_WhileFixedEnd : forall pe_st b1 c1,
pe_bexp pe_st b1 <> BFalse ->
(WHILE b1 DO c1 END) / pe_st \\ SKIP / pe_st / (WHILE b1 DO c1 END)
| PE_WhileFixedLoop : forall pe_st pe_st' pe_st'' b1 c1 c1' c2',
pe_bexp pe_st b1 = BTrue ->
c1 / pe_st \\ c1' / pe_st' / SKIP ->
(WHILE b1 DO c1 END) / pe_st'
\\ c2' / pe_st'' / (WHILE b1 DO c1 END) ->
pe_compare pe_st pe_st'' = [] ->
(WHILE b1 DO c1 END) / pe_st
\\ (WHILE BTrue DO SKIP END) / pe_st / SKIP

| PE_WhileFixed : forall pe_st pe_st' pe_st'' b1 c1 c1' c2',
pe_bexp pe_st b1 <> BFalse ->
pe_bexp pe_st b1 <> BTrue ->
c1 / pe_st \\ c1' / pe_st' / SKIP ->
(WHILE b1 DO c1 END) / pe_st'
\\ c2' / pe_st'' / (WHILE b1 DO c1 END) ->
pe_compare pe_st pe_st'' = [] ->
(WHILE b1 DO c1 END) / pe_st
\\ (WHILE pe_bexp pe_st b1 DO c1';; c2' END) / pe_st / SKIP

where "c1 '/' st '\\' c1' '/' st' '/' c''" := (pe_com c1 st c1' st' c'').

Hint Constructors pe_com.

Ltac step i :=
(eapply i; intuition eauto; try solve_by_invert);
repeat (try eapply PE_Seq;
try (eapply PE_AssStatic; simpl; reflexivity);
try (eapply PE_AssDynamic;
[ simpl; reflexivity
| intuition eauto; solve_by_invert])).

Definition square_loop: com :=
(WHILE 1 <= X DO
Y ::= Y * Y;;
X ::= X - 1
END)%imp.

Example pe_loop_example1:
square_loop / []
\\ (WHILE 1 <= X DO
(Y ::= Y * Y;;
X ::= X - 1);; SKIP
END)%imp / [] / SKIP.
Proof. hammer_hook "PE" "PE.Loop.pe_loop_example1". erewrite f_equal2 with (f := fun c st => _ / _ \\ c / st / SKIP).
step PE_WhileFixed. step PE_WhileFixedEnd. reflexivity.
reflexivity. reflexivity. Qed.

Example pe_loop_example2:
(X ::= 3;; square_loop)%imp / []
\\ (SKIP;;
(Y ::= Y * Y;; SKIP);;
(Y ::= Y * Y;; SKIP);;
(Y ::= Y * Y;; SKIP);;
SKIP)%imp / [(X,0)] / SKIP%imp.
Proof. hammer_hook "PE" "PE.Loop.pe_loop_example2". erewrite f_equal2 with (f := fun c st => _ / _ \\ c / st / SKIP).
eapply PE_Seq. eapply PE_AssStatic. reflexivity.
step PE_WhileTrue.
step PE_WhileTrue.
step PE_WhileTrue.
step PE_WhileFalse.
inversion H. inversion H. inversion H.
reflexivity. reflexivity. Qed.

Example pe_loop_example3:
(Z ::= 3;; subtract_slowly) / []
\\ (SKIP;;
TEST ~(X = 0) THEN
(SKIP;; X ::= X - 1);;
TEST ~(X = 0) THEN
(SKIP;; X ::= X - 1);;
TEST ~(X = 0) THEN
(SKIP;; X ::= X - 1);;
WHILE ~(X = 0) DO
(SKIP;; X ::= X - 1);; SKIP
END;;
SKIP;; Z ::= 0
ELSE SKIP;; Z ::= 1 FI;; SKIP
ELSE SKIP;; Z ::= 2 FI;; SKIP
ELSE SKIP;; Z ::= 3 FI)%imp / [] / SKIP.
Proof. hammer_hook "PE" "PE.Loop.pe_loop_example3". erewrite f_equal2 with (f := fun c st => _ / _ \\ c / st / SKIP).
eapply PE_Seq. eapply PE_AssStatic. reflexivity.
step PE_While.
step PE_While.
step PE_While.
step PE_WhileFixed.
step PE_WhileFixedEnd.
reflexivity. inversion H. inversion H. inversion H.
reflexivity. reflexivity. Qed.

Example pe_loop_example4:
(X ::= 0;;
WHILE X <= 2 DO
X ::= 1 - X
END)%imp / [] \\ (SKIP;; WHILE true DO SKIP END)%imp / [(X,0)] / SKIP.
Proof. hammer_hook "PE" "PE.Loop.pe_loop_example4". erewrite f_equal2 with (f := fun c st => _ / _ \\ c / st / SKIP).
eapply PE_Seq. eapply PE_AssStatic. reflexivity.
step PE_WhileFixedLoop.
step PE_WhileTrue.
step PE_WhileFixedEnd.
inversion H. reflexivity. reflexivity. reflexivity. Qed.

Reserved Notation "c1 '/' st '\\' st' '#' n"
(at level 40, st at level 39, st' at level 39).

Inductive ceval_count : com -> state -> state -> nat -> Prop :=
| E'Skip : forall st,
SKIP / st \\ st # 0
| E'Ass  : forall st a1 n l,
aeval st a1 = n ->
(l ::= a1) / st \\ (t_update st l n) # 0
| E'Seq : forall c1 c2 st st' st'' n1 n2,
c1 / st  \\ st'  # n1 ->
c2 / st' \\ st'' # n2 ->
(c1 ;; c2) / st \\ st'' # (n1 + n2)
| E'IfTrue : forall st st' b1 c1 c2 n,
beval st b1 = true ->
c1 / st \\ st' # n ->
(TEST b1 THEN c1 ELSE c2 FI) / st \\ st' # n
| E'IfFalse : forall st st' b1 c1 c2 n,
beval st b1 = false ->
c2 / st \\ st' # n ->
(TEST b1 THEN c1 ELSE c2 FI) / st \\ st' # n
| E'WhileFalse : forall b1 st c1,
beval st b1 = false ->
(WHILE b1 DO c1 END) / st \\ st # 0
| E'WhileTrue : forall st st' st'' b1 c1 n1 n2,
beval st b1 = true ->
c1 / st \\ st' # n1 ->
(WHILE b1 DO c1 END) / st' \\ st'' # n2 ->
(WHILE b1 DO c1 END) / st \\ st'' # S (n1 + n2)

where "c1 '/' st '\\' st' # n" := (ceval_count c1 st st' n).

Hint Constructors ceval_count.

Theorem ceval_count_complete: forall c st st',
st =[ c ]=> st' -> exists n, c / st \\ st' # n.
Proof. hammer_hook "PE" "PE.Loop.ceval_count_complete". intros c st st' Heval.
induction Heval;
try inversion IHHeval1;
try inversion IHHeval2;
try inversion IHHeval;
eauto. Qed.

Theorem ceval_count_sound: forall c st st' n,
c / st \\ st' # n -> st =[ c ]=> st'.
Proof. hammer_hook "PE" "PE.Loop.ceval_count_sound". intros c st st' n Heval. induction Heval; eauto. Qed.

Theorem pe_compare_nil_lookup: forall pe_st1 pe_st2,
pe_compare pe_st1 pe_st2 = [] ->
forall V, pe_lookup pe_st1 V = pe_lookup pe_st2 V.
Proof. hammer_hook "PE" "PE.Loop.pe_compare_nil_lookup". intros pe_st1 pe_st2 H V.
apply (pe_compare_correct pe_st1 pe_st2 V).
rewrite H. intro. inversion H0. Qed.

Theorem pe_compare_nil_update: forall pe_st1 pe_st2,
pe_compare pe_st1 pe_st2 = [] ->
forall st, pe_update st pe_st1 = pe_update st pe_st2.
Proof. hammer_hook "PE" "PE.Loop.pe_compare_nil_update". intros pe_st1 pe_st2 H st.
apply functional_extensionality. intros V.
rewrite !pe_update_correct.
apply pe_compare_nil_lookup with (V:=V) in H.
rewrite H. reflexivity. Qed.

Reserved Notation "c' '/' pe_st' '/' c'' '/' st '\\' st'' '#' n"
(at level 40, pe_st' at level 39, c'' at level 39,
st at level 39, st'' at level 39).

Inductive pe_ceval_count (c':com) (pe_st':pe_state) (c'':com)
(st:state) (st'':state) (n:nat) : Prop :=
| pe_ceval_count_intro : forall st' n',
st =[ c' ]=> st' ->
c'' / pe_update st' pe_st' \\ st'' # n' ->
n' <= n ->
c' / pe_st' / c'' / st \\ st'' # n
where "c' '/' pe_st' '/' c'' '/' st '\\' st'' '#' n" :=
(pe_ceval_count c' pe_st' c'' st st'' n).

Hint Constructors pe_ceval_count.

Lemma pe_ceval_count_le: forall c' pe_st' c'' st st'' n n',
n' <= n ->
c' / pe_st' / c'' / st \\ st'' # n' ->
c' / pe_st' / c'' / st \\ st'' # n.
Proof. hammer_hook "PE" "PE.Loop.pe_ceval_count_le". intros c' pe_st' c'' st st'' n n' Hle H. inversion H.
econstructor; try eassumption. omega. Qed.

Theorem pe_com_complete:
forall c pe_st pe_st' c' c'', c / pe_st \\ c' / pe_st' / c'' ->
forall st st'' n,
(c / pe_update st pe_st \\ st'' # n) ->
(c' / pe_st' / c'' / st \\ st'' # n).
Proof. hammer_hook "PE" "PE.Loop.pe_com_complete". intros c pe_st pe_st' c' c'' Hpe.
induction Hpe; intros st st'' n Heval;
try (inversion Heval; subst;
try (rewrite -> pe_bexp_correct, -> H in *; solve_by_invert);
[]);
eauto.
-  econstructor. econstructor.
rewrite -> pe_aexp_correct. rewrite <- pe_update_update_add.
rewrite -> H. apply E'Skip. auto.
-  econstructor. econstructor. reflexivity.
rewrite -> pe_aexp_correct. rewrite <- pe_update_update_remove.
apply E'Skip. auto.
-
edestruct IHHpe1 as [? ? ? Hskip ?]. eassumption.
inversion Hskip. subst.
edestruct IHHpe2. eassumption.
econstructor; eauto. omega.
-  inversion Heval; subst.
+  edestruct IHHpe1. eassumption.
econstructor. apply E_IfTrue. rewrite <- pe_bexp_correct. assumption.
eapply E_Seq. eassumption. apply eval_assign.
rewrite <- assign_removes. eassumption. eassumption.
+  edestruct IHHpe2. eassumption.
econstructor. apply E_IfFalse. rewrite <- pe_bexp_correct. assumption.
eapply E_Seq. eassumption. apply eval_assign.
rewrite -> pe_compare_update.
rewrite <- assign_removes. eassumption. eassumption.
-
edestruct IHHpe1 as [? ? ? Hskip ?]. eassumption.
inversion Hskip. subst.
edestruct IHHpe2. eassumption.
econstructor; eauto. omega.
-  inversion Heval; subst.
+  econstructor. apply E_IfFalse.
rewrite <- pe_bexp_correct. assumption.
apply eval_assign.
rewrite <- assign_removes. inversion H2; subst; auto.
auto.
+
edestruct IHHpe1 as [? ? ? Hskip ?]. eassumption.
inversion Hskip. subst.
edestruct IHHpe2. eassumption.
econstructor. apply E_IfTrue.
rewrite <- pe_bexp_correct. assumption.
repeat eapply E_Seq; eauto. apply eval_assign.
rewrite -> pe_compare_update, <- assign_removes. eassumption.
omega.
-  exfalso.
generalize dependent (S (n1 + n2)). intros n.
clear - H H0 IHHpe1 IHHpe2. generalize dependent st.
induction n using lt_wf_ind; intros st Heval. inversion Heval; subst.
+  rewrite pe_bexp_correct, H in H7. inversion H7.
+
edestruct IHHpe1 as [? ? ? Hskip ?]. eassumption.
inversion Hskip. subst.
edestruct IHHpe2. eassumption.
rewrite <- (pe_compare_nil_update _ _ H0) in H7.
apply H1 in H7; [| omega]. inversion H7.
-  generalize dependent st.
induction n using lt_wf_ind; intros st Heval. inversion Heval; subst.
+  rewrite pe_bexp_correct in H8. eauto.
+  rewrite pe_bexp_correct in H5.
edestruct IHHpe1 as [? ? ? Hskip ?]. eassumption.
inversion Hskip. subst.
edestruct IHHpe2. eassumption.
rewrite <- (pe_compare_nil_update _ _ H1) in H8.
apply H2 in H8; [| omega]. inversion H8.
econstructor; [ eapply E_WhileTrue; eauto | eassumption | omega].
Qed.

Theorem pe_com_sound:
forall c pe_st pe_st' c' c'', c / pe_st \\ c' / pe_st' / c'' ->
forall st st'' n,
(c' / pe_st' / c'' / st \\ st'' # n) ->
(pe_update st pe_st =[ c ]=> st'').
Proof. hammer_hook "PE" "PE.Loop.pe_com_sound". intros c pe_st pe_st' c' c'' Hpe.
induction Hpe;
intros st st'' n [st' n' Heval Heval' Hle];
try (inversion Heval; []; subst);
try (inversion Heval'; []; subst); eauto.
-  rewrite <- pe_update_update_add. apply E_Ass.
rewrite -> pe_aexp_correct. rewrite -> H. reflexivity.
-  rewrite <- pe_update_update_remove. apply E_Ass.
rewrite <- pe_aexp_correct. reflexivity.
-  eapply E_Seq; eauto.
-  apply E_IfTrue.
rewrite -> pe_bexp_correct. rewrite -> H. reflexivity.
eapply IHHpe. eauto.
-  apply E_IfFalse.
rewrite -> pe_bexp_correct. rewrite -> H. reflexivity.
eapply IHHpe. eauto.
-  inversion Heval; subst; inversion H7; subst; clear H7.
+
eapply ceval_deterministic in H8; [| apply eval_assign]. subst.
rewrite <- assign_removes in Heval'.
apply E_IfTrue. rewrite -> pe_bexp_correct. assumption.
eapply IHHpe1. eauto.
+
eapply ceval_deterministic in H8; [| apply eval_assign]. subst.
rewrite -> pe_compare_update in Heval'.
rewrite <- assign_removes in Heval'.
apply E_IfFalse. rewrite -> pe_bexp_correct. assumption.
eapply IHHpe2. eauto.
-  apply E_WhileFalse.
rewrite -> pe_bexp_correct. rewrite -> H. reflexivity.
-  eapply E_WhileTrue.
rewrite -> pe_bexp_correct. rewrite -> H. reflexivity.
eapply IHHpe1. eauto. eapply IHHpe2. eauto.
-  inversion Heval; subst.
+
inversion H9. subst. clear H9.
inversion H10. subst. clear H10.
eapply ceval_deterministic in H11; [| apply eval_assign]. subst.
rewrite -> pe_compare_update in Heval'.
rewrite <- assign_removes in Heval'.
eapply E_WhileTrue. rewrite -> pe_bexp_correct. assumption.
eapply IHHpe1. eauto.
eapply IHHpe2. eauto.
+  apply ceval_count_sound in Heval'.
eapply ceval_deterministic in H9; [| apply eval_assign]. subst.
rewrite <- assign_removes in Heval'.
inversion H2; subst.
*  inversion Heval'. subst. apply E_WhileFalse.
rewrite -> pe_bexp_correct. assumption.
*  assumption.
-  eapply ceval_count_sound. apply Heval'.
-
apply loop_never_stops in Heval. inversion Heval.
-
clear - H1 IHHpe1 IHHpe2 Heval.
remember (WHILE pe_bexp pe_st b1 DO c1';; c2' END)%imp as c'.
induction Heval;
inversion Heqc'; subst; clear Heqc'.
+  apply E_WhileFalse.
rewrite pe_bexp_correct. assumption.
+
assert (IHHeval2' := IHHeval2 (refl_equal _)).
apply ceval_count_complete in IHHeval2'. inversion IHHeval2'.
clear IHHeval1 IHHeval2 IHHeval2'.
inversion Heval1. subst.
eapply E_WhileTrue. rewrite pe_bexp_correct. assumption. eauto.
eapply IHHpe2. econstructor. eassumption.
rewrite <- (pe_compare_nil_update _ _ H1). eassumption. apply le_n.
Qed.

Corollary pe_com_correct:
forall c pe_st pe_st' c', c / pe_st \\ c' / pe_st' / SKIP ->
forall st st'',
(pe_update st pe_st =[ c ]=> st'') <->
(exists st', st =[ c' ]=> st' /\ pe_update st' pe_st' = st'').
Proof. hammer_hook "PE" "PE.Loop.pe_com_correct". intros c pe_st pe_st' c' H st st''. split.
-  intros Heval.
apply ceval_count_complete in Heval. inversion Heval as [n Heval'].
apply pe_com_complete with (st:=st) (st'':=st'') (n:=n) in H.
inversion H as [? ? ? Hskip ?]. inversion Hskip. subst. eauto.
assumption.
-  intros [st' [Heval Heq]]. subst st''.
eapply pe_com_sound in H. apply H.
econstructor. apply Heval. apply E'Skip. apply le_n.
Qed.

End Loop.

Inductive block (Label:Type) : Type :=
| Goto : Label -> block Label
| If : bexp -> Label -> Label -> block Label
| Assign : string -> aexp -> block Label -> block Label.

Arguments Goto {Label} _.
Arguments If   {Label} _ _ _.
Arguments Assign {Label} _ _ _.

Inductive parity_label : Type :=
| entry : parity_label
| loop  : parity_label
| body  : parity_label
| done  : parity_label.

Definition parity_body : block parity_label :=
Assign Y (Y - 1)
(Assign X (1 - X)
(Goto loop)).

Fixpoint keval {L:Type} (st:state) (k : block L) : state * L :=
match k with
| Goto l => (st, l)
| If b l1 l2 => (st, if beval st b then l1 else l2)
| Assign i a k => keval (t_update st i (aeval st a)) k
end.

Example keval_example:
keval empty_st parity_body
= ((X !-> 1 ; Y !-> 0), loop).
Proof. hammer_hook "PE" "PE.keval_example". reflexivity. Qed.

Definition program (L:Type) : Type := L -> option (block L).

Definition parity : program parity_label := fun l =>
match l with
| entry => Some (Assign X 0 (Goto loop))
| loop => Some (If (1 <= Y) body done)
| body => Some parity_body
| done => None
end.

Inductive peval {L:Type} (p : program L)
: state -> L -> state -> L -> Prop :=
| E_None: forall st l,
p l = None ->
peval p st l st l
| E_Some: forall st l k st' l' st'' l'',
p l = Some k ->
keval st k = (st', l') ->
peval p st' l' st'' l'' ->
peval p st l st'' l''.

Example parity_eval: peval parity empty_st entry  empty_st done.
Proof. hammer_hook "PE" "PE.parity_eval". erewrite f_equal with (f := fun st => peval _ _ _ st _).
eapply E_Some. reflexivity. reflexivity.
eapply E_Some. reflexivity. reflexivity.
apply E_None. reflexivity.
apply functional_extensionality. intros i. rewrite t_update_same; auto.
Qed.

Fixpoint pe_block {L:Type} (pe_st:pe_state) (k : block L)
: block (pe_state * L) :=
match k with
| Goto l => Goto (pe_st, l)
| If b l1 l2 =>
match pe_bexp pe_st b with
| BTrue  => Goto (pe_st, l1)
| BFalse => Goto (pe_st, l2)
| b'     => If b' (pe_st, l1) (pe_st, l2)
end
| Assign i a k =>
match pe_aexp pe_st a with
| ANum n => pe_block (pe_add pe_st i n) k
| a' => Assign i a' (pe_block (pe_remove pe_st i) k)
end
end.

Example pe_block_example:
pe_block [(X,0)] parity_body
= Assign Y (Y - 1) (Goto ([(X,1)], loop)).
Proof. hammer_hook "PE" "PE.pe_block_example". reflexivity. Qed.

Theorem pe_block_correct: forall (L:Type) st pe_st k st' pe_st' (l':L),
keval st (pe_block pe_st k) = (st', (pe_st', l')) ->
keval (pe_update st pe_st) k = (pe_update st' pe_st', l').
Proof. hammer_hook "PE" "PE.pe_block_correct". intros. generalize dependent pe_st. generalize dependent st.
induction k as [l | b l1 l2 | i a k];
intros st pe_st H.
-  inversion H; reflexivity.
-
replace (keval st (pe_block pe_st (If b l1 l2)))
with (keval st (If (pe_bexp pe_st b) (pe_st, l1) (pe_st, l2)))
in H by (simpl; destruct (pe_bexp pe_st b); reflexivity).
simpl in *. rewrite pe_bexp_correct.
destruct (beval st (pe_bexp pe_st b)); inversion H; reflexivity.
-
simpl in *. rewrite pe_aexp_correct.
destruct (pe_aexp pe_st a); simpl;
try solve [rewrite pe_update_update_add; apply IHk; apply H];
solve [rewrite pe_update_update_remove; apply IHk; apply H].
Qed.

Definition pe_program {L:Type} (p : program L)
: program (pe_state * L) :=
fun pe_l => match pe_l with | (pe_st, l) =>
option_map (pe_block pe_st) (p l)
end.

Inductive pe_peval {L:Type} (p : program L)
(st:state) (pe_st:pe_state) (l:L) (st'o:state) (l':L) : Prop :=
| pe_peval_intro : forall st' pe_st',
peval (pe_program p) st (pe_st, l) st' (pe_st', l') ->
pe_update st' pe_st' = st'o ->
pe_peval p st pe_st l st'o l'.

Theorem pe_program_correct:
forall (L:Type) (p : program L) st pe_st l st'o l',
peval p (pe_update st pe_st) l st'o l' <->
pe_peval p st pe_st l st'o l'.
Proof. hammer_hook "PE" "PE.pe_program_correct". intros.
split.
-  intros Heval.
remember (pe_update st pe_st) as sto.
generalize dependent pe_st. generalize dependent st.
induction Heval as
[ sto l Hlookup | sto l k st'o l' st''o l'' Hlookup Hkeval Heval ];
intros st pe_st Heqsto; subst sto.
+  eapply pe_peval_intro. apply E_None.
simpl. rewrite Hlookup. reflexivity. reflexivity.
+
remember (keval st (pe_block pe_st k)) as x.
destruct x as [st' [pe_st' l'_]].
symmetry in Heqx. erewrite pe_block_correct in Hkeval by apply Heqx.
inversion Hkeval. subst st'o l'_. clear Hkeval.
edestruct IHHeval. reflexivity. subst st''o. clear IHHeval.
eapply pe_peval_intro; [| reflexivity]. eapply E_Some; eauto.
simpl. rewrite Hlookup. reflexivity.
-  intros [st' pe_st' Heval Heqst'o].
remember (pe_st, l) as pe_st_l.
remember (pe_st', l') as pe_st'_l'.
generalize dependent pe_st. generalize dependent l.
induction Heval as
[ st [pe_st_ l_] Hlookup
| st [pe_st_ l_] pe_k st' [pe_st'_ l'_] st'' [pe_st'' l'']
Hlookup Hkeval Heval ];
intros l pe_st Heqpe_st_l;
inversion Heqpe_st_l; inversion Heqpe_st'_l'; repeat subst.
+  apply E_None. simpl in Hlookup.
destruct (p l'); [ solve [ inversion Hlookup ] | reflexivity ].
+
simpl in Hlookup. remember (p l) as k.
destruct k as [k|]; inversion Hlookup; subst.
eapply E_Some; eauto. apply pe_block_correct. apply Hkeval.
Qed.


(** This file is still experimental. See its tracking issue
https://gitlab.mpi-sws.org/iris/stdpp/-/issues/145 for details on remaining
issues before stabilization. This file is maintained by Michael Sammler. *)
From stdpp Require Export BVnumbers.
From stdpp Require Import countable finite.
From stdpp Require Import options.

(** * bitvector library *)
(** This file provides the [bv n] type for representing [n]-bit
integers with the standard operations. It also provides the
[bv_saturate] tactic for learning facts about the range of bit vector
variables in context. More extensive automation can be found in
[bitvector_auto.v].

Additionally, this file provides the [bvn] type for representing a
bitvector of arbitrary size. *)

(** * Settings *)
Local Open Scope Z_scope.

(** * Preliminary definitions *)
Definition bv_modulus (n : N) : Z := 2 ^ (Z.of_N n).
Definition bv_half_modulus (n : N) : Z := bv_modulus n `div` 2.
Definition bv_wrap (n : N) (z : Z) : Z := z `mod` bv_modulus n.
Definition bv_swrap (n : N) (z : Z) : Z := bv_wrap n (z + bv_half_modulus n) - bv_half_modulus n.

Lemma bv_modulus_pos n :
  0 < bv_modulus n.
Proof. apply Z.pow_pos_nonneg; lia. Qed.
Lemma bv_modulus_gt_1 n :
  n ≠ 0%N →
  1 < bv_modulus n.
Proof. intros ?. apply Z.pow_gt_1; lia. Qed.
Lemma bv_half_modulus_nonneg n :
  0 ≤ bv_half_modulus n.
Proof. apply Z.div_pos; [|done]. pose proof bv_modulus_pos n. lia. Qed.

Lemma bv_modulus_add n1 n2 :
  bv_modulus (n1 + n2) = bv_modulus n1 * bv_modulus n2.
Proof. unfold bv_modulus. rewrite N2Z.inj_add. eapply Z.pow_add_r; lia. Qed.

Lemma bv_half_modulus_twice n:
  n ≠ 0%N →
  bv_half_modulus n + bv_half_modulus n = bv_modulus n.
Proof.
  intros. unfold bv_half_modulus, bv_modulus.
  rewrite Z.add_diag. symmetry. apply Z_div_exact_2; [lia|].
  rewrite <-Z.pow_pred_r by lia. rewrite Z.mul_comm. by apply Z.mod_mul.
Qed.

Lemma bv_half_modulus_lt_modulus n:
  bv_half_modulus n < bv_modulus n.
Proof.
  pose proof bv_modulus_pos n.
  apply Z_div_lt; [done| lia].
Qed.

Lemma bv_modulus_le_mono n m:
  (n ≤ m)%N →
  bv_modulus n ≤ bv_modulus m.
Proof. intros. apply Z.pow_le_mono; [done|lia]. Qed.
Lemma bv_half_modulus_le_mono n m:
  (n ≤ m)%N →
  bv_half_modulus n ≤ bv_half_modulus m.
Proof. intros. apply Z.div_le_mono; [done|]. by apply bv_modulus_le_mono. Qed.

Lemma bv_modulus_0:
  bv_modulus 0 = 1.
Proof. done. Qed.
Lemma bv_half_modulus_0:
  bv_half_modulus 0 = 0.
Proof. done. Qed.

Lemma bv_half_modulus_twice_mult n:
  bv_half_modulus n + bv_half_modulus n = (Z.of_N n `min` 1) * bv_modulus n.
Proof. destruct (decide (n = 0%N)); subst; [ rewrite bv_half_modulus_0 | rewrite bv_half_modulus_twice]; lia. Qed.

Lemma bv_wrap_in_range n z:
  0 ≤ bv_wrap n z < bv_modulus n.
Proof. apply Z.mod_pos_bound. apply bv_modulus_pos. Qed.

Lemma bv_swrap_in_range n z:
  n ≠ 0%N →
  - bv_half_modulus n ≤ bv_swrap n z < bv_half_modulus n.
Proof.
  intros ?. unfold bv_swrap.
  pose proof bv_half_modulus_twice n.
  pose proof bv_wrap_in_range n (z + bv_half_modulus n).
  lia.
Qed.

Lemma bv_wrap_small n z :
  0 ≤ z < bv_modulus n → bv_wrap n z = z.
Proof. intros. by apply Z.mod_small. Qed.

Lemma bv_swrap_small n z :
  - bv_half_modulus n ≤ z < bv_half_modulus n →
  bv_swrap n z = z.
Proof.
  intros Hrange. unfold bv_swrap.
  destruct (decide (n = 0%N)); subst.
  { rewrite bv_half_modulus_0 in Hrange. lia. }
  pose proof bv_half_modulus_twice n.
  rewrite bv_wrap_small by lia. lia.
Qed.

Lemma bv_wrap_0 n :
  bv_wrap n 0 = 0.
Proof. done. Qed.
Lemma bv_swrap_0 n :
  bv_swrap n 0 = 0.
Proof.
  pose proof bv_half_modulus_lt_modulus n.
  pose proof bv_half_modulus_nonneg n.
  unfold bv_swrap. rewrite bv_wrap_small; lia.
Qed.

Lemma bv_wrap_idemp n b : bv_wrap n (bv_wrap n b) = bv_wrap n b.
Proof. unfold bv_wrap. by rewrite Zmod_mod. Qed.

Definition bv_wrap_factor (n : N) (x z : Z) :=
  x = - z `div` bv_modulus n.

Lemma bv_wrap_factor_intro n z :
  ∃ x, bv_wrap_factor n x z ∧ bv_wrap n z = z + x * bv_modulus n.
Proof.
  eexists _. split; [done|].
  pose proof (bv_modulus_pos n). unfold bv_wrap. rewrite Z.mod_eq; lia.
Qed.

Lemma bv_wrap_add_modulus c n z:
  bv_wrap n (z + c * bv_modulus n) = bv_wrap n z.
Proof. apply Z_mod_plus_full. Qed.
Lemma bv_wrap_add_modulus_1 n z:
  bv_wrap n (z + bv_modulus n) = bv_wrap n z.
Proof. rewrite <-(bv_wrap_add_modulus 1 n z). f_equal. lia. Qed.
Lemma bv_wrap_sub_modulus c n z:
  bv_wrap n (z - c * bv_modulus n) = bv_wrap n z.
Proof. rewrite <-(bv_wrap_add_modulus (-c) n z). f_equal. lia. Qed.
Lemma bv_wrap_sub_modulus_1 n z:
  bv_wrap n (z - bv_modulus n) = bv_wrap n z.
Proof. rewrite <-(bv_wrap_add_modulus (-1) n z). done. Qed.

Lemma bv_wrap_add_idemp n x y :
  bv_wrap n (bv_wrap n x + bv_wrap n y) = bv_wrap n (x + y).
Proof. symmetry. apply Zplus_mod. Qed.
Lemma bv_wrap_add_idemp_l n x y :
  bv_wrap n (bv_wrap n x + y) = bv_wrap n (x + y).
Proof. apply Zplus_mod_idemp_l. Qed.
Lemma bv_wrap_add_idemp_r n x y :
  bv_wrap n (x + bv_wrap n y) = bv_wrap n (x + y).
Proof. apply Zplus_mod_idemp_r. Qed.

Lemma bv_wrap_opp_idemp n x :
  bv_wrap n (- bv_wrap n x) = bv_wrap n (- x).
Proof.
  unfold bv_wrap. pose proof (bv_modulus_pos n).
  destruct (decide (x `mod` bv_modulus n = 0)) as [Hx|Hx].
  - rewrite !Z.mod_opp_l_z; [done |lia|done|lia|by rewrite Hx].
  - rewrite !Z.mod_opp_l_nz, Z.mod_mod;
      [done|lia|lia|done|lia|by rewrite Z.mod_mod by lia].
Qed.

Lemma bv_wrap_mul_idemp n x y :
  bv_wrap n (bv_wrap n x * bv_wrap n y) = bv_wrap n (x * y).
Proof. etrans; [| apply Zmult_mod_idemp_r]. apply Zmult_mod_idemp_l. Qed.
Lemma bv_wrap_mul_idemp_l n x y :
  bv_wrap n (bv_wrap n x * y) = bv_wrap n (x * y).
Proof. apply Zmult_mod_idemp_l. Qed.
Lemma bv_wrap_mul_idemp_r n x y :
  bv_wrap n (x * bv_wrap n y) = bv_wrap n (x * y).
Proof. apply Zmult_mod_idemp_r. Qed.

Lemma bv_wrap_sub_idemp n x y :
  bv_wrap n (bv_wrap n x - bv_wrap n y) = bv_wrap n (x - y).
Proof.
  by rewrite <-!Z.add_opp_r, <-bv_wrap_add_idemp_r,
    bv_wrap_opp_idemp, bv_wrap_add_idemp.
 Qed.
Lemma bv_wrap_sub_idemp_l n x y :
  bv_wrap n (bv_wrap n x - y) = bv_wrap n (x - y).
Proof. by rewrite <-!Z.add_opp_r, bv_wrap_add_idemp_l. Qed.
Lemma bv_wrap_sub_idemp_r n x y :
  bv_wrap n (x - bv_wrap n y) = bv_wrap n (x - y).
Proof.
  by rewrite <-!Z.add_opp_r, <-bv_wrap_add_idemp_r,
    bv_wrap_opp_idemp, bv_wrap_add_idemp_r.
Qed.

Lemma bv_wrap_succ_idemp n x :
  bv_wrap n (Z.succ (bv_wrap n x)) = bv_wrap n (Z.succ x).
Proof. by rewrite <-!Z.add_1_r, bv_wrap_add_idemp_l. Qed.
Lemma bv_wrap_pred_idemp n x :
  bv_wrap n (Z.pred (bv_wrap n x)) = bv_wrap n (Z.pred x).
Proof. by rewrite <-!Z.sub_1_r, bv_wrap_sub_idemp_l. Qed.

Lemma bv_wrap_add_inj n x1 x2 y :
  bv_wrap n x1 = bv_wrap n x2 ↔ bv_wrap n (x1 + y) = bv_wrap n (x2 + y).
Proof.
  split; intros Heq.
  - by rewrite <-bv_wrap_add_idemp_l, Heq, bv_wrap_add_idemp_l.
  - pose proof (bv_wrap_factor_intro n (x1 + y)) as [f1[? Hx1]].
    pose proof (bv_wrap_factor_intro n (x2 + y)) as [f2[? Hx2]].
    assert (x1 = x2 + f2 * bv_modulus n - f1 * bv_modulus n) as -> by lia.
    by rewrite bv_wrap_sub_modulus, bv_wrap_add_modulus.
Qed.

Lemma bv_swrap_wrap n z:
  bv_swrap n (bv_wrap n z) = bv_swrap n z.
Proof. unfold bv_swrap, bv_wrap. by rewrite Zplus_mod_idemp_l. Qed.

Lemma bv_wrap_bv_wrap n1 n2 bv :
  (n1 ≤ n2)%N →
  bv_wrap n1 (bv_wrap n2 bv) = bv_wrap n1 bv.
Proof.
  intros ?. unfold bv_wrap.
  rewrite <-Znumtheory.Zmod_div_mod; [done| apply bv_modulus_pos.. |].
  unfold bv_modulus. eexists (2 ^ (Z.of_N n2 - Z.of_N n1)).
  rewrite <-Z.pow_add_r by lia. f_equal. lia.
Qed.

Lemma bv_wrap_land n z :
  bv_wrap n z = Z.land z (Z.ones (Z.of_N n)).
Proof. by rewrite Z.land_ones by lia. Qed.
Lemma bv_wrap_spec n z i:
  0 ≤ i →
  Z.testbit (bv_wrap n z) i = bool_decide (i < Z.of_N n) && Z.testbit z i.
Proof.
  intros ?. rewrite bv_wrap_land, Z.land_spec, Z.ones_spec by lia.
  case_bool_decide; simpl; by rewrite ?andb_true_r, ?andb_false_r.
Qed.
Lemma bv_wrap_spec_low n z i:
  0 ≤ i < Z.of_N n →
  Z.testbit (bv_wrap n z) i = Z.testbit z i.
Proof. intros ?. rewrite bv_wrap_spec; [|lia]. case_bool_decide; [done|]. lia. Qed.
Lemma bv_wrap_spec_high n z i:
  Z.of_N n ≤ i →
  Z.testbit (bv_wrap n z) i = false.
Proof. intros ?. rewrite bv_wrap_spec; [|lia]. case_bool_decide; [|done]. lia. Qed.

(** * [BvWf] *)
(** The [BvWf] typeclass checks that the integer [z] can be
interpreted as a [n]-bit integer. [BvWf] is a typeclass such that it
can be automatically inferred for bitvector constants. *)
Class BvWf (n : N) (z : Z) : Prop :=
    bv_wf : (0 <=? z) && (z <? bv_modulus n)
.
Global Hint Mode BvWf + + : typeclass_instances.
Global Instance bv_wf_pi n z : ProofIrrel (BvWf n z).
Proof. unfold BvWf. apply _. Qed.
Global Instance bv_wf_dec n z : Decision (BvWf n z).
Proof. unfold BvWf. apply _. Defined.

Typeclasses Opaque BvWf.

Ltac solve_BvWf :=
  lazymatch goal with
    |- BvWf ?n ?v =>
      is_closed_term n;
      is_closed_term v;
      try (vm_compute; exact I);
      fail "Bitvector constant" v "does not fit into" n "bits"
  end.
Global Hint Extern 10 (BvWf _ _) => solve_BvWf : typeclass_instances.

Lemma bv_wf_in_range n z:
  BvWf n z ↔ 0 ≤ z < bv_modulus n.
Proof. unfold BvWf. by rewrite andb_True, !Is_true_true, Z.leb_le, Z.ltb_lt. Qed.

Lemma bv_wrap_wf n z :
  BvWf n (bv_wrap n z).
Proof. apply bv_wf_in_range. apply bv_wrap_in_range. Qed.

Lemma bv_wf_bitwise_op {n} op bop n1 n2 :
  (∀ k, Z.testbit (op n1 n2) k = bop (Z.testbit n1 k) (Z.testbit n2 k)) →
  (0 ≤ n1 → 0 ≤ n2 → 0 ≤ op n1 n2) →
  bop false false = false →
  BvWf n n1 →
  BvWf n n2 →
  BvWf n (op n1 n2).
Proof.
  intros Hbits Hnonneg Hop [? Hok1]%bv_wf_in_range [? Hok2]%bv_wf_in_range. apply bv_wf_in_range.
  split; [lia|].
  apply Z.bounded_iff_bits_nonneg; [lia..|]. intros l ?.
  eapply Z.bounded_iff_bits_nonneg in Hok1;[|try done; lia..].
  eapply Z.bounded_iff_bits_nonneg in Hok2;[|try done; lia..].
  by rewrite Hbits, Hok1, Hok2.
Qed.

(** * Definition of [bv n] *)
Record bv (n : N) := BV {
  bv_unsigned : Z;
  bv_is_wf : BvWf n bv_unsigned;
}.
Global Arguments bv_unsigned {_}.
Global Arguments bv_is_wf {_}.
Global Arguments BV _ _ {_}.
Add Printing Constructor bv.

Global Arguments bv_unsigned : simpl never.

Definition bv_signed {n} (b : bv n) := bv_swrap n (bv_unsigned b).

Lemma bv_eq n (b1 b2 : bv n) :
  b1 = b2 ↔ b1.(bv_unsigned) = b2.(bv_unsigned).
Proof.
  destruct b1, b2. unfold bv_unsigned. split; [ naive_solver|].
  intros. subst. f_equal. apply proof_irrel.
Qed.

Lemma bv_neq n (b1 b2 : bv n) :
  b1 ≠ b2 ↔ b1.(bv_unsigned) ≠ b2.(bv_unsigned).
Proof. unfold not. by rewrite bv_eq. Qed.

Definition Z_to_bv_checked (n : N) (z : Z) : option (bv n) :=
  guard (BvWf n z) as H; Some (@BV n z H).

Program Definition Z_to_bv (n : N) (z : Z) : bv n :=
  @BV n (bv_wrap n z) _.
Next Obligation. apply bv_wrap_wf. Qed.

Lemma Z_to_bv_unsigned n z:
  bv_unsigned (Z_to_bv n z) = bv_wrap n z.
Proof. done. Qed.

Lemma Z_to_bv_signed n z:
  bv_signed (Z_to_bv n z) = bv_swrap n z.
Proof. apply bv_swrap_wrap. Qed.

Lemma Z_to_bv_small n z:
  0 ≤ z < bv_modulus n →
  bv_unsigned (Z_to_bv n z) = z.
Proof. rewrite Z_to_bv_unsigned. apply bv_wrap_small. Qed.

Lemma bv_unsigned_BV n z Hwf:
  bv_unsigned (@BV n z Hwf) = z.
Proof. done. Qed.

Lemma bv_signed_BV n z Hwf:
  bv_signed (@BV n z Hwf) = bv_swrap n z.
Proof. done. Qed.

Lemma bv_unsigned_in_range n (b : bv n):
  0 ≤ bv_unsigned b < bv_modulus n.
Proof. apply bv_wf_in_range. apply bv_is_wf. Qed.

Lemma bv_wrap_bv_unsigned n (b : bv n):
  bv_wrap n (bv_unsigned b) = bv_unsigned b.
Proof. rewrite bv_wrap_small; [done|apply bv_unsigned_in_range]. Qed.

Lemma Z_to_bv_bv_unsigned n (b : bv n):
  Z_to_bv n (bv_unsigned b) = b.
Proof. apply bv_eq. by rewrite Z_to_bv_unsigned, bv_wrap_bv_unsigned. Qed.

Lemma bv_eq_wrap n (b1 b2 : bv n) :
  b1 = b2 ↔ bv_wrap n b1.(bv_unsigned) = bv_wrap n b2.(bv_unsigned).
Proof.
  rewrite !bv_wrap_small; [apply bv_eq | apply bv_unsigned_in_range..].
Qed.

Lemma bv_neq_wrap n (b1 b2 : bv n) :
  b1 ≠ b2 ↔ bv_wrap n b1.(bv_unsigned) ≠ bv_wrap n b2.(bv_unsigned).
Proof. unfold not. by rewrite bv_eq_wrap. Qed.

Lemma bv_eq_signed n (b1 b2 : bv n) :
  b1 = b2 ↔ bv_signed b1 = bv_signed b2.
Proof.
  split; [naive_solver |].
  unfold bv_signed, bv_swrap. intros ?.
  assert (bv_wrap n (bv_unsigned b1 + bv_half_modulus n)
          = bv_wrap n (bv_unsigned b2 + bv_half_modulus n)) as ?%bv_wrap_add_inj by lia.
  by apply bv_eq_wrap.
Qed.

Lemma bv_signed_in_range n (b : bv n):
  n ≠ 0%N →
  - bv_half_modulus n ≤ bv_signed b < bv_half_modulus n.
Proof. apply bv_swrap_in_range. Qed.

Lemma bv_unsigned_spec_high i n (b : bv n) :
  Z.of_N n ≤ i →
  Z.testbit (bv_unsigned b) i = false.
Proof.
  intros ?. pose proof (bv_unsigned_in_range _ b). unfold bv_modulus in *.
  eapply Z.bounded_iff_bits_nonneg; [..|done]; lia.
Qed.

Lemma bv_unsigned_N_0 (b : bv 0):
  bv_unsigned b = 0.
Proof.
  pose proof bv_unsigned_in_range 0 b as H.
  rewrite bv_modulus_0 in H. lia.
Qed.
Lemma bv_signed_N_0 (b : bv 0):
  bv_signed b = 0.
Proof. unfold bv_signed. by rewrite bv_unsigned_N_0, bv_swrap_0. Qed.

Lemma bv_swrap_bv_signed n (b : bv n):
  bv_swrap n (bv_signed b) = bv_signed b.
Proof.
  destruct (decide (n = 0%N)); subst.
  { by rewrite bv_signed_N_0, bv_swrap_0. }
  apply bv_swrap_small. by apply bv_signed_in_range.
Qed.

Lemma Z_to_bv_checked_bv_unsigned n (b : bv n):
  Z_to_bv_checked n (bv_unsigned b) = Some b.
Proof.
  unfold Z_to_bv_checked. case_option_guard.
  - f_equal. by apply bv_eq.
  - by pose proof bv_is_wf b.
Qed.
Lemma Z_to_bv_checked_Some n a (b : bv n):
  Z_to_bv_checked n a = Some b ↔ a = bv_unsigned b.
Proof.
  split.
  - unfold Z_to_bv_checked. case_option_guard; [|done]. intros ?. by simplify_eq.
  - intros ->. apply Z_to_bv_checked_bv_unsigned.
Qed.

(** * Typeclass instances for [bv n] *)
Global Program Instance bv_eq_dec n : EqDecision (bv n) := λ '(@BV _ v1 p1) '(@BV _ v2 p2),
   match decide (v1 = v2) with
   | left eqv => left _
   | right eqv => right _
   end.
Next Obligation.
  (* TODO: Can we get a better proof term here? *)
  intros n b1 v1 p1 ? b2 v2 p2 ????. subst.
  rewrite (proof_irrel p1 p2). exact eq_refl.
Defined.
Next Obligation. intros. by injection. Qed.

Global Instance bv_countable n : Countable (bv n) :=
  inj_countable bv_unsigned (Z_to_bv_checked n) (Z_to_bv_checked_bv_unsigned n).

Global Program Instance bv_finite n : Finite (bv n) :=
  {| enum := Z_to_bv n <$> (seqZ 0 (bv_modulus n)) |}.
Next Obligation.
  intros n. apply NoDup_alt. intros i j x.
  rewrite !list_lookup_fmap.
  intros [? [[??]%lookup_seqZ ?]]%fmap_Some.
  intros [? [[??]%lookup_seqZ Hz]]%fmap_Some. subst.
  apply bv_eq in Hz. rewrite !Z_to_bv_small in Hz; lia.
Qed.
Next Obligation.
  intros n x. apply elem_of_list_lookup. eexists (Z.to_nat (bv_unsigned x)).
  rewrite list_lookup_fmap. apply fmap_Some. eexists _.
  pose proof (bv_unsigned_in_range _ x). split.
  - apply lookup_seqZ. split; [done|]. rewrite Z2Nat.id; lia.
  - apply bv_eq. rewrite Z_to_bv_small; rewrite Z2Nat.id; lia.
Qed.

Lemma bv_1_ind (P : bv 1 → Prop) :
  P (@BV 1 1 I) → P (@BV 1 0 I) → ∀ b : bv 1, P b.
Proof.
  intros ??. apply Forall_finite. repeat constructor.
  - by assert ((@BV 1 0 I) = (Z_to_bv 1 (Z.of_nat 0 + 0))) as <- by by apply bv_eq.
  - by assert ((@BV 1 1 I) = (Z_to_bv 1 (Z.of_nat 1 + 0))) as <- by by apply bv_eq.
Qed.

(** * [bv_saturate]: Add range facts about bit vectors to the context *)
Ltac bv_saturate :=
  repeat match goal with b : bv _ |- _ => first [
     clear b | (* Clear if unused *)
     learn_hyp (bv_unsigned_in_range _ b) |
     learn_hyp (bv_signed_in_range _ b)
  ] end.

Ltac bv_saturate_unsigned :=
  repeat match goal with b : bv _ |- _ => first [
     clear b | (* Clear if unused *)
     learn_hyp (bv_unsigned_in_range _ b)
  ] end.

(** * Operations on [bv n] *)
Program Definition bv_0 (n : N) :=
  @BV n 0 _.
Next Obligation.
  intros n. apply bv_wf_in_range. split; [done| apply bv_modulus_pos].
Qed.
Global Instance bv_inhabited n : Inhabited (bv n) := populate (bv_0 n).

Definition bv_succ {n} (x : bv n) : bv n :=
  Z_to_bv n (Z.succ (bv_unsigned x)).
Definition bv_pred {n} (x : bv n) : bv n :=
  Z_to_bv n (Z.pred (bv_unsigned x)).

Definition bv_add {n} (x y : bv n) : bv n := (* SMT: bvadd *)
  Z_to_bv n (Z.add (bv_unsigned x) (bv_unsigned y)).
Definition bv_sub {n} (x y : bv n) : bv n := (* SMT: bvsub *)
  Z_to_bv n (Z.sub (bv_unsigned x) (bv_unsigned y)).
Definition bv_opp {n} (x : bv n) : bv n := (* SMT: bvneg *)
  Z_to_bv n (Z.opp (bv_unsigned x)).

Definition bv_mul {n} (x y : bv n) : bv n := (* SMT: bvmul *)
  Z_to_bv n (Z.mul (bv_unsigned x) (bv_unsigned y)).
Program Definition bv_divu {n} (x y : bv n) : bv n := (* SMT: bvudiv *)
  @BV n (Z.div (bv_unsigned x) (bv_unsigned y)) _.
Next Obligation.
  intros n x y. apply bv_wf_in_range. bv_saturate.
  destruct (decide (bv_unsigned y = 0)) as [->|?].
  { rewrite Zdiv_0_r. lia. }
  split; [ apply Z.div_pos; lia |].
  apply (Z.le_lt_trans _ (bv_unsigned x)); [|lia].
  apply Z.div_le_upper_bound; [ lia|]. nia.
Qed.
Program Definition bv_modu {n} (x y : bv n) : bv n := (* SMT: bvurem *)
  @BV n (Z.modulo (bv_unsigned x) (bv_unsigned y)) _.
Next Obligation.
  intros n x y. apply bv_wf_in_range. bv_saturate.
  destruct (decide (bv_unsigned y = 0)) as [->|?].
  { rewrite Zmod_0_r. lia. }
  split; [ apply Z.mod_pos; lia |].
  apply (Z.le_lt_trans _ (bv_unsigned x)); [|lia].
  apply Z.mod_le; lia.
Qed.
Definition bv_divs {n} (x y : bv n) : bv n :=
  Z_to_bv n (Z.div (bv_signed x) (bv_signed y)).
Definition bv_quots {n} (x y : bv n) : bv n := (* SMT: bvsdiv *)
  Z_to_bv n (Z.quot (bv_signed x) (bv_signed y)).
Definition bv_mods {n} (x y : bv n) : bv n := (* SMT: bvsmod *)
  Z_to_bv n (Z.modulo (bv_signed x) (bv_signed y)).
Definition bv_rems {n} (x y : bv n) : bv n := (* SMT: bvsrem *)
  Z_to_bv n (Z.rem (bv_signed x) (bv_signed y)).

Definition bv_shiftl {n} (x y : bv n) : bv n := (* SMT: bvshl *)
  Z_to_bv n (Z.shiftl (bv_unsigned x) (bv_unsigned y)).
Program Definition bv_shiftr {n} (x y : bv n) : bv n := (* SMT: bvlshr *)
  @BV n (Z.shiftr (bv_unsigned x) (bv_unsigned y)) _.
Next Obligation.
  intros n x y. apply bv_wf_in_range. bv_saturate.
  split; [ apply Z.shiftr_nonneg; lia|].
  rewrite Z.shiftr_div_pow2; [|lia].
  apply (Z.le_lt_trans _ (bv_unsigned x)); [|lia].
  pose proof (Z.pow_pos_nonneg 2 (bv_unsigned y)).
  apply Z.div_le_upper_bound; [ lia|]. nia.
Qed.
Definition bv_ashiftr {n} (x y : bv n) : bv n := (* SMT: bvashr *)
  Z_to_bv n (Z.shiftr (bv_signed x) (bv_unsigned y)).

Program Definition bv_or {n} (x y : bv n) : bv n := (* SMT: bvor *)
  @BV n (Z.lor (bv_unsigned x) (bv_unsigned y)) _.
Next Obligation.
  intros. eapply bv_wf_bitwise_op; [ apply Z.lor_spec |
    by intros; eapply Z.lor_nonneg | done | apply bv_is_wf..].
Qed.
Program Definition bv_and {n} (x y : bv n) : bv n := (* SMT: bvand *)
  @BV n (Z.land (bv_unsigned x) (bv_unsigned y)) _.
Next Obligation.
  intros. eapply bv_wf_bitwise_op; [ apply Z.land_spec |
    intros; eapply Z.land_nonneg; by left | done | apply bv_is_wf..].
Qed.
Program Definition bv_xor {n} (x y : bv n) : bv n := (* SMT: bvxor *)
  @BV n (Z.lxor (bv_unsigned x) (bv_unsigned y)) _.
Next Obligation.
  intros. eapply bv_wf_bitwise_op; [ apply Z.lxor_spec |
    intros; eapply Z.lxor_nonneg; naive_solver | done | apply bv_is_wf..].
Qed.
Program Definition bv_not {n} (x : bv n) : bv n := (* SMT: bvnot *)
  Z_to_bv n (Z.lnot (bv_unsigned x)).

(* [bv_zero_extends z b] extends [b] to [z] bits with 0. If [z] is
smaller than [n], [b] is truncated. Note that [z] gives the resulting
size instead of the number of bits to add (as SMTLIB does) to avoid a
type-level [_ + _] *)
Program Definition bv_zero_extend {n} (z : N) (b : bv n) : bv z := (* SMT: zero_extend *)
  Z_to_bv z (bv_unsigned b).

Program Definition bv_sign_extend {n} (z : N) (b : bv n) : bv z := (* SMT: sign_extend *)
  Z_to_bv z (bv_signed b).

(* s is start index and l is length. Note that this is different from
extract in SMTLIB which uses [extract (inclusive upper bound)
(inclusive lower bound)]. The version here is phrased in a way that
makes it impossible to use an upper bound that is lower than the lower
bound. *)
Definition bv_extract {n} (s l : N) (b : bv n) : bv l :=
  Z_to_bv l (bv_unsigned b ≫ Z.of_N s).

(* Note that we should always have n1 + n2 = n, but we use a parameter to avoid a type-level (_ + _) *)
Program Definition bv_concat n {n1 n2} (b1 : bv n1) (b2 : bv n2) : bv n := (* SMT: concat *)
  Z_to_bv n (Z.lor (bv_unsigned b1 ≪ Z.of_N n2) (bv_unsigned b2)).

Definition bv_to_little_endian m n (z : Z) : list (bv n) :=
  (λ b, Z_to_bv n b) <$> Z_to_little_endian m (Z.of_N n) z.

Definition little_endian_to_bv n (bs : list (bv n)) : Z :=
  little_endian_to_Z (Z.of_N n) (bv_unsigned <$> bs).

(** * Operations on [bv n] and Z *)
Definition bv_add_Z {n} (x : bv n) (y : Z) : bv n :=
  Z_to_bv n (Z.add (bv_unsigned x) y).
Definition bv_sub_Z {n} (x : bv n) (y : Z) : bv n :=
  Z_to_bv n (Z.sub (bv_unsigned x) y).
Definition bv_mul_Z {n} (x : bv n) (y : Z) : bv n :=
  Z_to_bv n (Z.mul (bv_unsigned x) y).

Definition bv_seq {n} (x : bv n) (len : Z) : list (bv n) :=
  (bv_add_Z x) <$> seqZ 0 len.

(** * Operations on [bv n] and bool *)
Definition bool_to_bv (n : N) (b : bool) : bv n :=
  Z_to_bv n (bool_to_Z b).

Definition bv_to_bits {n} (b : bv n) : list bool :=
  (λ i, Z.testbit (bv_unsigned b) i) <$> seqZ 0 (Z.of_N n).

(** * Notation for [bv] operations *)
Declare Scope bv_scope.
Delimit Scope bv_scope with bv.
Bind Scope bv_scope with bv.

Infix "+" := bv_add : bv_scope.
Infix "-" := bv_sub : bv_scope.
Notation "- x" := (bv_opp x) : bv_scope.
Infix "*" := bv_mul : bv_scope.
Infix "`divu`" := bv_divu (at level 35) : bv_scope.
Infix "`modu`" := bv_modu (at level 35) : bv_scope.
Infix "`divs`" := bv_divs (at level 35) : bv_scope.
Infix "`quots`" := bv_quots (at level 35) : bv_scope.
Infix "`mods`" := bv_mods (at level 35) : bv_scope.
Infix "`rems`" := bv_rems (at level 35) : bv_scope.
Infix "≪" := bv_shiftl : bv_scope.
Infix "≫" := bv_shiftr : bv_scope.
Infix "`ashiftr`" := bv_ashiftr (at level 35) : bv_scope.

Infix "`+Z`" := bv_add_Z (at level 50) : bv_scope.
Infix "`-Z`" := bv_sub_Z (at level 50) : bv_scope.
Infix "`*Z`" := bv_mul_Z (at level 40) : bv_scope.

(** * [bv_wrap_simplify]: typeclass-based automation for simplifying [bv_wrap] *)
(** The [bv_wrap_simplify] tactic removes [bv_wrap] where possible by
using the fact that [bv_wrap n (bv_warp n z) = bv_wrap n z]. The main
use case for this tactic is for proving the lemmas about the
operations of [bv n] below. Users should use the more extensive
automation provided by [bitvector_auto.v]. *)
Create HintDb bv_wrap_simplify_db discriminated.
Global Hint Constants Opaque : bv_wrap_simplify_db.
Global Hint Variables Opaque : bv_wrap_simplify_db.

Class BvWrapSimplify (n : N) (z z' : Z) := {
  bv_wrap_simplify_proof : bv_wrap n z = bv_wrap n z';
}.
Global Arguments bv_wrap_simplify_proof _ _ _ {_}.
Global Hint Mode BvWrapSimplify + + - : bv_wrap_simplify_db.

(** Default instance to end search. *)
Lemma bv_wrap_simplify_id n z :
  BvWrapSimplify n z z.
Proof. by constructor. Qed.
Global Hint Resolve bv_wrap_simplify_id | 1000 : bv_wrap_simplify_db.

(** [bv_wrap_simplify_bv_wrap] performs the actual simplification. *)
Lemma bv_wrap_simplify_bv_wrap n z z' :
  BvWrapSimplify n z z' →
  BvWrapSimplify n (bv_wrap n z) z'.
Proof. intros [->]. constructor. by rewrite bv_wrap_bv_wrap. Qed.
Global Hint Resolve bv_wrap_simplify_bv_wrap | 10 : bv_wrap_simplify_db.

(** The rest of the instances propagate [BvWrapSimplify].  *)
Lemma bv_wrap_simplify_succ n z z' :
  BvWrapSimplify n z z' →
  BvWrapSimplify n (Z.succ z) (Z.succ z').
Proof.
  intros [Hz]. constructor. by rewrite <-bv_wrap_succ_idemp, Hz, bv_wrap_succ_idemp.
Qed.
Global Hint Resolve bv_wrap_simplify_succ | 10 : bv_wrap_simplify_db.

Lemma bv_wrap_simplify_pred n z z' :
  BvWrapSimplify n z z' →
  BvWrapSimplify n (Z.pred z) (Z.pred z').
Proof.
  intros [Hz]. constructor. by rewrite <-bv_wrap_pred_idemp, Hz, bv_wrap_pred_idemp.
Qed.
Global Hint Resolve bv_wrap_simplify_pred | 10 : bv_wrap_simplify_db.

Lemma bv_wrap_simplify_opp n z z' :
  BvWrapSimplify n z z' →
  BvWrapSimplify n (- z) (- z').
Proof.
  intros [Hz]. constructor. by rewrite <-bv_wrap_opp_idemp, Hz, bv_wrap_opp_idemp.
Qed.
Global Hint Resolve bv_wrap_simplify_opp | 10 : bv_wrap_simplify_db.

Lemma bv_wrap_simplify_add n z1 z1' z2 z2' :
  BvWrapSimplify n z1 z1' →
  BvWrapSimplify n z2 z2' →
  BvWrapSimplify n (z1 + z2) (z1' + z2').
Proof.
  intros [Hz1] [Hz2]. constructor.
  by rewrite <-bv_wrap_add_idemp, Hz1, Hz2, bv_wrap_add_idemp.
Qed.
Global Hint Resolve bv_wrap_simplify_add | 10 : bv_wrap_simplify_db.

Lemma bv_wrap_simplify_sub n z1 z1' z2 z2' :
  BvWrapSimplify n z1 z1' →
  BvWrapSimplify n z2 z2' →
  BvWrapSimplify n (z1 - z2) (z1' - z2').
Proof.
  intros [Hz1] [Hz2]. constructor.
  by rewrite <-bv_wrap_sub_idemp, Hz1, Hz2, bv_wrap_sub_idemp.
Qed.
Global Hint Resolve bv_wrap_simplify_sub | 10 : bv_wrap_simplify_db.

Lemma bv_wrap_simplify_mul n z1 z1' z2 z2' :
  BvWrapSimplify n z1 z1' →
  BvWrapSimplify n z2 z2' →
  BvWrapSimplify n (z1 * z2) (z1' * z2').
Proof.
  intros [Hz1] [Hz2]. constructor.
  by rewrite <-bv_wrap_mul_idemp, Hz1, Hz2, bv_wrap_mul_idemp.
Qed.
Global Hint Resolve bv_wrap_simplify_mul | 10 : bv_wrap_simplify_db.

(** [bv_wrap_simplify_left] applies for goals of the form [bv_wrap n z1 = _] and
 tries to simplify them by removing any [bv_wrap] inside z1. *)
Ltac bv_wrap_simplify_left :=
  lazymatch goal with |- bv_wrap _ _ = _ => idtac end;
  etrans; [ notypeclasses refine (bv_wrap_simplify_proof _ _ _);
            typeclasses eauto with bv_wrap_simplify_db | ]
.

(** [bv_wrap_simplify] applies for goals of the form [bv_wrap n z1 = bv_wrap n z2] and
[bv_swrap n z1 = bv_swrap n z2] and tries to simplify them by removing any [bv_wrap]
and [bv_swrap] inside z1 and z2. *)
Ltac bv_wrap_simplify :=
  unfold bv_signed, bv_swrap;
  try match goal with | |- _ - _ = _ - _ => f_equal end;
  bv_wrap_simplify_left;
  symmetry;
  bv_wrap_simplify_left;
  symmetry.

Ltac bv_wrap_simplify_solve :=
  bv_wrap_simplify; f_equal; lia.

(** * Lemmas about [bv n] operations *)

(** ** Unfolding lemmas for the operations. *)
Section unfolding.
  Context {n : N}.
  Implicit Types (b : bv n).

  Lemma bv_0_unsigned :
    bv_unsigned (bv_0 n) = 0.
  Proof. done. Qed.
  Lemma bv_0_signed :
    bv_signed (bv_0 n) = 0.
  Proof. unfold bv_0. by rewrite bv_signed_BV, bv_swrap_0. Qed.

  Lemma bv_succ_unsigned b :
    bv_unsigned (bv_succ b) = bv_wrap n (Z.succ (bv_unsigned b)).
  Proof. done. Qed.
  Lemma bv_succ_signed b :
    bv_signed (bv_succ b) = bv_swrap n (Z.succ (bv_signed b)).
  Proof. unfold bv_succ. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed.

  Lemma bv_pred_unsigned b :
    bv_unsigned (bv_pred b) = bv_wrap n (Z.pred (bv_unsigned b)).
  Proof. done. Qed.
  Lemma bv_pred_signed b :
    bv_signed (bv_pred b) = bv_swrap n (Z.pred (bv_signed b)).
  Proof. unfold bv_pred. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed.

  Lemma bv_add_unsigned b1 b2 :
    bv_unsigned (b1 + b2) = bv_wrap n (bv_unsigned b1 + bv_unsigned b2).
  Proof. done. Qed.
  Lemma bv_add_signed b1 b2 :
    bv_signed (b1 + b2) = bv_swrap n (bv_signed b1 + bv_signed b2).
  Proof. unfold bv_add. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed.

  Lemma bv_sub_unsigned b1 b2 :
    bv_unsigned (b1 - b2) = bv_wrap n (bv_unsigned b1 - bv_unsigned b2).
  Proof. done. Qed.
  Lemma bv_sub_signed b1 b2 :
    bv_signed (b1 - b2) = bv_swrap n (bv_signed b1 - bv_signed b2).
  Proof. unfold bv_sub. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed.

  Lemma bv_opp_unsigned b :
    bv_unsigned (- b) = bv_wrap n (- bv_unsigned b).
  Proof. done. Qed.
  Lemma bv_opp_signed b :
    bv_signed (- b) = bv_swrap n (- bv_signed b).
  Proof. unfold bv_opp. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed.

  Lemma bv_mul_unsigned b1 b2 :
    bv_unsigned (b1 * b2) = bv_wrap n (bv_unsigned b1 * bv_unsigned b2).
  Proof. done. Qed.
  Lemma bv_mul_signed b1 b2 :
    bv_signed (b1 * b2) = bv_swrap n (bv_signed b1 * bv_signed b2).
  Proof. unfold bv_mul. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed.

  Lemma bv_divu_unsigned b1 b2 :
    bv_unsigned (b1 `divu` b2) = bv_unsigned b1 `div` bv_unsigned b2.
  Proof. done. Qed.
  Lemma bv_divu_signed b1 b2 :
    bv_signed (b1 `divu` b2) = bv_swrap n (bv_unsigned b1 `div` bv_unsigned b2).
  Proof. done. Qed.

  Lemma bv_modu_unsigned b1 b2 :
    bv_unsigned (b1 `modu` b2) = bv_unsigned b1 `mod` bv_unsigned b2.
  Proof. done. Qed.
  Lemma bv_modu_signed b1 b2 :
    bv_signed (b1 `modu` b2) = bv_swrap n (bv_unsigned b1 `mod` bv_unsigned b2).
  Proof. done. Qed.

  Lemma bv_divs_unsigned b1 b2 :
    bv_unsigned (b1 `divs` b2) = bv_wrap n (bv_signed b1 `div` bv_signed b2).
  Proof. done. Qed.
  Lemma bv_divs_signed b1 b2 :
    bv_signed (b1 `divs` b2) = bv_swrap n (bv_signed b1 `div` bv_signed b2).
  Proof. unfold bv_divs. rewrite Z_to_bv_signed. done. Qed.

  Lemma bv_quots_unsigned b1 b2 :
    bv_unsigned (b1 `quots` b2) = bv_wrap n (bv_signed b1 `quot` bv_signed b2).
  Proof. done. Qed.
  Lemma bv_quots_signed b1 b2 :
    bv_signed (b1 `quots` b2) = bv_swrap n (bv_signed b1 `quot` bv_signed b2).
  Proof. unfold bv_quots. rewrite Z_to_bv_signed. done. Qed.

  Lemma bv_mods_unsigned b1 b2 :
    bv_unsigned (b1 `mods` b2) = bv_wrap n (bv_signed b1 `mod` bv_signed b2).
  Proof. done. Qed.
  Lemma bv_mods_signed b1 b2 :
    bv_signed (b1 `mods` b2) = bv_swrap n (bv_signed b1 `mod` bv_signed b2).
  Proof. unfold bv_mods. rewrite Z_to_bv_signed. done. Qed.

  Lemma bv_rems_unsigned b1 b2 :
    bv_unsigned (b1 `rems` b2) = bv_wrap n (bv_signed b1 `rem` bv_signed b2).
  Proof. done. Qed.
  Lemma bv_rems_signed b1 b2 :
    bv_signed (b1 `rems` b2) = bv_swrap n (bv_signed b1 `rem` bv_signed b2).
  Proof. unfold bv_rems. rewrite Z_to_bv_signed. done. Qed.

  Lemma bv_shiftl_unsigned b1 b2 :
    bv_unsigned (b1 ≪ b2) = bv_wrap n (bv_unsigned b1 ≪ bv_unsigned b2).
  Proof. done. Qed.
  Lemma bv_shiftl_signed b1 b2 :
    bv_signed (b1 ≪ b2) = bv_swrap n (bv_unsigned b1 ≪ bv_unsigned b2).
  Proof. unfold bv_shiftl. rewrite Z_to_bv_signed. done. Qed.

  Lemma bv_shiftr_unsigned b1 b2 :
    bv_unsigned (b1 ≫ b2) = bv_unsigned b1 ≫ bv_unsigned b2.
  Proof. done. Qed.
  Lemma bv_shiftr_signed b1 b2 :
    bv_signed (b1 ≫ b2) = bv_swrap n (bv_unsigned b1 ≫ bv_unsigned b2).
  Proof. done. Qed.

  Lemma bv_ashiftr_unsigned b1 b2 :
    bv_unsigned (b1 `ashiftr` b2) = bv_wrap n (bv_signed b1 ≫ bv_unsigned b2).
  Proof. done. Qed.
  Lemma bv_ashiftr_signed b1 b2 :
    bv_signed (b1 `ashiftr` b2) = bv_swrap n (bv_signed b1 ≫ bv_unsigned b2).
  Proof. unfold bv_ashiftr. rewrite Z_to_bv_signed. done. Qed.

  Lemma bv_or_unsigned b1 b2 :
    bv_unsigned (bv_or b1 b2) = Z.lor (bv_unsigned b1) (bv_unsigned b2).
  Proof. done. Qed.
  Lemma bv_or_signed b1 b2 :
    bv_signed (bv_or b1 b2) = bv_swrap n (Z.lor (bv_unsigned b1) (bv_unsigned b2)).
  Proof. done. Qed.

  Lemma bv_and_unsigned b1 b2 :
    bv_unsigned (bv_and b1 b2) = Z.land (bv_unsigned b1) (bv_unsigned b2).
  Proof. done. Qed.
  Lemma bv_and_signed b1 b2 :
    bv_signed (bv_and b1 b2) = bv_swrap n (Z.land (bv_unsigned b1) (bv_unsigned b2)).
  Proof. done. Qed.

  Lemma bv_xor_unsigned b1 b2 :
    bv_unsigned (bv_xor b1 b2) = Z.lxor (bv_unsigned b1) (bv_unsigned b2).
  Proof. done. Qed.
  Lemma bv_xor_signed b1 b2 :
    bv_signed (bv_xor b1 b2) = bv_swrap n (Z.lxor (bv_unsigned b1) (bv_unsigned b2)).
  Proof. done. Qed.

  Lemma bv_not_unsigned b :
    bv_unsigned (bv_not b) = bv_wrap n (Z.lnot (bv_unsigned b)).
  Proof. done. Qed.
  Lemma bv_not_signed b :
    bv_signed (bv_not b) = bv_swrap n (Z.lnot (bv_unsigned b)).
  Proof. unfold bv_not. rewrite Z_to_bv_signed. done. Qed.

  Lemma bv_zero_extend_unsigned' z b :
    bv_unsigned (bv_zero_extend z b) = bv_wrap z (bv_unsigned b).
  Proof. done. Qed.
  (* [bv_zero_extend_unsigned] is the version that we want, but it
  only holds with a precondition. *)
  Lemma bv_zero_extend_unsigned z b :
    (n ≤ z)%N →
    bv_unsigned (bv_zero_extend z b) = bv_unsigned b.
  Proof.
    intros ?. rewrite bv_zero_extend_unsigned', bv_wrap_small; [done|].
    bv_saturate. pose proof (bv_modulus_le_mono n z). lia.
  Qed.
  Lemma bv_zero_extend_signed z b :
    bv_signed (bv_zero_extend z b) = bv_swrap z (bv_unsigned b).
  Proof. unfold bv_zero_extend. rewrite Z_to_bv_signed. done. Qed.

  Lemma bv_sign_extend_unsigned z b :
    bv_unsigned (bv_sign_extend z b) = bv_wrap z (bv_signed b).
  Proof. done. Qed.
  Lemma bv_sign_extend_signed' z b :
    bv_signed (bv_sign_extend z b) = bv_swrap z (bv_signed b).
  Proof. unfold bv_sign_extend. rewrite Z_to_bv_signed. done. Qed.
  (* [bv_sign_extend_signed] is the version that we want, but it
  only holds with a precondition. *)
  Lemma bv_sign_extend_signed z b :
    (n ≤ z)%N →
    bv_signed (bv_sign_extend z b) = bv_signed b.
  Proof.
    intros ?. rewrite bv_sign_extend_signed'.
    destruct (decide (n = 0%N)); subst.
    { by rewrite bv_signed_N_0, bv_swrap_0. }
    apply bv_swrap_small. bv_saturate.
    pose proof bv_half_modulus_le_mono n z. lia.
  Qed.

  Lemma bv_extract_unsigned s l b :
    bv_unsigned (bv_extract s l b) = bv_wrap l (bv_unsigned b ≫ Z.of_N s).
  Proof. done. Qed.
  Lemma bv_extract_signed s l b :
    bv_signed (bv_extract s l b) = bv_swrap l (bv_unsigned b ≫ Z.of_N s).
  Proof. unfold bv_extract. rewrite Z_to_bv_signed. done. Qed.

  Lemma bv_concat_unsigned' m  n2 b1 (b2 : bv n2) :
    bv_unsigned (bv_concat m b1 b2) = bv_wrap m (Z.lor (bv_unsigned b1 ≪ Z.of_N n2) (bv_unsigned b2)).
  Proof. done. Qed.
  (* [bv_concat_unsigned] is the version that we want, but it
  only holds with a precondition. *)
  Lemma bv_concat_unsigned m n2 b1 (b2 : bv n2) :
    (m = n + n2)%N →
    bv_unsigned (bv_concat m b1 b2) = Z.lor (bv_unsigned b1 ≪ Z.of_N n2) (bv_unsigned b2).
  Proof.
    intros ->. rewrite bv_concat_unsigned', bv_wrap_small; [done|].
    apply Z.bounded_iff_bits_nonneg'; [lia | |].
    { apply Z.lor_nonneg. bv_saturate. split; [|lia]. apply Z.shiftl_nonneg. lia. }
    intros k ?. rewrite Z.lor_spec, Z.shiftl_spec; [|lia].
    apply orb_false_intro; (eapply Z.bounded_iff_bits_nonneg; [..|done]); bv_saturate; try lia.
    - apply (Z.lt_le_trans _ (bv_modulus n)); [lia|]. apply Z.pow_le_mono_r; lia.
    - apply (Z.lt_le_trans _ (bv_modulus n2)); [lia|]. apply Z.pow_le_mono_r; lia.
  Qed.
  Lemma bv_concat_signed m n2 b1 (b2 : bv n2) :
    bv_signed (bv_concat m b1 b2) = bv_swrap m (Z.lor (bv_unsigned b1 ≪ Z.of_N n2) (bv_unsigned b2)).
  Proof. unfold bv_concat. rewrite Z_to_bv_signed. done. Qed.

  Lemma bv_add_Z_unsigned b z :
    bv_unsigned (b `+Z` z) = bv_wrap n (bv_unsigned b + z).
  Proof. done. Qed.
  Lemma bv_add_Z_signed b z :
    bv_signed (b `+Z` z) = bv_swrap n (bv_signed b + z).
  Proof. unfold bv_add_Z. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed.

  Lemma bv_sub_Z_unsigned b z :
    bv_unsigned (b `-Z` z) = bv_wrap n (bv_unsigned b - z).
  Proof. done. Qed.
  Lemma bv_sub_Z_signed b z :
    bv_signed (b `-Z` z) = bv_swrap n (bv_signed b - z).
  Proof. unfold bv_sub_Z. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed.

  Lemma bv_mul_Z_unsigned b z:
    bv_unsigned (b `*Z` z) = bv_wrap n (bv_unsigned b * z).
  Proof. done. Qed.
  Lemma bv_mul_Z_signed b z :
    bv_signed (b `*Z` z) = bv_swrap n (bv_signed b * z).
  Proof. unfold bv_mul_Z. rewrite Z_to_bv_signed. bv_wrap_simplify_solve. Qed.
End unfolding.

(** ** Properties of bv operations *)
Section properties.
  Context {n : N}.
  Implicit Types (b : bv n).
  Local Open Scope bv_scope.

  Lemma bv_sub_add_opp b1 b2:
    b1 - b2 = b1 + - b2.
  Proof.
    apply bv_eq. unfold bv_sub, bv_add, bv_opp. rewrite !Z_to_bv_unsigned.
    bv_wrap_simplify_solve.
  Qed.

  Global Instance bv_add_assoc : Assoc (=) (@bv_add n).
  Proof.
    intros ???. unfold bv_add. apply bv_eq. rewrite !Z_to_bv_unsigned.
    bv_wrap_simplify_solve.
  Qed.

  Global Instance bv_mul_assoc : Assoc (=) (@bv_mul n).
  Proof.
    intros ???. unfold bv_mul. apply bv_eq. rewrite !Z_to_bv_unsigned.
    bv_wrap_simplify_solve.
  Qed.

  Lemma bv_add_0_l b1 b2 :
    bv_unsigned b1 = 0 →
    b1 + b2 = b2.
  Proof.
    intros Hb. apply bv_eq.
    rewrite bv_add_unsigned, Hb, Z.add_0_l, bv_wrap_small; [done|apply bv_unsigned_in_range].
  Qed.

  Lemma bv_add_0_r b1 b2 :
    bv_unsigned b2 = 0 →
    b1 + b2 = b1.
  Proof.
    intros Hb. apply bv_eq.
    rewrite bv_add_unsigned, Hb, Z.add_0_r, bv_wrap_small; [done|apply bv_unsigned_in_range].
  Qed.

  Lemma bv_add_Z_0 b : b `+Z` 0 = b.
  Proof.
    unfold bv_add_Z. rewrite Z.add_0_r.
    apply bv_eq. apply Z_to_bv_small. apply bv_unsigned_in_range.
  Qed.

  Lemma bv_add_Z_add_r b m o:
    b `+Z` (m + o) = (b `+Z` o) `+Z` m.
  Proof.
    apply bv_eq. unfold bv_add_Z. rewrite !Z_to_bv_unsigned.
     bv_wrap_simplify_solve.
  Qed.

  Lemma bv_add_Z_add_l b m o:
    b `+Z` (m + o) = (b `+Z` m) `+Z` o.
  Proof.
    apply bv_eq. unfold bv_add_Z. rewrite !Z_to_bv_unsigned.
     bv_wrap_simplify_solve.
  Qed.

  Lemma bv_add_Z_succ b m:
    b `+Z` Z.succ m = (b `+Z` 1) `+Z` m.
  Proof.
    apply bv_eq. unfold bv_add_Z. rewrite !Z_to_bv_unsigned.
    bv_wrap_simplify_solve.
  Qed.

  Lemma bv_add_Z_inj_l b i j:
    0 ≤ i < bv_modulus n →
    0 ≤ j < bv_modulus n →
    b `+Z` i = b `+Z` j ↔ i = j.
  Proof.
    intros ??. split; [|naive_solver].
    intros Heq%bv_eq. rewrite !bv_add_Z_unsigned, !(Z.add_comm (bv_unsigned _)) in Heq.
    by rewrite <-bv_wrap_add_inj, !bv_wrap_small in Heq.
  Qed.

  Lemma bv_opp_not b:
    - b `-Z` 1 = bv_not b.
  Proof.
    apply bv_eq.
    rewrite bv_not_unsigned, bv_sub_Z_unsigned, bv_opp_unsigned, <-Z.opp_lnot.
    bv_wrap_simplify_solve.
  Qed.

  Lemma bv_and_comm b1 b2:
    bv_and b1 b2 = bv_and b2 b1.
  Proof. apply bv_eq. by rewrite !bv_and_unsigned, Z.land_comm. Qed.

  Lemma bv_or_comm b1 b2:
    bv_or b1 b2 = bv_or b2 b1.
  Proof. apply bv_eq. by rewrite !bv_or_unsigned, Z.lor_comm. Qed.

  Lemma bv_or_0_l b1 b2 :
    bv_unsigned b1 = 0 →
    bv_or b1 b2 = b2.
  Proof. intros Hb. apply bv_eq. by rewrite bv_or_unsigned, Hb, Z.lor_0_l. Qed.

  Lemma bv_or_0_r b1 b2 :
    bv_unsigned b2 = 0 →
    bv_or b1 b2 = b1.
  Proof. intros Hb. apply bv_eq. by rewrite bv_or_unsigned, Hb, Z.lor_0_r. Qed.

  Lemma bv_extract_0_unsigned l b:
    bv_unsigned (bv_extract 0 l b) = bv_wrap l (bv_unsigned b).
  Proof. rewrite bv_extract_unsigned, Z.shiftr_0_r. done. Qed.

  Lemma bv_extract_0_bv_add_distr l b1 b2:
    (l ≤ n)%N →
    bv_extract 0 l (bv_add b1 b2) = bv_add (bv_extract 0 l b1) (bv_extract 0 l b2).
  Proof.
    intros ?.
    apply bv_eq. rewrite !bv_extract_0_unsigned, !bv_add_unsigned, !bv_extract_0_unsigned.
    rewrite bv_wrap_bv_wrap by done.
    bv_wrap_simplify_solve.
  Qed.

  Lemma bv_concat_0 m n2 b1 (b2 : bv n2) :
    bv_unsigned b1 = 0 →
    bv_concat m b1 b2 = bv_zero_extend m b2.
  Proof.
    intros Hb1. apply bv_eq.
    by rewrite bv_zero_extend_unsigned', bv_concat_unsigned', Hb1, Z.shiftl_0_l, Z.lor_0_l.
  Qed.

  Lemma bv_zero_extend_idemp b:
    bv_zero_extend n b = b.
  Proof. apply bv_eq. by rewrite bv_zero_extend_unsigned. Qed.

  Lemma bv_sign_extend_idemp b:
    bv_sign_extend n b = b.
  Proof. apply bv_eq_signed. by rewrite bv_sign_extend_signed. Qed.
End properties.

(** ** Lemmas about [bv_to_little] and [bv_of_little] *)
Section little.

  Lemma bv_to_litte_endian_unsigned m n z:
    0 ≤ m →
    bv_unsigned <$> bv_to_little_endian m n z = Z_to_little_endian m (Z.of_N n) z.
  Proof.
    intros ?. apply list_eq. intros i. unfold bv_to_little_endian.
    rewrite list_lookup_fmap, list_lookup_fmap.
    destruct (Z_to_little_endian m (Z.of_N n) z !! i) eqn: Heq; [simpl |done].
    rewrite Z_to_bv_small; [done|].
    eapply (Forall_forall (λ z, _ ≤ z < _)); [ |by eapply elem_of_list_lookup_2].
    eapply Z_to_little_endian_bound; lia.
  Qed.

  Lemma bv_to_little_endian_to_bv m n bs:
    m = Z.of_nat (length bs) →
    bv_to_little_endian m n (little_endian_to_bv n bs) = bs.
  Proof.
    intros ->. eapply (fmap_inj bv_unsigned). { intros ???. by apply bv_eq. }
    rewrite bv_to_litte_endian_unsigned; [|lia].
    apply Z_to_little_endian_to_Z; [by rewrite fmap_length | lia |].
    apply Forall_forall. intros ? [?[->?]]%elem_of_list_fmap_2. apply bv_unsigned_in_range.
  Qed.

  Lemma little_endian_to_bv_to_little_endian m n z:
    0 ≤ m →
    little_endian_to_bv n (bv_to_little_endian m n z) = z `mod` 2 ^ (m * Z.of_N n).
  Proof.
    intros ?. unfold little_endian_to_bv.
    rewrite bv_to_litte_endian_unsigned; [|lia].
    apply little_endian_to_Z_to_little_endian; lia.
  Qed.

  Lemma bv_to_little_endian_length m n z :
    0 ≤ m →
    length (bv_to_little_endian m n z) = Z.to_nat m.
  Proof.
    intros ?. unfold bv_to_little_endian. rewrite fmap_length.
    apply Nat2Z.inj. rewrite Z_to_little_endian_length, ?Z2Nat.id; try lia.
  Qed.

  Lemma little_endian_to_bv_bound n bs :
    0 ≤ little_endian_to_bv n bs < 2 ^ (Z.of_nat (length bs) * Z.of_N n).
  Proof.
    unfold little_endian_to_bv. rewrite <-(fmap_length bv_unsigned bs).
    apply little_endian_to_Z_bound; [lia|].
    apply Forall_forall. intros ? [? [-> ?]]%elem_of_list_fmap.
    apply bv_unsigned_in_range.
  Qed.

  Lemma Z_to_bv_little_endian_to_bv_to_little_endian x m n (b : bv x):
    0 ≤ m →
    x = (Z.to_N m * n)%N →
    Z_to_bv x (little_endian_to_bv n (bv_to_little_endian m n (bv_unsigned b))) = b.
  Proof.
    intros ? ->. rewrite little_endian_to_bv_to_little_endian, Z.mod_small; [| |lia].
    - apply bv_eq. rewrite Z_to_bv_small; [done|]. apply bv_unsigned_in_range.
    - pose proof bv_unsigned_in_range _ b as Hr. unfold bv_modulus in Hr.
      by rewrite N2Z.inj_mul, Z2N.id in Hr.
  Qed.

  Lemma bv_to_little_endian_lookup_Some m n z (i : nat) x:
    0 ≤ m → bv_to_little_endian m n z !! i = Some x ↔
      Z.of_nat i < m ∧ x = Z_to_bv n (z ≫ (Z.of_nat i * Z.of_N n)).
  Proof.
    unfold bv_to_little_endian. intros Hm. rewrite list_lookup_fmap, fmap_Some.
    split.
    - intros [?[[??]%Z_to_little_endian_lookup_Some ?]]; [|lia..]; subst. split; [done|].
      rewrite <-bv_wrap_land. apply bv_eq. by rewrite !Z_to_bv_unsigned, bv_wrap_bv_wrap.
    - intros [?->]. eexists _. split; [apply Z_to_little_endian_lookup_Some; try done; lia| ].
      rewrite <-bv_wrap_land. apply bv_eq. by rewrite !Z_to_bv_unsigned, bv_wrap_bv_wrap.
  Qed.

  Lemma little_endian_to_bv_spec n bs i b:
    0 ≤ i → n ≠ 0%N →
    bs !! Z.to_nat (i `div` Z.of_N n) = Some b →
    Z.testbit (little_endian_to_bv n bs) i = Z.testbit (bv_unsigned b) (i `mod` Z.of_N n).
  Proof.
    intros ???. unfold little_endian_to_bv. apply little_endian_to_Z_spec; [lia|lia| |].
    { apply Forall_fmap. apply Forall_true. intros ?; simpl. apply bv_unsigned_in_range. }
    rewrite list_lookup_fmap. apply fmap_Some. naive_solver.
  Qed.
End little.

(** ** Lemmas about [bv_seq] *)
Section bv_seq.
  Context {n : N}.
  Implicit Types (b : bv n).

  Lemma bv_seq_length b len:
    length (bv_seq b len) = Z.to_nat len.
  Proof. unfold bv_seq. by rewrite fmap_length, seqZ_length. Qed.

  Lemma bv_seq_succ b m:
    0 ≤ m →
    bv_seq b (Z.succ m) = b :: bv_seq (b `+Z` 1) m.
  Proof.
    intros. unfold bv_seq. rewrite seqZ_cons by lia. csimpl.
    rewrite bv_add_Z_0. f_equal.
    assert (Z.succ 0 = 1 + 0) as -> by lia.
    rewrite <-fmap_add_seqZ, <-list_fmap_compose, Z.pred_succ. apply list_fmap_ext.
    intros i x. simpl. by rewrite bv_add_Z_add_l.
  Qed.

  Lemma NoDup_bv_seq b z:
    0 ≤ z ≤ bv_modulus n →
    NoDup (bv_seq b z).
  Proof.
    intros ?. apply NoDup_alt. intros i j b'. unfold bv_seq. rewrite !list_lookup_fmap.
    intros [?[[??]%lookup_seqZ ?]]%fmap_Some ; simplify_eq.
    intros [?[[->?]%lookup_seqZ ?%bv_add_Z_inj_l]]%fmap_Some; lia.
  Qed.
End bv_seq.

(** ** Lemmas about [bv] and [bool] *)
Section bv_bool.
  Implicit Types (b : bool).

  Lemma bool_to_bv_unsigned n b:
    n ≠ 0%N →
    bv_unsigned (bool_to_bv n b) = bool_to_Z b.
  Proof.
    intros ?. pose proof (bv_modulus_gt_1 n).
    apply Z_to_bv_small. destruct b; simpl; lia.
  Qed.

  Lemma bv_extract_bool_to_bv n n2 b:
    n ≠ 0%N → n2 ≠ 0%N →
    bv_extract 0 n (bool_to_bv n2 b) = bool_to_bv n b.
  Proof.
    intros ??. apply bv_eq. pose proof (bv_modulus_gt_1 n).
    rewrite bv_extract_unsigned, !bool_to_bv_unsigned, Z.shiftr_0_r by done.
    rewrite bv_wrap_small; [done|]. destruct b; simpl; lia.
  Qed.

  Lemma bv_not_bool_to_bv b:
    bv_not (bool_to_bv 1 b) = bool_to_bv 1 (negb b).
  Proof. apply bv_eq. by destruct b. Qed.

  Lemma bool_decide_bool_to_bv_0 b:
    bool_decide (bv_unsigned (bool_to_bv 1 b) = 0) = negb b.
  Proof. by destruct b. Qed.
  Lemma bool_decide_bool_to_bv_1 b:
    bool_decide (bv_unsigned (bool_to_bv 1 b) = 1) = b.
  Proof. by destruct b. Qed.
End bv_bool.

Section bv_bits.
  Context {n : N}.
  Implicit Types (b : bv n).

  Lemma bv_to_bits_length b : length (bv_to_bits b) = N.to_nat n.
  Proof. unfold bv_to_bits. rewrite fmap_length, seqZ_length, <-Z_N_nat, N2Z.id. done. Qed.

  Lemma bv_to_bits_lookup_Some b i x:
    bv_to_bits b !! i = Some x ↔ (i < N.to_nat n)%nat ∧ x = Z.testbit (bv_unsigned b) (Z.of_nat i).
  Proof.
    unfold bv_to_bits. rewrite list_lookup_fmap, fmap_Some.
    split.
    - intros [?[?%lookup_seqZ?]]. naive_solver lia.
    - intros [??]. eexists _. split; [|done]. apply lookup_seqZ. lia.
  Qed.

  Global Instance bv_to_bits_inj : Inj eq eq (@bv_to_bits n).
  Proof.
    unfold bv_to_bits. intros x y Hf.
    apply bv_eq_wrap. apply Z.bits_inj_iff'. intros i Hi.
    rewrite !bv_wrap_spec; [|lia..]. case_bool_decide; simpl; [|done].
    eapply list_fmap_inj_1 in Hf; [done|]. apply elem_of_seqZ. lia.
  Qed.
End bv_bits.

(** * [bvn] *)
Record bvn := bv_to_bvn {
  bvn_n : N;
  bvn_val : bv bvn_n;
}.
Global Arguments bv_to_bvn {_} _.
Add Printing Constructor bvn.

Definition bvn_unsigned (b : bvn) := bv_unsigned (b.(bvn_val)).

Lemma bvn_eq (b1 b2 : bvn) :
  b1 = b2 ↔ b1.(bvn_n) = b2.(bvn_n) ∧ bvn_unsigned b1 = bvn_unsigned b2.
Proof. split; [ naive_solver|]. destruct b1, b2; simpl; intros [??]. subst. f_equal. by apply bv_eq. Qed.

Global Program Instance bvn_eq_dec : EqDecision bvn := λ '(@bv_to_bvn n1 b1) '(@bv_to_bvn n2 b2),
   cast_if_and (decide (n1 = n2)) (decide (bv_unsigned b1 = bv_unsigned b2)).
(* TODO: The following does not compute to eq_refl*)
Next Obligation. intros. apply bvn_eq. naive_solver. Qed.
Next Obligation. intros. intros ?%bvn_eq. naive_solver. Qed.
Next Obligation. intros. intros ?%bvn_eq. naive_solver. Qed.

Definition bvn_to_bv (n : N) (b : bvn) : option (bv n) :=
  match decide (b.(bvn_n) = n) with
  | left eq => Some (eq_rect (bvn_n b) (λ n0 : N, bv n0) (bvn_val b) n eq)
  | right _ => None
  end.
Global Arguments bvn_to_bv !_ !_ /.

Global Coercion bv_to_bvn : bv >-> bvn.

(** * Opaqueness *)
(** We mark all functions on bitvectors as opaque. *)
Global Hint Opaque Z_to_bv
       bv_0 bv_succ bv_pred
       bv_add bv_sub bv_opp
       bv_mul bv_divu bv_modu
       bv_divs bv_quots bv_mods bv_rems
       bv_shiftl bv_shiftr bv_ashiftr bv_or
       bv_and bv_xor bv_not bv_zero_extend
       bv_sign_extend bv_extract bv_concat
       bv_add_Z bv_sub_Z bv_mul_Z
       bool_to_bv bv_to_bits : typeclass_instances.
Global Opaque Z_to_bv
       bv_0 bv_succ bv_pred
       bv_add bv_sub bv_opp
       bv_mul bv_divu bv_modu
       bv_divs bv_quots bv_mods bv_rems
       bv_shiftl bv_shiftr bv_ashiftr bv_or
       bv_and bv_xor bv_not bv_zero_extend
       bv_sign_extend bv_extract bv_concat
       bv_add_Z bv_sub_Z bv_mul_Z
       bool_to_bv bv_to_bits.


(************************************************************
* Lambda-calculus,                                          *
* Indexed pretty-big-step semantics                         *
*************************************************************)

Set Implicit Arguments.
Require Import Lambda_Syntax Lambda_Pretty.

Implicit Types v : val.
Implicit Types t : trm.
Implicit Types o : out.
Implicit Types e : ext.

(*==========================================================*)
(* * Definitions *)

(************************************************************)
(* ** Semantics *)

(** Order on the indices, [Lo o n n'] is
    equivalent to [o = out_div \/ n < n']. *)

Definition Lo o (n n':nat) :=
  match o with
  | out_div => True
  | _ => n < n'
  end.

(** Semantics *)

CoInductive ired : nat -> ext -> out -> Prop :=
  | ired_val : forall n v,
      ired n v v
  | ired_abs : forall n x t,
      ired n (trm_abs x t) (val_clo x t)
  | ired_app : forall n2 n1 n t1 t2 o1 o,
      ired n1 t1 o1 -> Lo o n1 n ->
      ired n2 (ext_app_1 o1 t2) o -> Lo o n2 n ->
      ired n (trm_app t1 t2) o
  | ired_app_1_div : forall n t2,
      ired n (ext_app_1 out_div t2) out_div
  | ired_app_1 : forall n2 n1 n v1 t2 o o2,
      ired n1 t2 o2 -> Lo o n1 n ->
      ired n2 (ext_app_2 v1 o2) o -> Lo o n2 n ->
      ired n (ext_app_1 v1 t2) o
  | ired_app_2_div : forall n v1,
      ired n (ext_app_2 v1 out_div) out_div
  | ired_app_2 : forall n1 n x t3 v2 o,
      ired n1 (subst x v2 t3) o -> Lo o n1 n ->
      ired n (ext_app_2 (val_clo x t3) v2) o.

Definition iredval e v := exists n, ired n e v.

Definition idiverge e := exists n, ired n e out_div.

(*==========================================================*)
(* * Proofs *)

(************************************************************)
(* ** Monotonicity properties *)

Hint Constructors ired.
Hint Unfold Lo.
Hint Extern 1 (_ < _) => math.
Hint Extern 1 (_ <> _) => math.

Lemma lt_Lo : forall o n1 n2,
  n1 < n2 -> Lo o n1 n2.
Proof. unfolds Lo. destruct o. math. auto. Qed.

Lemma Lo_le : forall o n1 n2 n2',
  Lo o n1 n2 -> n2 <= n2' -> Lo o n1 n2'.
Proof. unfolds Lo. destruct o. math. auto. Qed.

Hint Resolve lt_Lo Lo_le.

Lemma ired_le : forall n n' e o,
  ired n e o -> n <= n' -> ired n' e o.
Proof.
  cofix IH. introv R L. inverts R; try solve [ constructors* ].
Qed.

Lemma ired_div_n : forall n n' e,
  ired n e out_div -> ired n' e out_div.
Proof.
  cofix IH. introv R. inverts R; try solve [ constructors* ].
Qed.

(************************************************************)
(* ** Equivalence with pretty-big-step *)

Require Import Lambda_Pretty.
Hint Constructors red.

(** [red] to [iredval] *)

Lemma red_ired : forall e o,
  red e o -> exists n, ired n e o.
Proof.
  unfold iredval. introv H.
  forwards (n&M): red_redh (rm H).
  exists ((n+n+n)%nat).
  induction M; auto.
  applys* ired_app ((n+n+n)%nat).
  applys* ired_app_1 ((n+n+n)%nat).
  applys* ired_app_2 ((n+n+n)%nat).
Qed.

Corollary red_iredval : forall e v,
  red e v -> iredval e v.
Proof. introv R. applys* red_ired. Qed.

(** [iredval] to [red] *)

Lemma iredval_red : forall e v,
  iredval e v -> red e v.
Proof.
  introv (n&R). gen e v. induction n using peano_induction.
  asserts IH: (forall m e v, ired m e v -> m < n -> red e v).
    autos*. clear H.
  introv R. inverts R as; auto.
  introv R1 L1 R2 L2. destruct o1; [ | inverts R2 ]. autos*.
  introv R1 L1 R2 L2. destruct o2; [ | inverts R2 ]. autos*.
  introv R1 L1. autos*.
Qed.

(** [diverge] to [idiverge] *)

Lemma cored_red_or_diverge : forall e o,
  cored e o -> (exists n, ired n e o) \/ diverge e.
Proof.
  introv R. lets [H|H]: cored_to_diverge_or_red R.
  right*.
  left. applys* red_ired.
Qed.

Section DivHints.
Definition ired_app_1_div_zero := ired_app_1_div 0.
Definition ired_app_2_div_zero := ired_app_2_div 0.
Hint Resolve ired_app_1_div_zero ired_app_2_div_zero.

Lemma diverge_idiverge : forall e,
  diverge e -> idiverge e.
Proof.
  unfold idiverge. introv R. exists O. gen e. cofix IH.
  introv R. inverts R as.
  introv R1 R2. lets [(n1&M1)|M1]: cored_red_or_diverge R1; constructors*.
  constructors*.
  introv R1 R2. lets [(n1&M1)|M1]: cored_red_or_diverge R1; constructors*.
  constructors*.
  introv R1. constructors*.
Qed.

End DivHints.

(** [idiverge] to [diverge] *)

Lemma ired_cored : forall n e o,
  ired n e o -> cored e o.
Proof. cofix IH. introv R. inverts R as; constructors*. Qed.

Corollary idiverge_diverge : forall e,
  idiverge e -> diverge e.
Proof. introv (n&R). applys* ired_cored. Qed.

(************************************************************)
(* ** Equivalence with big-step *)

Require Import Lambda_Big.
Hint Constructors bigred.

(** [bigred] to [iredval] *)

Lemma bigred_iredval : forall t v,
  bigred t v -> iredval t v.
Proof.
  unfold iredval. introv H.
  forwards (n&M): bigred_bigredh (rm H).
  exists ((n+n+n)%nat).
  induction M; auto.
  applys* ired_app ((S n+S n+n)%nat).
   applys* ired_app_1 ((S n+n+n)%nat).
Qed.

(** [iredval] to [bigred] *)

Lemma iredval_bigred : forall t v,
  iredval t v -> bigred t v.
Proof.
  introv (n&R). gen t v. induction n using peano_induction.
  asserts IH: (forall m t v, ired m t v -> m < n -> bigred t v).
    autos*. clear H.
  introv R. inverts R as; auto.
  introv R1 L1 R2 L2. inverts R2 as R3 L3 R4 L4.
   inverts R4 as R5 L5. unfolds Lo. constructors*.
Qed.

(** [bigdiv] to [idiverge] *)

Lemma ired_bigred : forall n t v,
  ired n t v -> bigred t v.
Proof. introv R. apply* iredval_bigred. exists* n. Qed.

Lemma bigdiv_idiverge : forall t,
  bigdiv t -> idiverge t.
Proof.
  introv R. exists O. gen t. cofix IH.
  introv H. inverts H as.
  introv R1. applys* ired_app O.
  introv R1 R2. forwards (n1&M1): bigred_iredval R1.
   applys ired_app O. eauto. eauto. applys* ired_app_1 O. auto.
  introv R1 R2 R3. forwards (n1&M1): bigred_iredval R1.
    forwards (n2&M2): bigred_iredval R2.
    applys ired_app O. eauto. eauto. applys* ired_app_1 O. auto.
Qed.

(** [idiverge] to [bigdiv] *)

Lemma idiverge_bigdiv : forall t,
  idiverge t -> bigdiv t.
Proof.
  hint ired_bigred.
  introv (n&R). gen n t. cofix IH.
  introv R. inverts R as R1 L1 R2 L2.
  inverts R2 as.
    apply* bigdiv_app_1.
    introv R3 L3 R4 L4. inverts R4 as.
      apply* bigdiv_app_2.
      introv R5 L5. apply* bigdiv_app_3.
Qed.