Load "foo_axioms".

(** * FOO Voting Prtocol *)
(** ** Phase-I *)
(**
- V -> A : (V, sign(blind(commit(v, r), r'), sk(V)))

- A-> V :  sign(blind(commit(v, r), r'), sk(A)) *)

(** - We assume that Administrator and collector are dishonest
    - Hence, random numbers used to generate keys (pair) of them included in attacker's knowledge *)

(** * ProtocolPhase-I: There are two voters [V1] and [V2], and their corresponding votes [va] and [vb] respectively. *)

(** * Frame [phi0]: initial knowledge *)
(** 1-Voter1, 2-Voter2, 3-Administrator, 4-Collector, 5-Mixnet
[(pk 0)] represents a public key used in commitment shceme. *)

Definition vt (n:nat) := (v (nonce n)).
Definition phi0:= [msg (pk 1); msg (pk 2);  msg (pk 3); msg (nonce 4); msg (pk 5); msg (nonce 6)].

(** * Frame [phi11] *)

(** commitments *)

Definition b (n' n'':nat) := (commit (v (nonce n')) (r n'')).
Definition e (t:message) (n':nat) := (blind t (pk 3) (r n')).

(** Converting [mylist] to [list message] *)

Definition mphi0 := (conv_mylist_listm phi0).

(** attacker's computation *)

Definition x1 := (f mphi0).

Definition q0 n1 n2 :=  (ifm (eqm (to x1) (V 1)) ((pk 1), ((e (b n1 7) 8) , (sign (sk 1) (ONE, (e (b n1 7) 8)))))
		    	            (ifm  (eqm (to x1) (V 2))  ((pk 2), ( (e (b n2 9) 10),  (sign (sk 2) (ONE, (e (b n2 9) 10)))))
                                                    O)).

(** attacker's knowledge *)

Definition phi1 n1 n2 := phi0 ++ [msg (q0 n1 n2)].

(** * Frame [phi2] *)
Fixpoint traces {n} (l:mylist n) : list (list oursum):= cons (ifmT l) (cons (ifmE l) nil).

(*Eval compute in ifmT (phi1 0 1). *)
(*Eval compute in (ifmT (conv_listos_mylist (ifmE (phi1 0 1)))). *)
(*Eval compute in (ifmE (conv_listos_mylist (ifmE (phi1 0 1)))). *)
Definition phi1t n1 := phi0 ++ [msg ((pk 1), ((e (b n1 7) 8) , (sign (sk 1) (ONE, (e (b n1 7) 8)))))].
Definition x2t n1 := (f (conv_mylist_listm (phi1t n1))).

Definition phi1ft  n2 := phi0 ++ [msg  ((pk 2), ( (e (b n2 9) 10),  (sign (sk 2) (ONE, (e (b n2 9) 10)))))].

Definition x2ft n2 := (f (conv_mylist_listm (phi1ft n2))).

(**************************************************************************)
Definition mphi1 n1 n2 := (conv_mylist_listm (phi1 n1 n2)).
Definition x2 n1 n2 := (f (mphi1 n1 n2)).

Definition q1 n1 n2 := (ifm (eqm (to (x2t n1)) (V 1))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x2t n1)))  ok
			            (ifm (eqm (to (x2t n1)) (V 2))  ((pk 2), ( (e (b n2 11) 12),  (sign (sk 2) (ONE, (e (b n2 11) 12)))))
                                                  O)).

Definition q2 n1 n2 :=  (ifm (eqm (to (x2ft n2)) (V 2))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x2ft n2)))  ok
			           (ifm (eqm (to (x2ft n2)) (V 1))  ((pk 1), ( (e (b n1 13) 14),  (sign (sk 1) (ONE, (e (b n1 13) 14)))))
                                                   O)).

Definition t1 n1 n2 :=  (ifm (eqm (to x1) (V 1)) (q1 n1 n2)
		    	     (ifm (eqm (to x1) (V 2))  (q2 n1 n2) O)).

Definition phi2 n1 n2 := (phi1 n1 n2) ++ [msg (t1 n1 n2)].

 (** * Frame [phi3] *)
   (** T *)

Definition phi2tt n1 := (phi1t n1) ++ [msg ok].
Definition x3tt n1 := (f (conv_mylist_listm (phi2tt n1))).

Definition phi2tft n1 n2 := (phi1t n1) ++ [msg ((pk 2), ( (e (b n2 11) 12),  (sign (sk 2) (ONE, (e (b n2 11) 12)))))].
Definition x3tft n1 n2 := (f (conv_mylist_listm (phi2tft n1 n2))).

(** FT *)

Definition phi2ftt n2 := (phi1ft n2) ++ [msg ok].
Definition x3ftt n2 := (f (conv_mylist_listm (phi2ftt n2))).

Definition phi2ftft n1 n2  := (phi1ft n2) ++ [msg  (pk 1, (e (b n1 13) 14, sign (sk 1) (ONE, (e (b n1 13) 14))))].
Definition x3ftft n1 n2 := (f (conv_mylist_listm (phi2ftft n1 n2))).

(*Eval compute in x3ftft  0 1. *)
(*Eval compute in x3ftft 1 0. *)

(****************************************************************)
Definition mphi2 n1 n2:= (conv_mylist_listm (phi2 n1 n2)).
Definition x3 n1 n2 := (f (mphi2 n1 n2)).

Definition q11 n1 n2 :=  (ifm  (eqm (to (x3tt n1 )) (V 2))  ((pk 2), ( (e (b n2 19) 20),  (sign (sk 2) (ONE, (e (b n2 19) 20))))) O).

Definition q12 n1 n2 := (ifm (eqm (to (x3tft n1 n2)) (V 1))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x3tft n1 n2))) ok
                                    (ifm (eqm (to (x3tft n1 n2)) (V 2))& (bacc (pk 3) (b n2 11) (r 12) (pi2 (x3tft n1 n2))) ok
                                                  O)).

Definition q21 n1 n2 := (ifm  (eqm (to (x3ftt n2)) (V 1))  ((pk 1), ( (e (b n1 23) 24),  (sign (sk 1) (ONE, (e (b n1 23) 24)))))
                                    O).

Definition q22 n1 n2 := (ifm (eqm (to (x3ftft n1 n2 )) (V 1))& (bacc (pk 3) (b n1 13) (r 14) (pi1 (x3ftft n1 n2 ))) ok
                                    (ifm (eqm (to (x3ftft n1 n2 )) (V 2))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x3ftft n1 n2 ))) ok
                                                    O)).

(********************************************************************************************)

Definition q1_s n1 n2 := (ifm (eqm (to (x2t n1)) (V 1))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x2t n1 )))  (q11 n1 n2)
			           (ifm (eqm (to (x2t n1 )) (V 2))  (q12 n1 n2)
                                                   O)).

Definition q2_s n1 n2 :=  (ifm (eqm (to (x2ft  n2)) (V 2))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x2ft  n2)))  (q21 n1 n2 )
			           (ifm (eqm (to (x2ft  n2)) (V 1))  (q22 n1 n2)
                                                   O)).

Definition t2 n1 n2 :=  (ifm (eqm (to x1) (V 1)) (q1_s n1 n2)
		    	           (ifm (eqm (to x1) (V 2))  (q2_s n1 n2)
                                                   O)).

Definition phi3  n1 n2 := (phi2 n1 n2) ++ [msg (t2 n1 n2)].
(** * Frame [phi4] *)
Definition mphi3ttt n1 n2 := (phi2tt n1) ++ [msg ((pk 2), ( (e (b n2 19) 20),  (sign (sk 2) (ONE, (e (b n2 19) 20)))))].
Definition x4ttt n1 n2 := (f (conv_mylist_listm (mphi3ttt n1 n2))).

Definition phi3tftt n1 n2 := (phi2tft n1 n2) ++ [msg ok].
Definition x4tftt n1 n2 := (f (conv_mylist_listm (phi3tftt n1 n2))).

Definition phi3tftft n1 n2 := (phi2tft n1 n2) ++ [msg ok].
Definition x4tftft n1 n2 := (f (conv_mylist_listm (phi3tftft n1 n2))).

Definition phi3fttt n1 n2 := (phi2ftt n2) ++ [msg  ((pk 1), ( (e (b n1 23) 24),  (sign (sk 1) (ONE, (e (b n1 23) 24)))))].

Definition x4fttt n1 n2 := (f (conv_mylist_listm (phi3fttt n1 n2))).

Definition phi3ftftt n1 n2:= (phi2ftft n1 n2) ++ [msg ok].
Definition x4ftftt n1 n2 := (f (conv_mylist_listm (phi3ftftt n1 n2))).
Definition phi3ftftft n1 n2:= (phi2ftft n1 n2) ++ [msg ok].
Definition x4ftftft n1 n2 := (f (conv_mylist_listm (phi3ftftft n1 n2))).

(**********************************)
Definition q111 n1 n2 := (ifm  (eqm (to (x4ttt n1 n2)) (V 2))& (bacc (pk 3) (b n2 19) (r 20) (pi2 (x4ttt n1 n2))) ok
                                     O).

 (*************************************************)

Definition q121 n1 n2 := (ifm (eqm (to (x4tftt n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 11) (r 12) (pi2 (x4tftt n1 n2))) ok
                         O).

Definition q122 n1 n2 := (ifm (eqm (to (x4tftft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x4tftft n1 n2))) ok
                         O).

Definition q211 n1 n2 :=  (ifm (eqm (to (x4fttt n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 23) (r 24) (pi1 (x4fttt n1 n2))) ok
                          O).

(***************************************************)

Definition q221 n1 n2:=   (ifm (eqm (to (x4ftftt n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x4ftftt n1 n2))) ok
                           O).
Definition q222 n1 n2 :=  (ifm (eqm (to (x4ftftft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 13) (r 14) (pi1 (x4ftftft n1 n2))) ok O).

(*****************************************)

Definition q11_s n1 n2 :=  (ifm  (eqm (to (x3tt n1 )) (V 2)) (q111 n1 n2)
                                      O).

Definition q12_s n1 n2 := (ifm (eqm (to (x3tft n1 n2)) (V 1))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x3tft n1 n2))) (q121 n1 n2)
                                    (ifm (eqm (to (x3tft n1 n2)) (V 2))& (bacc (pk 3) (b n2 11) (r 12) (pi2 (x3tft n1 n2))) (q122 n1 n2)
                                                 O)).

Definition q21_s n1 n2 := (ifm  (eqm (to (x3ftt n2)) (V 1))  (q211 n1 n2)
                                   O).

Definition q22_s n1 n2  := (ifm (eqm (to (x3ftft n1 n2)) (V 1))& (bacc (pk 3) (b n1 13) (r 14) (pi1 (x3ftft n1 n2))) (q221 n1 n2)
                                    (ifm (eqm (to (x3ftft n1 n2)) (V 2))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x3ftft n1 n2))) (q222 n1 n2)
                                                   O)).

(********************************************************************************************)

Definition q1_ss n1 n2 := (ifm (eqm (to (x2t n1 )) (V 1))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x2t n1 )))  (q11_s n1 n2)
			           (ifm (eqm (to (x2t n1 )) (V 2))  (q12_s n1 n2)
                                                  O)).

Definition q2_ss n1 n2 :=  (ifm (eqm (to (x2ft n2)) (V 2))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x2ft n2)))  (q21_s n1 n2)
			           (ifm (eqm (to (x2ft n2)) (V 1))  (q22_s n1 n2)
                                                   O)).

Definition t3 n1 n2 :=  (ifm (eqm (to x1) (V 1)) (q1_ss n1 n2)
		    	           (ifm (eqm (to x1) (V 2))  (q2_ss n1 n2)
                                                   O )).

Definition phi4 n1 n2 := (phi3 n1 n2) ++ [msg (t3 n1 n2)].

 (** Tactics *)

Ltac unf_phi := try unfold phi0, phi1, phi2. (* phi3 phi4,  phi5.*)

Ltac unf_q :=  try unfold q0, q1, q2.
Ltac unf_trm:=  try unfold t1. (*t2, t3, t4.*)

Ltac unf := try unf_phi; try unf_trm; try unf_q.

 (** blindness *)
Ltac aply_blindness n n1 n2 n3 n4 m0 m1 t1 t2 l  := pose proof( blindness n n1 n2 n3 n4 m0 m1 t1 t2 l ) as H.

(** Using [funapptrmhyp] *)
Ltac appconst H:=
  funappmconst ok H; funappmconst (V 1) H; funappmconst (V 2) H; funappmconst O H; funappmconst ONE H; funappmconst TWO H; funappmconst THREE H;  funappbconst FAlse H; try reflexivity.
 Ltac x1checks x1 x2 H := funapptrmhyp (msg x1) (msg x2) H ;
                   funapptrmhyp (msg (to x1)) (msg (to x2)) H;
                    funapptrmhyp (bol (eqm (to x1) (V 1))) (bol (eqm (to x2) (V 1))) H;
                   funapptrmhyp (bol (eqm (to x1) (V 2))) (bol (eqm (to x2) (V 2))) H;
                   funapptrmhyp (bol (eqm (to x1) (pk 3))) (bol (eqm (to x2) (pk 3))) H; try reflexivity.

Axiom fresh_blind : forall (n1 n2 n3 n4 n5 n6 n7 : nat) {n} (l1 l2 :mylist n),
                      (l1 ++ [msg (e (b n1 n2) n3)]) ~ (l2 ++ [msg (e (b n4 n5) n6)]) ->  Fresh [n7] (l1 ++ [msg (e (b n1 n2) n3)] ++  l2 ++ [msg (e (b n4 n5) n6)]) = true  -> (l1 ++ [msg (e (b n1 n2) n7)])  ~ (l2 ++ [msg (e (b n4 n5) n7)]).
Axiom fresh_commit : forall (n1 n2 n3 n4 n5 n6 n7 : nat) {n} (l1 l2 :mylist n), Fresh [n7] (l1++ [msg (e (b n1 n2) n3)] ++  l2 ++ [msg (e (b n4 n5) n6)]) = true ->
                      (l1 ++ [msg (e (b n1 n2) n3)]) ~ (l2 ++ [msg (e (b n4 n5) n6)]) -> (l1 ++ [msg (e (b n1 n7) n3)]) ~ (l2 ++ [msg (e (b n4 n7) n6)]).

 Ltac adminchecks t1 t2 H:=
  funapptrmhyp (msg (pi1 t1)) (msg (pi1 t2)) H;
  funapptrmhyp (msg (pi1 (pi1 t1))) (msg (pi1 (pi1 t2))) H;
  funapptrmhyp (msg (pi2 (pi1 t1))) (msg (pi2 (pi1 t2))) H;
  funapptrmhyp (msg (pi1 (pi2 (pi1 t1)))) (msg (pi1 (pi2 (pi1 t2)))) H;
  funapptrmhyp (msg (pi2 (pi2 (pi1 t1)))) (msg (pi2 (pi2 (pi1 t2)))) H;
  funapptrmhyp (msg (pi2 t1)) (msg (pi2 t2)) H;
  funapptrmhyp (msg (pi1 (pi2 t1))) (msg (pi1 (pi2 t2))) H;
  funapptrmhyp (msg (pi2 (pi2 t1))) (msg (pi2 (pi2 t2))) H;
  funapptrmhyp (msg (pi1 (pi2 (pi2 t1)))) (msg (pi1 (pi2 (pi2 t2)))) H;
  funapptrmhyp (msg (pi2 (pi2 (pi2 t1)))) (msg (pi2 (pi2 (pi2 t2)))) H;
   funapptrmhyp (msg (bsign (sk 3) (pi1 (pi2 (pi1 t1))) )) (msg (bsign (sk 3) (pi1 (pi2 (pi1 t2))) )) H;
  funapptrmhyp (msg (bsign (sk 3) (pi1 (pi2 (pi2 t1))) )) (msg (bsign (sk 3) (pi1 (pi2 (pi2 t2))) )) H;
  funapptrmhyp (msg ((bsign (sk 3) (pi1 (pi2 (pi1 t1))) ) , (bsign (sk 3) (pi1 (pi2 (pi2 t1))) ))) (msg ((bsign (sk 3) (pi1 (pi2 (pi1 t2))) ), (bsign (sk 3) (pi1 (pi2 (pi2 t2))) ))) H;
 funapptrmhyp (bol (ver (pk 1)  (pi1 (pi2 (pi1 t1))) (pi2 (pi2 (pi1 t1))))) (bol (ver (pk 1)  (pi1 (pi2 (pi1 t2))) (pi2 (pi2 (pi1 t2))))) H;
 funapptrmhyp (bol (ver (pk 2)  (pi1 (pi2 (pi2 t1))) (pi2 (pi2 (pi2 t1)))))  (bol (ver (pk 2)  (pi1 (pi2 (pi2 t2))) (pi2 (pi2 (pi2 t2))))) H.

   Ltac funapp_vtrm a v1 v2 ck bk m H  :=
funapptrmhyp (msg (m, (e (b v1 ck) bk))) (msg (m, (e (b v2 ck) bk))) H;
     funapptrmhyp (msg (sign (sk a) (m, (e (b v1 ck) bk))))  (msg (sign (sk a) (m, (e (b v2 ck) bk)))) H;
 funapptrmhyp  (msg ((e (b v1 ck) bk), (sign (sk a) (m, (e (b v1 ck) bk)))))  (msg ((e (b v2 ck) bk), (sign (sk a) (m, (e (b v2 ck) bk))))) H;
 funapptrmhyp  (msg (pk a, ((e (b v1 ck) bk), (sign (sk a) (m, (e (b v1 ck) bk))))))  (msg (pk a, ((e (b v2 ck) bk), (sign (sk a) (m, (e (b v2 ck) bk)))))) H; try reflexivity.
   Ltac bacctac v1 v2 ck bk t1 t2 H:=
      funapptrmhyp (msg (pi1 t1)) (msg (pi1 t2)) H;
     funapptrmhyp (bol (bacc (pk 3) (b v1 ck) (r bk) (pi1 t1))) (bol (bacc (pk 3) (b v2 ck) (r bk) (pi1 t2))) H;
    funapptrmhyp (msg (pi2 t1)) (msg (pi2 t2)) H;
    funapptrmhyp (bol (bacc (pk 3) (b v1 ck) (r bk) (pi2 t1))) (bol (bacc (pk 3) (b v2 ck) (r bk) (pi2 t2))) H; try reflexivity.
(** tactics related to application of unforgeability *)
   (*
    Ltac rew_hyps  :=
       match goal with
         | [H:_ |- _ ] => simpl in H; repeat rewrite H; unfold andB; repeat redg; clear H
       end. *)
       Ltac ufcma_pi1  x :=
          match goal with
            |[|- context[(ver (pk ?n) (pi1 (pi2 (pi1 x))) ?Y)] ] => pose proof( UFCMA n (pi1 (pi2 (pi1 x))) Y); rew_hyps; try split; try reflexivity
          end.
             Ltac ufcma_pi2 x:=
               match goal with
                 |[|- context[(ver (pk ?n1) (pi1 (pi2 (pi2 x))) ?Y)] ] => pose proof( UFCMA n1 (pi1 (pi2 (pi2 x))) Y); rew_hyps; try split; try reflexivity
               end.
(** andB elimination *)

Axiom andB_elm': forall (b1 b2: Bool) (x y : message), (ifm b1& b2 x y) #  (ifm b1 (ifm b2 x y ) y).

Ltac aply_andB_elm :=
match goal with
|[|- context[ifm (ifb ?B1 ?B2 FAlse) ?T1 ?T2 ] ] => rewrite andB_elm' with (b1:= B1) (b2:= B2) (x:= T1) (y:= T2)
end.
Ltac ufcma_pi1'  x :=
          repeat match goal with
            |[|- context[(ver (pk ?n') (pi1 (pi2 (pi1 x))) ?Y)] ] => rewrite UFCMA with (n:= n') (t:= (pi1 (pi2 (pi1 x)))) (u:= Y)   ;  simpl ; repeat (try rewrite IFSAME_B; try rewrite IFFALSE_B; try rewrite IFFALSE_M); try split; try reflexivity
          end.

      Ltac ufcma_pi2' x:=
              repeat match goal with
                       |[|- context[(ver (pk ?n1) (pi1 (pi2 (pi2 x))) ?Y)] ] => rewrite UFCMA with (n:=n1) (t:= (pi1 (pi2 (pi2 x)))) (u:= Y)  ; simpl ; repeat (try rewrite IFSAME_B; try rewrite IFFALSE_B; try rewrite IFFALSE_M); try split; try reflexivity
                     end.                                                                                Ltac unforge' x1 n1 n2:=
                         ufcma_pi1' (x1 n1 n2); ufcma_pi2' (x1 n1 n2);   ufcma_pi1' (x1 n2 n1);   ufcma_pi2' (x1 n2 n1).

Ltac aply_andB_elm' B2 :=
match goal with
|[|- context[ifm (ifb ?B1 B2 FAlse) ?T1 ?T2 ] ] => rewrite andB_elm' with (b1:= B1) (b2:= B2) (x:= T1) (y:= T2)
end.
 Ltac aply_bver' :=
  match goal with
    |[|- context[bver (pk ?N) ?T  (unblind ?T (pk ?N) ?T' ?U) ] ] => rewrite SHU_UFCMA with (n:= N) (t:=T) (t':= T') (u:= U)
  end.
 Ltac btrm n x1 b1 x2 b2  H :=
  funapptrmhyp (bol (ifb (eqm (pi1 (pi2 x1)) b1)
            (ver (pk n) b1 (pi2 (pi2 x1))) FAlse)) (bol (ifb (eqm (pi1 (pi2 x2)) b2) (ver (pk n) b2 (pi2 (pi2 x2))) FAlse)) H.
(** replace bacc with bver *)

Ltac rew_mupbver  :=
  match goal with
    | [|- context[ (ifm (bacc (pk 3) ?M _ ?T) ?T1 ?T2) ] ] => rewrite mupbver with (n := 3) (m:= M)  (t1:= T1) (t2:= T2)
  end.
 Ltac aply_bver :=
  match goal with
    |[|- context[bver (pk ?N) ?T  (unblind ?T (pk ?N) ?T' ?U) ] ] => pose proof (SHU_UFCMA nonce T T' U)
  end.

(** replacing the random commit keys with fresh values *)

Definition droplast {n} (l: mylist n): mylist (pred n) :=  (reverse (dropone (reverse l))).
Axiom restr_droplast : forall {n} (l1 l2:mylist n), (l1 ~ l2) -> (droplast l1) ~ (droplast l2).
Ltac droplast_in H:= apply restr_droplast in H; unfold droplast in H; simpl in H.
Ltac fresh_n n3 n4 H := apply FRESHIND_rs with (n1:= n3) (n2:= n4) in H; try split; try reflexivity.
Ltac app_rn n3 n4 H :=
funapptrmhyp (msg (r n3)) (msg (r n4)) H;  try reflexivity.
Ltac fresh_rn n1 n2 H := fresh_n n1 n2 H; try split; try reflexivity; app_rn n1 n2 H; try split; try reflexivity.

      (*                  funapptrmhyp (msg (r n3)) (msg (r n4)) H;  repeat try split;    try reflexivity.
*)

  Ltac fresh_assert name  :=
  match goal with
    | [H: (?X ~ ?Y) |- _ ] =>  assert(([msg (vt 0); msg (vt 1)] ++ Y) ~ ([msg (vt 0); msg (vt 1)] ++ Y)) as name ;try reflexivity; do 4 (droplast_in name)
  end.

  Ltac appcommit v  n1 n2  H:=
    funapptrmhyp (msg (b v n1)) (msg (b v n2)) H; try reflexivity.

  Ltac appblind v  n1 n2  r  H:=
    funapptrmhyp (msg (e (b v n1) r)) (msg (e (b v n2) r )) H; try reflexivity.

   Ltac freshind n1 n2 H:= fresh_rn n1 n2 H; fresh_rn (S n1) (S n1) H; try split; try reflexivity.

  Ltac assertg fr1 fr2 t :=
    match goal with
      | [H : (?X1 ~ ?X2) |- _ ] => match H with
                                     |fr1 =>  match goal with
                                                | [H1: (?X3 ~ ?X4) |- _ ] => match H1 with
                                                                               | fr2 => assert( X1 ~ X3) as t ;simpl
                                                                             end
                                              end
                                   end

    end.
  Ltac aplytrans H1 :=
    match goal with
      | [H: (?X1~ ?X2) |- _ ] => match H with
                              | H1 => apply EQI_trans with (ml2:= X2); try assumption; symmetry; assumption
                            end
    end.

  Ltac freshns1 v1 v2  n1 n2 n3 n4 H :=
    fresh_assert H; freshind n1 n2 H; freshind n3 n4 H; appcommit v1 n3 n4 H; appcommit v2 n1 n2 H; appblind v2 n1 n2 (S n3) H; appblind v1 n3 n4 (S n1) H;  do 6 (dropone_in H); do 5  (restrproj_in 11 H).

  Ltac freshns2 v1 v2 n1 n2 n3 n4 H :=
    fresh_assert H; freshind n1 n2 H; freshind n3 n4 H; appcommit v1 n1 n2 H; appcommit v2 n3 n4 H; appblind v2 n3 n4 (S n3) H; appblind v1 n1 n2 (S n1) H;  do 6 (dropone_in H); do 4  (restrproj_in 11 H).
   Ltac freshns v1 v2 n1 n2 n3 n4 H1 H2 :=  freshns1 v1 v2 n1 n2 n3 n4 H1; freshns2 v1 v2 n1 n4 n3 n2 H2 .

   Ltac asert_aplytrans H1 H2 t := assertg  H1 H2 t ; try aplytrans H1; try assumption; symmetry in t.
    (** tactics to replace fresh names in commitments *)

   (** (b v2 n1) -> (b v2 n3),  (b v1 n3) -> (b v1 n1) *)
Ltac rep_commits  v1 v2 n1 n2 n3 n4 H1 H2 H3 H H0 :=  freshns v1 v2 n1 n2 n3 n4 H1 H2; (restrproj_in 11 H) ;
   asert_aplytrans H1 H2 H3 ;
   asert_aplytrans H H3 H0; symmetry in H0;
   clear -H0.
(** building the term when verification successful *)

 Ltac ver_suc n x1 e1 x2 e2 H:=
  funapptrmhyp (bol (eqm (pi1 (pi2 x1)) e1)) (bol (eqm (pi1 (pi2 x2)) e2)) H;
  funapptrmhyp (bol  (ver (pk n) e1 (pi2 (pi2 x1))))  (bol (ver (pk n) e2 (pi2 (pi2 x2)))) H;
  funapptrmhyp (bol (eqm (pi1 (pi2 x1)) e1) & (ver (pk n) e1 (pi2 (pi2 x1))))  (bol (eqm (pi1 (pi2 x2)) e2) & (ver (pk n) e2 (pi2 (pi2 x2)))) H.
Ltac ver_suc1 n x1 e1 x2 e2 H:=
  funapptrmhyp (bol (eqm (pi1 (pi2 x1)) e1)) (bol (eqm (pi1 (pi2 x2)) e2)) H;
  funapptrmhyp (bol  (ver (pk n) e1 (pi2 (pi2 x1))))  (bol (ver (pk n) e2 (pi2 (pi2 x2)))) H.
 (** apply unforgeability *)

Ltac unforge x1 n1 n2:=
  ufcma_pi1 (x1 n1 n2); ufcma_pi2 (x1 n1 n2);   ufcma_pi1 (x1 n2 n1);   ufcma_pi2 (x1 n2 n1).

Axiom EQL_eqm : forall u u', (EQL u u') ##  (eqm (L u) (L u')).
Check L.
 (** lengths of the encryptions are equal *)
Axiom len_nonce: forall n n', (L n) # (L n').

Axiom len_f1 : forall t t' f, (L t) # (L t') -> (L (f t)) # (L (f t')).
Axiom len_f2 : forall t1 t2 t1' t2' f, (L t1) # (L t1') -> (L t2) # (L t2')  -> (L (f t1 t2)) # (L (f t1' t2')).
Axiom len_f3 : forall t1 t2 t3  t1' t2' t3' f, (L t1) # (L t1') -> (L t2) # (L t2') -> (L t3) # (L t3') -> (L (f t1 t2 t3)) # (L (f t1' t2' t3')).
Axiom len_f4 : forall t1 t2 t3 t4 t1' t2' t3' t4' f, (L t1) # (L t1') -> (L t2) # (L t2') -> (L t3) # (L t3') -> (L t4) # (L t4') -> (L (f t1 t2 t3 t4)) # (L (f t1' t2' t3' t4')).

Axiom ENCCPA': forall (u u' u'': message) (n n1 n2 n3 :nat) {m} (l:mylist m),  (eqm (L u) (L u')) ## TRue ->   (leb (length (distmvars l)) 1) = true -> (clos_listm [u; u'; u''] = true) -> ((Fresh [n2] l) = true) -> ((Fresh [n3] l) = true) -> ((checkmtmylis (sk n1) l) = false)  -> (l++ [msg (enc u (pk n1) (rr (nonce n2)))]) ~ (l++ [msg (enc u' (pk n1) (rr (nonce n3)))]).
(** include cor_ex7_2.v *)
Axiom EQmsg': forall(x y: message),   x # y <->   (eqm x y) ## (TRue) .
  Ltac bterm v1 v2 ck H :=
  funapptrmhyp (msg (e (b v1 ck) (S ck))) (msg (e (b v2 ck) (S ck))) H.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Import Category.Instance.Sets.

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

Program Definition Part : Category := {|
obj := Sets;
hom := fun x y =>
@SetoidMorphism x (is_setoid x) (option y) (@option_setoid _ (is_setoid y));
homset := fun x y =>
@SetoidMorphism_Setoid x {| is_setoid := @option_setoid _ (is_setoid y) |}
|}.
Next Obligation.
construct.
- exact (Some X).
- proper.
Defined.
Next Obligation.
construct.
- destruct (g X) as [b|].
exact (f b).
exact None.
- proper.
destruct f, g; simpl.
spose (proper_morphism0 _ _ X) as X1.
destruct (morphism0 x0); auto;
destruct (morphism0 y0); auto.
spose (proper_morphism _ _ X1) as X2.
destruct (morphism c); auto;
destruct (morphism c0); auto.
contradiction.
contradiction.
Defined.
Next Obligation.
proper.
specialize (X0 x2).
destruct (x1 x2); auto.
- specialize (X c).
destruct (x0 c); auto;
destruct (y1 x2); auto;
destruct y0; simpl in *;
spose (proper_morphism _ _ X0) as X1.
destruct (morphism c); auto;
destruct (morphism c1); try tauto.
now transitivity c2.
destruct (morphism c); auto;
destruct (morphism c0); tauto.
- destruct (y1 x2); auto.
contradiction.
Qed.
Next Obligation.
intros.
destruct (f x0); auto.
reflexivity.
Qed.
Next Obligation.
intros.
destruct (f x0); auto.
reflexivity.
Qed.
Next Obligation.
intros.
destruct (h x0); auto.
destruct (g c); auto.
destruct (f c0); auto.
reflexivity.
Qed.
Next Obligation.
intros.
destruct (h x0); auto.
destruct (g c); auto.
destruct (f c0); auto.
reflexivity.
Qed.

Require Import Category.Structure.Cartesian.

Arguments option_setoid A {_}.
Arguments sum_setoid A B {_ _}.

Program Instance Part_Cartesian : @Cartesian Part := {
product_obj := fun x y =>
{| carrier := sum (carrier x) (sum (carrier y) (carrier x * carrier y)) |}
}.
Next Obligation.
destruct x, y.
proper.
Defined.
Next Obligation.
construct.
- destruct (f H) as [b|].
destruct (g H) as [c|].
exact (Some (Datatypes.inr (Datatypes.inr (b, c)))).
exact (Some (Datatypes.inl b)).
destruct (g H) as [c|].
exact (Some (Datatypes.inr (Datatypes.inl c))).
exact None.
- proper.
destruct f, g; simpl in *.
spose (proper_morphism _ _ X) as X1.
destruct (morphism x0);
destruct (morphism y0); try tauto;
spose (proper_morphism0 _ _ X) as X2;
destruct (morphism0 x0);
destruct (morphism0 y0); try tauto.
Defined.
Next Obligation.
unfold Part_Cartesian_obligation_1.
construct.
- destruct H.
exact (Some c).
destruct s.
exact None.
destruct p.
exact (Some c).
- proper.
destruct x0, y0; try tauto.
destruct s, s0; try tauto.
destruct p, p0, X; auto.
Defined.
Next Obligation.
unfold Part_Cartesian_obligation_1.
construct.
- destruct H.
exact None.
destruct s.
exact (Some c).
destruct p.
exact (Some c0).
- proper.
destruct x0, y0; try tauto.
destruct s, s0; try tauto.
destruct p, p0, X; auto.
Defined.
Next Obligation.
proper.
specialize (X x2).
specialize (X0 x2).
destruct (x0 x2), (x1 x2), (y0 x2), (y1 x2); auto.
Qed.
Next Obligation.
split; intros.
- split; intros.
+ specialize (X x0).
destruct (h x0), (f x0), (g x0); try tauto;
destruct s; try tauto;
destruct s; try tauto.
destruct p, X; auto.
+ specialize (X x0).
destruct (h x0), (f x0), (g x0); try tauto;
destruct s; try tauto;
destruct s; try tauto.
destruct p, X; auto.
- destruct X.
specialize (y0 x0).
specialize (y1 x0).
destruct (h x0), (f x0), (g x0); try tauto;
destruct s; try tauto;
destruct s; try tauto;
destruct p; simpl in *; auto.
Qed.

Require Import Category.Instance.Sets.

Definition to {a b c} :
(a + (b + (a * b)) -> option c) -> (a -> option (b -> option c)) :=
fun f a => Some (fun b => f (inr (inr (a, b)))).

Definition from {a b c} :
(a -> option (b -> option c)) -> (a + (b + (a * b)) -> option c) :=
fun f x =>
match x with
| inl _            => None
| inr (inl _)      => None
| inr (inr (a, b)) =>
match f a with
| None => None
| Some k => k b
end
end.

Lemma to_from {a b c} :
to \o from = @Datatypes.id (a -> option (b -> option c)).
Proof. hammer_hook "Part" "Part.to_from".
extensionality f.
simpl.
extensionality x.
unfold to, from.
destruct (f x).
f_equal.

Abort.

Lemma to_from_impossible {a b c} :
to \o from = @Datatypes.id (a -> option (b -> option c))
-> inhabited a -> False.
Proof. hammer_hook "Part" "Part.to_from_impossible".
intros.
pose proof (equal_f H).
pose proof (equal_f (H1 (fun _ => None))).
simpl in H2.
destruct H0.
specialize (H2 X).
unfold to, from in H2.
discriminate.
Qed.

Lemma from_to {a b c} :
from \o to = @Datatypes.id (a + (b + (a * b)) -> option c).
Proof. hammer_hook "Part" "Part.from_to".
extensionality f.
simpl.
extensionality x.
unfold to, from.
destruct x; simpl.

admit.
destruct s; simpl.
admit.
destruct p; auto.
Abort.

Lemma from_to_impossible {a b c} :
from \o to = @Datatypes.id (a + (b + (a * b)) -> option c)
-> inhabited a ∨ inhabited b -> inhabited c -> False.
Proof. hammer_hook "Part" "Part.from_to_impossible".
intros.
pose proof (equal_f H).
destruct H1.
pose proof (equal_f (H2 (fun _ => Some X))).
simpl in H1.
unfold to, from in H1.
destruct H0, i.
specialize (H1 (inl X0)).
discriminate.
specialize (H1 (inr (inl X0))).
discriminate.
Qed.


(** * Heap Lookup *)

Require Import TM.Code.ProgrammingTools.
Require Import TM.LM.Semantics TM.LM.Alphabets.
Require Import TM.Code.ListTM TM.Code.CasePair TM.Code.CaseSum TM.Code.CaseNat.

Local Arguments plus : simpl never.
Local Arguments mult : simpl never.

Section Lookup.

  (** There is no need to save [n]. [H] must be saved. We use the [Nth'] machine, because we don't want to introduce an additional [sigOption sigHEnt] to the alphabet. [Nth'] also doesn't save [a] (which is the parameter of [Nth'] here, not [n]). [Lookup] will overwrite and reset the variables [a] and [n], but save [H] (which is saved by [Nth']). *)

(** We could define [Lookup] over the alphabet [sigHeap], however, in the step machine, we want to read [a] and [n] from a different closure alphabet (sigList sigHClos). [a] is read from an address of a closure and [n] from a variable of this closure, and the output closure will also be copied to this alphabet. *)

  Variable sigLookup : finType.

  Variable retr_clos_lookup : Retract sigHClos sigLookup.
  Variable retr_heap_lookup : Retract sigHeap sigLookup.

  (**
There are (more than) three possible ways how to encode [nat] on the [Heap] alphabet [sigLookup]:

- 1: as a heap address of a closure on the stack alphabet
- 2: as a variable of a command inside a closure of the closure input alphabet
- 3: as a "next" address of an heap entry

[a] is stored in the second way and [n] in the third way.
*)

  (** No 1 *)
  Definition retr_nat_clos_ad : Retract sigNat sigHClos :=
    Retract_sigPair_X _ _.
  Definition retr_nat_lookup_clos_ad : Retract sigNat sigLookup :=
    ComposeRetract retr_clos_lookup retr_nat_clos_ad.

  (** No 2 *)
  Definition retr_nat_clos_var : Retract sigNat sigHClos :=
    Retract_sigPair_Y _ _.
  Definition retr_nat_lookup_clos_var : Retract sigNat sigLookup :=
    ComposeRetract retr_clos_lookup retr_nat_clos_var.

  (** No 3 *)
  Definition retr_nat_heap_entry : Retract sigNat sigHeap :=
    Retract_sigList_X (Retract_sigOption_X (Retract_sigPair_Y _ (Retract_id _))).
  Local Definition retr_nat_lookup_entry : Retract sigNat sigLookup :=
    ComposeRetract retr_heap_lookup retr_nat_heap_entry.

  (** Encoding of a closure on the heap alphabet *)
  Definition retr_clos_heap : Retract sigHClos sigHeap := _.
  Definition retr_clos_lookup_heap : Retract sigHClos sigLookup := ComposeRetract retr_heap_lookup retr_clos_heap.

  Definition retr_hent_heap : Retract sigHEntr sigHeap := _.
  Local Definition retr_hent_lookup : Retract sigHEntr sigLookup := ComposeRetract retr_heap_lookup retr_hent_heap.

  Definition retr_hent'_heap : Retract sigHEntr' sigHeap := _.
  Local Definition retr_hent'_lookup : Retract sigHEntr' sigLookup := ComposeRetract retr_heap_lookup retr_hent'_heap.

  (*
  Tapes:
  t0: H
  t1: a
  t2: n
  t3: out
  t4: internal tape
  *)

  Definition Lookup_Step : pTM sigLookup^+ (option bool) 5 :=
    If (Nth' retr_heap_lookup retr_nat_lookup_clos_ad @ [|Fin0; Fin1; Fin4; Fin3|])
       (If (CaseOption sigHEntr'_fin ⇑ retr_hent_lookup @ [|Fin4|])
           (CasePair sigHClos_fin sigHAdd_fin ⇑ retr_hent'_lookup @ [|Fin4; Fin3|];;
            If (CaseNat ⇑ retr_nat_lookup_clos_var @ [|Fin2|])
               (Return (CopyValue _ @ [|Fin4; Fin1|];; (* n = S n' *)
                        Translate retr_nat_lookup_entry retr_nat_lookup_clos_ad @ [|Fin1|];;
                        Reset _ @ [|Fin4|];;
                        Reset _ @ [|Fin3 |])
                       None) (* continue *)
               (Return (Reset _ @ [|Fin4|];; (* n = 0 *)
                        Reset _ @ [|Fin2|];;
                        Translate retr_clos_lookup_heap retr_clos_lookup @ [|Fin3|])
                       (Some true))) (* return true *)
           (Return Nop (Some false))) (* return false *)
       (Return Nop (Some false)) (* return false *)
  .

  Definition Lookup_Step_Rel : pRel sigLookup^+ (option bool) 5 :=
    fun tin '(yout, tout) =>
      forall (H: Heap) (a n: nat),
        tin[@Fin0] ≃ H ->
        tin[@Fin1] ≃(Encode_map Encode_nat retr_nat_lookup_clos_ad ) a ->
        tin[@Fin2] ≃(Encode_map Encode_nat retr_nat_lookup_clos_var) n ->
        isRight tin[@Fin3] -> isRight tin[@Fin4] ->
        match yout, n with
        | Some true, O => (* return true *)
          exists g b,
          nth_error H a = Some (Some (g, b)) /\
          tout[@Fin0] ≃ H /\
          isRight tout[@Fin1] /\
          isRight tout[@Fin2] /\
          tout[@Fin3] ≃(Encode_map Encode_HClos retr_clos_lookup) g /\
          isRight tout[@Fin4]
        | None, S n' => (* continue *)
          exists g b,
          nth_error H a = Some (Some (g, b)) /\
          tout[@Fin0] ≃ H /\
          tout[@Fin1] ≃(Encode_map Encode_nat retr_nat_lookup_clos_ad ) b /\
          tout[@Fin2] ≃(Encode_map Encode_nat retr_nat_lookup_clos_var) n' /\
          isRight tout[@Fin3] /\
          isRight tout[@Fin4]
        | Some false, _ =>
          lookup H a n = None (* Tapes are not specified *)
        | _, _ => False (* Unreachable *)
        end.

  Lemma Lookup_Step_Realise : Lookup_Step ⊨ Lookup_Step_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Lookup_Step. TM_Correct.
      - apply Nth'_Realise.
      - apply CopyValue_Realise with (cX := Encode_map Encode_nat retr_nat_lookup_entry).
      - apply Translate_Realise with (X := nat).
      - apply Reset_Realise with (cX := Encode_map Encode_nat retr_nat_lookup_entry).
      - apply Reset_Realise with (cX := Encode_map Encode_HClos retr_clos_lookup_heap).
      - apply Reset_Realise with (cX := Encode_map Encode_nat retr_nat_lookup_entry).
      - apply Reset_Realise with (cX := Encode_map Encode_nat retr_nat_lookup_clos_var).
      - apply Translate_Realise with (X := HClos).
    }
    {
      intros tin (yout, tout) H. cbn. intros heap a n HEncHeap HEncA HEncN HRight3 HRight4.
      destruct H; TMSimp.
      { (* Then of [Nth'], i.e. nth_error H a = Some e *) rename H into HNth, H0 into HCaseOption.
        modpon HNth. destruct HNth as (e&HNth); modpon HNth.
        destruct HCaseOption; TMSimp.
        { (* Then of [CaseOption], i.e. e = Some e', where e' = (g, b) *) rename H into HCaseOption, H0 into HCasePair, H1 into HCaseNat.
          modpon HCaseOption. destruct e as [ e' | ]; auto; simpl_surject.
          modpon HCasePair.
          destruct HCaseNat; TMSimp.
          { (* Then of [CaseNat], i.e. n = S n' *)
            rename H into HCaseNat, H0 into HCopy, H1 into HTranslate, H2 into HReset, H3 into HReset'.
            modpon HCaseNat. destruct n as [ | n']; auto; simpl_surject.
            modpon HCopy.
            modpon HTranslate.
            modpon HReset.
            modpon HReset'.
            eauto 9.
          }
          { (* Else of [CaseNat], i.e. n = 0 *)
            rename H into HCaseNat, H0 into HReset, H1 into HReset', H2 into HTranslate.
            modpon HCaseNat. destruct n as [ | n']; auto; simpl_surject.
            modpon HReset.
            modpon HReset'.
            modpon HTranslate.
            eauto 8.
          }
        }
        { (* Else of [CaseOption], i.e. e = None *) rename H into HCaseOption.
          modpon HCaseOption. destruct e; auto; simpl_surject. rewrite lookup_eq, HNth. auto.
        }
      }
      { (* Else of [Nth'], i.e. nth_error H a = None *) rename H into HNth.
        modpon HNth. rewrite lookup_eq, HNth. auto.
      }
    }
  Qed.

  Local Definition Lookup_Step_steps_CaseNat (n: nat) (e': HClos * HAdd) :=
    let (g,b) := (fst e', snd e') in
    match n with
    | S _ => 1 + CopyValue_steps _ b + 1 + Translate_steps _ b + 1 + Reset_steps _ b + Reset_steps _ g
    | O => 1 + Reset_steps _ b + 1 + Reset_steps _ 0 + Translate_steps _ g
    end.

  Local Definition Lookup_Step_steps_CaseOption (n:nat) (e: HEntr) :=
    match e with
    | Some ((g, b) as e') => 1 + CasePair_steps _ g + 1 + CaseNat_steps + Lookup_Step_steps_CaseNat n e'
    | None => 0
    end.

  Local Definition Lookup_Step_steps_Nth' H a n :=
    match nth_error H a with
    | Some e => 1 + CaseOption_steps + Lookup_Step_steps_CaseOption n e
    | None => 0
    end.

  Definition Lookup_Step_steps (H: Heap) (a: HAdd) (n: nat) :=
    1 + Nth'_steps _ H a + Lookup_Step_steps_Nth' H a n.

  Definition Lookup_Step_T : tRel sigLookup^+ 5 :=
    fun tin k =>
      exists (H: Heap) (a n: nat),
        tin[@Fin0] ≃ H /\
        tin[@Fin1] ≃(Encode_map Encode_nat retr_nat_lookup_clos_ad ) a /\
        tin[@Fin2] ≃(Encode_map Encode_nat retr_nat_lookup_clos_var) n /\
        isRight tin[@Fin3] /\ isRight tin[@Fin4] /\
        Lookup_Step_steps H a n <= k.

  Lemma Lookup_Step_Terminates : projT1 Lookup_Step ↓ Lookup_Step_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Lookup_Step. TM_Correct.
      - apply Nth'_Realise.
      - apply Nth'_Terminates.
      - apply CopyValue_Realise with (cX := Encode_map Encode_nat retr_nat_lookup_entry).
      - apply CopyValue_Terminates with (cX := Encode_map Encode_nat retr_nat_lookup_entry).
      - apply Translate_Realise with (X := nat).
      - apply Translate_Terminates with (X := nat).
      - apply Reset_Realise with (cX := Encode_map Encode_nat retr_nat_lookup_entry).
      - apply Reset_Terminates with (cX := Encode_map Encode_nat retr_nat_lookup_entry).
      - apply Reset_Terminates with (cX := Encode_map Encode_HClos retr_clos_lookup_heap).
      - apply Reset_Realise with (cX := Encode_map Encode_nat retr_nat_lookup_entry).
      - apply Reset_Terminates with (cX := Encode_map Encode_nat retr_nat_lookup_entry).
      - apply Reset_Realise with (cX := Encode_map Encode_nat retr_nat_lookup_clos_var).
      - apply Reset_Terminates with (cX := Encode_map Encode_nat retr_nat_lookup_clos_var).
      - apply Translate_Terminates with (X := HClos).
    }
    {
      intros tin k. cbn. intros (H&a&n&HEncH&HEncA&HEncN&HRight3&HRight4&Hk). unfold Lookup_Step_steps in Hk.
      exists (Nth'_steps _ H a), (Lookup_Step_steps_Nth' H a n).
      repeat split; try omega.
      { hnf; cbn; eauto 7. }
      unfold Lookup_Step_steps_Nth' in *.
      intros tmid b (HNth&HNthInj); TMSimp. modpon HNth. destruct b; modpon HNth.
      { (* nth_error H a = Some e *) destruct HNth as (e&HNth); modpon HNth. rewrite HNth in *.
        exists (CaseOption_steps), (Lookup_Step_steps_CaseOption n e).
        repeat split; try omega. unfold Lookup_Step_steps_CaseOption in *.
        intros tmid0 b (HCaseOption&HCaseOptionInj); TMSimp. modpon HCaseOption. destruct b; auto.
        { (* e = Some e', where e' = (g,b) *) destruct e as [ e' | ]; auto; simpl_surject.
          destruct e' as [g b] eqn:Ee'.
          exists (CasePair_steps _ g), (1 + CaseNat_steps + Lookup_Step_steps_CaseNat n e'); subst.
          repeat split; try omega. 2: now rewrite !Nat.add_assoc.
          { hnf; cbn. exists (g,b). repeat split; simpl_surject; eauto. contains_ext. }
          intros tmid1 () (HCasePair&HCasePairInj). specialize (HCasePair (g,b)); modpon HCasePair.
          exists (CaseNat_steps), (Lookup_Step_steps_CaseNat n (g,b)).
          repeat split; try omega.
          intros tmid2 bif (HCaseNat&HCaseNatInj); TMSimp. modpon HCaseNat. destruct bif, n as [ | n']; auto; simpl_surject.
          { (* n = S n' *)
            exists (CopyValue_steps _ b), (1 + Translate_steps _ b + 1 + Reset_steps _ b + Reset_steps _ g).
            repeat split; try omega. 2: now rewrite !Nat.add_assoc.
            { eexists; repeat split; eauto. contains_ext. now setoid_rewrite CopyValue_steps_comp. }
            intros tmid3 () (HCopyValue&HCopyValueInj); TMSimp. modpon HCopyValue.
            exists (Translate_steps _ b), (1 + Reset_steps _ b + Reset_steps _ g).
            repeat split; try omega. 2: now rewrite !Nat.add_assoc.
            { hnf; cbn. eauto. }
            intros tmid4 () (HTranslate&HTranslateInj); TMSimp. modpon HTranslate.
            exists (Reset_steps _ b), (Reset_steps _ g).
            repeat split; try omega. 2: reflexivity.
            { hnf; cbn. eexists; repeat split; eauto. now setoid_rewrite Reset_steps_comp. }
            intros tmid5 () (HReset&HResetInj); TMSimp. modpon HReset.
            { hnf; cbn. eexists; repeat split; eauto. contains_ext. now setoid_rewrite Reset_steps_comp. }
          }
          { (* n = 0 *)
            exists (Reset_steps _ b), (1 + Reset_steps _ 0 + Translate_steps _ g).
            repeat split; try omega. 2: now rewrite !Nat.add_assoc.
            { eexists; split; eauto. contains_ext. now setoid_rewrite Reset_steps_comp. }
            intros tmid3 () (HReset&HResetInj); TMSimp. modpon HReset.
            exists (Reset_steps _ 0), (Translate_steps _ g).
            repeat split; try omega. 2: reflexivity.
            { eexists; split; eauto. }
            intros tmid4 () (HReset'&HResetInj'); TMSimp. modpon HReset'.
            { hnf; cbn. eexists; split; eauto. contains_ext. }
          }
        }
        { (* e = None *) destruct e; auto. }
      }
      { (* nth_error H a = None *) now rewrite HNth. }
    }
  Qed.

  Definition Lookup := While Lookup_Step.

  Definition Lookup_Rel : pRel sigLookup^+ bool 5 :=
    fun tin '(yout, tout) =>
      forall (H: Heap) (a n: nat),
        tin[@Fin0] ≃ H ->
        tin[@Fin1] ≃(Encode_map Encode_nat retr_nat_lookup_clos_ad) a ->
        tin[@Fin2] ≃(Encode_map Encode_nat retr_nat_lookup_clos_var) n ->
        isRight tin[@Fin3] -> isRight tin[@Fin4] ->
        match yout with
        | true =>
          exists g,
          lookup H a n = Some g /\
          tout[@Fin0] ≃ H /\ (* [H] is saved *)
          isRight tout[@Fin1] /\ (* [a] is discarded *)
          isRight tout[@Fin2] /\ (* [n] is discarded *)
          tout[@Fin3] ≃(Encode_map Encode_HClos retr_clos_lookup) g /\ (* result *)
          isRight tout[@Fin4] (* internal tape *)
        | false =>
          lookup H a n = None (* Tapes are not specified *)
        end.

  Lemma Lookup_Realise : Lookup ⊨ Lookup_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Lookup. TM_Correct.
      - apply Lookup_Step_Realise.
    }
    {
      apply WhileInduction; intros; intros heap a n HEncHeap HEncA HEncN HRight3 HRight4; cbn in *.
      - modpon HLastStep. destruct yout, n as [ | n']; auto.
        destruct HLastStep as (g&b&HLastStep); modpon HLastStep.
        eexists. rewrite lookup_eq, HLastStep. eauto 10.
      - modpon HStar. destruct n as [ | n']; auto.
        destruct HStar as (g&b&HStar); modpon HStar.
        modpon HLastStep. destruct yout.
        + destruct HLastStep as (g'&HLastStep); modpon HLastStep.
          eexists. rewrite lookup_eq, HStar. eauto 10.
        + modpon HLastStep. cbn. rewrite HStar. repeat split; auto.
    }
  Qed.

  Fixpoint Lookup_steps (H : Heap) (a : HAdd) (n : nat) : nat :=
    match nth_error H a with
    | Some (Some (g, b)) =>
      match n with
      | 0 => Lookup_Step_steps H a n
      | S n' => 1 + Lookup_Step_steps H a n + Lookup_steps H b n'
      end
    | _ => Lookup_Step_steps H a n
    end.

  Definition Lookup_T : tRel sigLookup^+ 5 :=
    fun tin k =>
      exists (H: Heap) (a n: nat),
        tin[@Fin0] ≃ H /\
        tin[@Fin1] ≃(Encode_map Encode_nat retr_nat_lookup_clos_ad) a /\
        tin[@Fin2] ≃(Encode_map Encode_nat retr_nat_lookup_clos_var) n /\
        isRight tin[@Fin3] /\ isRight tin[@Fin4] /\
        Lookup_steps H a n <= k.

  Lemma Lookup_Terminates : projT1 Lookup ↓ Lookup_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Lookup. TM_Correct.
      - apply Lookup_Step_Realise.
      - apply Lookup_Step_Terminates. }
    {
      apply WhileCoInduction. intros tin k (Heap&a&n&HEncHeap&HEncA&HEncN&HRight3&HRight4&Hk).
      exists (Lookup_Step_steps Heap a n). split.
      - hnf. do 3 eexists; repeat split; eauto.
      - intros ymid tmid HStep. cbn in *. modpon HStep. destruct ymid as [ [ | ] | ], n as [ | n']; cbn in *; auto.
        + destruct HStep as (g&b&HStep); modpon HStep. rewrite HStep in Hk. auto.
        + destruct (nth_error Heap a) as [ [ (g&b) | ] | ] eqn:E; auto.
        + destruct (nth_error Heap a) as [ [ (g&b) | ] | ] eqn:E; auto. omega.
        + destruct HStep as (g&b&HStep); modpon HStep. rewrite HStep in Hk.
          eexists; repeat split; eauto. hnf. do 3 eexists; repeat split; eauto.
    }
  Qed.

End Lookup.


Require Export Iron.Language.SystemF2Cap.Store.Bind.
Require Export Iron.Language.SystemF2Cap.Store.TypeB.

(********************************************************************)
(* Well typed store.
   All bindings are well typed. *)
Definition StoreT' (sec : stenv) (se: stenv) (sp: stprops) (ss: store)
 := Forall2 (TypeB nil nil sec sp) ss se.
Hint Unfold StoreT'.

Definition StoreT  (se  : stenv) (sp : stprops) (ss : store)
 := StoreT' se se sp ss.
Hint Unfold StoreT.

(********************************************************************)
Lemma storeT_mergeB
 :  forall  sec se sp ss p1 p2
 ,  In (SRegion p1) sp
 -> StoreT' sec se sp ss
 -> StoreT' (mergeTE p1 p2 sec) (mergeTE p1 p2 se) sp (mergeBs p1 p2 ss).
Proof.
 intros.
 unfold StoreT' in *.
 induction H0.
 - snorm.
 - simpl. eapply Forall2_cons.
   + rgwrite (nil = mergeTE p1 p2 nil).
     eapply typeB_mergeT. auto. auto.
   + auto.
Qed.

(* Weaken store properties in store typing judgement. *)
Lemma storeT_weak_stprops
 :  forall se sp ss p
 ,  StoreT se sp ss
 -> StoreT se (SRegion p <: sp) ss.
Proof.
 intros.
 unfold StoreT in *.
 eapply Forall2_impl.
 - intros. eapply typeB_stprops_snoc. eauto.
 - auto.
Qed.
Hint Resolve storeT_weak_stprops.

(* All region handles in store bindings are present
   in the store properties. *)
Lemma storeT_handles_in_stprops
 :  forall se sp ss
 ,  StoreT se sp ss
 -> Forall (fun s => forall p
                  ,  regionOfStBind s = p
                  -> In (SRegion p) sp)
           ss.
Proof.
 intros.
 snorm.
 unfold StoreT in *.
 have (exists ix, get ix ss = Some x).
  dest ix.
 have (exists t, TypeB nil nil se sp x t).
  dest t.
 inverts H3.
 - snorm. subst. inverts_kind. auto.
 - snorm. subst. inverts_kind. auto.
Qed.

(* Extended store is well typed under extended store environment *)
Lemma storeT_snoc
 :  forall se sp ss p1 v1 t2
 ,  In (SRegion p1) sp
 -> TypeV  nil nil se sp v1 t2
 -> StoreT                       se  sp                   ss
 -> StoreT (TRef (TRgn p1) t2 <: se) sp (StValue p1 v1 <: ss).
Proof.
 intros.
 set (tRef' := TRef (TRgn p1) t2).

 assert (TypeB nil nil (tRef' <: se) sp (StValue p1 v1) tRef').
 { apply TbValue; auto.
   - apply typev_stenv_snoc.
     subst tRef'.
     assert (ClosedT t2).
      rrwrite (0 = @length ki nil).
      apply (kind_wfT nil sp t2 KData).

      (* NOTE: This one has to be done manually to instantiate existentials *)
      apply (typex_kind_type nil nil se sp (XVal v1) t2 (TBot KEffect)).
       auto. auto. auto.
 }

 assert (Forall2 (TypeB nil nil (tRef' <: se) sp) ss se).
 { lets D: (@Forall2_impl stbind ty)
                (TypeB nil nil se sp)
                (TypeB nil nil (tRef' <: se) sp)
                ss se H1.
   intros.
   apply typeB_stenv_snoc. auto. subst tRef'. eauto.
   auto.
 }

 unfold StoreT.
 auto.
Qed.
Hint Resolve storeT_snoc.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rfn_sel_other_reduce :
  forall T1 x1 L1 Ts1 T', T1 = (t_rfn_sel x1 L1 Ts1 T') ->
                     forall T2, (T2 <> t_top) ->
                           (forall Ts2, T2 <> (t_rfn_top Ts2)) ->
                           (forall x2 L2 Ts2 T'', T2 <> (t_rfn_sel x2 L2 Ts2 T'')) ->
                           (forall x L T, T2 <> (t_sel_low x L T)) ->
                           (forall x L T, T2 <> (t_sel_equ x L T)) ->
                           (forall L2 T2', T2 <> (t_upp L2 T2')) ->
                           (forall L2 T2', T2 <> (t_equ L2 T2')) ->
                           (forall L2 T2', T2 <> (t_low L2 T2')) ->
                           (forall L2 t2 T2', T2 <> (t_nom L2 t2 T2')) ->
                           (T2 <> t_nil) ->
                           (forall T2' Ts2, T2 <> (t_con T2' Ts2)) ->
                           subtype T1 T2 = subtype T' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

  destruct T2; auto.

  contradiction H0; auto.
  contradiction (H3 v l T2); auto.
  contradiction (H4 v l T2); auto.
  contradiction (H2 v l T2_1 T2_2); auto.
  contradiction (H5 l T2); auto.
  contradiction (H7 l T2); auto.
  contradiction (H6 l T2); auto.
  contradiction (H8 l t T2); auto.
  contradiction H9; auto.
  contradiction (H10 T2_1 T2_2); auto.

Qed.


From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.NLSyntax.
From Velus Require Import NLustre.NLOrdered.
From Velus Require Import CoreExpr.CETyping.

From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.

From Coq Require Import Morphisms.

(** * NLustre typing *)

(**

  Typing judgements for NLustre and resulting properties.
  Classify NLustre programs which are statically well-formed.

 *)

Module Type NLTYPING
       (Import Ids   : IDS)
       (Import Op    : OPERATORS)
       (Import CESyn : CESYNTAX      Op)
       (Import Syn   : NLSYNTAX  Ids Op CESyn)
       (Import Ord   : NLORDERED Ids Op CESyn Syn)
       (Import CETyp : CETYPING  Ids Op CESyn).

  Inductive wt_equation (G: global) (vars: list (ident * type)): equation -> Prop :=
  | wt_EqDef: forall x ck e,
      In (x, typeofc e) vars ->
      wt_clock vars ck ->
      wt_cexp vars e ->
      wt_equation G vars (EqDef x ck e)
  | wt_EqApp: forall n xs ck f es,
      find_node f G = Some n ->
      Forall2 (fun x '(_, (t, _)) => In (x, t) vars) xs n.(n_out) ->
      Forall2 (fun e '(_, (t, _)) => typeof e = t) es n.(n_in) ->
      wt_clock vars ck ->
      Forall (wt_exp vars) es ->
      wt_equation G vars (EqApp xs ck f es None)
  | wt_EqReset: forall n xs ck f es y cky,
      find_node f G = Some n ->
      Forall2 (fun x '(_, (t, _)) => In (x, t) vars) xs n.(n_out) ->
      Forall2 (fun e '(_, (t, _)) => typeof e = t) es n.(n_in) ->
      wt_clock vars ck ->
      Forall (wt_exp vars) es ->
      In (y, bool_type) vars ->
      wt_clock vars cky ->
      wt_equation G vars (EqApp xs ck f es (Some (y, cky)))
  | wt_EqFby: forall x ck c0 e,
      In (x, type_const c0) vars ->
      typeof e = type_const c0 ->
      wt_clock vars ck ->
      wt_exp vars e ->
      wt_equation G vars (EqFby x ck c0 e).

  Definition wt_node (G: global) (n: node) : Prop
    := Forall (wt_equation G (idty (n.(n_in) ++ n.(n_vars) ++ n.(n_out))))
              n.(n_eqs).

  Inductive wt_global : global -> Prop :=
  | wtg_nil:
      wt_global []
  | wtg_cons: forall n ns,
      wt_global ns ->
      wt_node ns n ->
      Forall (fun n'=> n.(n_name) <> n'.(n_name))%type ns ->
      wt_global (n::ns).

  Hint Constructors wt_clock wt_exp wt_cexp wt_equation wt_global : nltyping.

  Lemma wt_global_NoDup:
    forall g,
      wt_global g ->
      NoDup (map n_name g).
  Proof.
    induction g; eauto using NoDup.
    intro WTg. simpl. constructor.
    2:apply IHg; now inv WTg.
    intro Hin.
    inversion_clear WTg as [|? ? ? WTn Hn].
    change (Forall (fun n' => (fun i=> a.(n_name) <> i :> ident) n'.(n_name)) g)
      in Hn.
    apply Forall_map in Hn.
    apply Forall_forall with (1:=Hn) in Hin.
    now contradiction Hin.
  Qed.

  Instance wt_equation_Proper:
    Proper (@eq global ==> @Permutation.Permutation (ident * type)
                ==> @eq equation ==> iff)
           wt_equation.
  Proof.
    intros G1 G2 HG env1 env2 Henv eq1 eq2 Heq.
    rewrite Heq, HG.
    split; intro WTeq.
    - inv WTeq; rewrite Henv in *; eauto;
        econstructor; eauto;
          match goal with H:Forall2 _ ?x ?y |- Forall2 _ ?x ?y =>
                          apply Forall2_impl_In with (2:=H) end;
          intros ? (?&(?&?)); rewrite Henv in *; auto.
    - inv WTeq; rewrite <-Henv in *; eauto;
        econstructor; eauto;
          match goal with H:Forall2 _ ?x ?y |- Forall2 _ ?x ?y =>
                          apply Forall2_impl_In with (2:=H) end;
          intros ? (?&(?&?)); rewrite Henv in *; auto.
  Qed.

  Lemma wt_global_Ordered_nodes:
    forall G,
      wt_global G ->
      Ordered_nodes G.
  Proof.
    induction G as [|n G]; intros * WT; auto using Ordered_nodes.
    inv WT.
    constructor; auto.
    intros *  Hni.
    eapply Forall_Exists, Exists_exists in Hni as (eq & Hin & WTeq & Hni); eauto.
    inv Hni; inv WTeq;
      assert (Exists (fun n' => f = n_name n') G) as Hn
        by (apply find_node_Exists, not_None_is_Some; eauto);
      split; auto; intro; subst;
        eapply Forall_Exists, Exists_exists in Hn as (?&?&?&?); eauto;
          contradiction.
  Qed.

End NLTYPING.

Module NLTypingFun
       (Ids   : IDS)
       (Op    : OPERATORS)
       (CESyn : CESYNTAX       Op)
       (Syn   : NLSYNTAX   Ids Op CESyn)
       (Ord   : NLORDERED  Ids Op CESyn Syn)
       (CETyp : CETYPING   Ids Op CESyn)
       <: NLTYPING Ids Op CESyn Syn Ord CETyp.
  Include NLTYPING Ids Op CESyn Syn Ord CETyp.
End NLTypingFun.


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

(**********************************************************************
    Proof of Huffman algorithm: BTree.v

    Definition and some properties of binary trees

    Definitions:
        btree, inb, all_leaves, distinct_leaves, compute_code,
        number_of_nodes

                                    Laurent.Thery@inria.fr (2003)
 **********************************************************************)

From Huffman Require Export Code.
From Huffman Require Export ISort.
Require Export Compare_dec.
From Huffman Require Export Weight.
From Huffman Require Export UniqueKey.
Require Import ArithRing.

Section Tree.
Variable A : Type.
Variable eqA_dec : forall a b : A, {a = b} + {a <> b}.
Variable empty : A.

(* Definition of binary trees *)
Inductive btree : Type :=
  | leaf : A -> btree
  | node : btree -> btree -> btree.

(* Predicate that defines belonging *)
Inductive inb : btree -> btree -> Prop :=
  | inleaf : forall t : btree, inb t t
  | innodeL : forall t t1 t2 : btree, inb t t1 -> inb t (node t1 t2)
  | innodeR : forall t t1 t2 : btree, inb t t2 -> inb t (node t1 t2).
Hint Constructors inb : core.

(* inb is transitive *)
Theorem inb_trans : forall t1 t2 t3, inb t1 t2 -> inb t2 t3 -> inb t1 t3.
Proof using.
intros t1 t2 t3 H H1; generalize t1 H; elim H1; clear H H1 t1 t2 t3; auto.
Qed.

(* A tree has at least one leaf  *)
Theorem inb_ex : forall t : btree, exists x : _, inb (leaf x) t.
Proof using.
intros t; elim t; simpl in |- *; auto.
intros a; exists a; auto.
intros b (a, H) b0 H0; exists a; auto.
Qed.

(* Compute the number of nodes of a tree *)
Fixpoint number_of_nodes (b : btree) : nat :=
  match b with
  | leaf _ => 0
  | node b1 b2 => S (number_of_nodes b1 + number_of_nodes b2)
  end.

(* Belonging gives smaller trees *)
Theorem number_of_nodes_inb_le :
 forall t1 t2, inb t1 t2 -> number_of_nodes t1 <= number_of_nodes t2.
Proof using.
intros t1 t2 H; elim H; clear H t1 t2; simpl in |- *; auto.
intros t t1 t2 H H0; apply le_trans with (1 := H0); auto with arith.
intros t t1 t2 H H0; apply le_trans with (1 := H0); auto with arith.
Qed.

(* Belonging is anisymmetric *)
Theorem inb_antisym : forall t1 t2 : btree, inb t1 t2 -> inb t2 t1 -> t1 = t2.
Proof using.
intros t1 t2 H; elim H; auto.
intros t t0 t3 H0 H1 H2.
absurd (number_of_nodes (node t0 t3) <= number_of_nodes t).
rewrite H1; simpl in |- *; auto with arith.
apply inb_trans with (2 := H2); auto.
apply number_of_nodes_inb_le; auto.
intros t t0 t3 H0 H1 H2.
absurd (number_of_nodes (node t0 t3) <= number_of_nodes t).
rewrite H1; simpl in |- *; auto with arith.
apply inb_trans with (2 := H2); auto.
apply number_of_nodes_inb_le; auto.
Qed.

(* equality on trees is decidable  *)
Definition btree_dec : forall a b : btree, {a = b} + {a <> b}.
intros a; elim a.
intros a1 b; case b.
intros b1; case (eqA_dec a1 b1).
intros e; left; rewrite e; auto.
intros e; right; Contradict e; inversion e; auto.
intros b0 b1; right; red in |- *; intros H; discriminate.
intros b H b0 H0 b1; case b1.
intros a0; right; red in |- *; intros H1; discriminate.
intros b2 b3; case (H b2); intros H1.
case (H0 b3); intros H2.
left; rewrite H1; rewrite H2; auto.
right; rewrite H1; Contradict H2; inversion H2; auto.
right; Contradict H1; inversion H1; auto.
Defined.

(* Belonging is decidable *)
Definition inb_dec : forall a p, {inb a p} + {~ inb a p}.
intros a; elim a; simpl in |- *; auto; clear a.
intros a p; elim p; simpl in |- *; auto; clear p.
intros a1; case (eqA_dec a a1); intros Ha.
left; rewrite Ha; simpl in |- *; auto.
right; red in |- *; Contradict Ha; inversion Ha; auto.
intros b [H| H]; auto.
intros b0 [H1| H1]; auto.
right; red in |- *; intros H2; inversion H2.
case H; auto.
case H1; auto.
intros b H b0 H0 p; elim p; auto.
intros a; right; red in |- *; intros H1; inversion H1.
intros b1 H1 b2 H2.
case H1; intros H3; auto.
case H2; intros H4; auto.
case (btree_dec (node b b0) (node b1 b2)); intros H5.
left; rewrite H5; auto.
right; red in |- *; intros H6; inversion H6; auto.
case H5; rewrite H9; rewrite H10; auto.
Defined.

(* Compute all the leaves of the tree *)
Fixpoint all_leaves (t : btree) : list A :=
  match t with
  | leaf a => a :: nil
  | node t1 t2 => all_leaves t1 ++ all_leaves t2
  end.

(* A leaf is in the list of all leaves *)
Theorem all_leaves_in : forall t a, inb (leaf a) t -> In a (all_leaves t).
Proof using.
intros t; elim t; simpl in |- *; auto.
intros a a0 H; inversion H; auto.
intros b H b0 H0 a H1; apply in_or_app; inversion H1; auto.
Qed.

(* An element of a list of all leaves is a leaf *)
Theorem all_leaves_inb : forall t a, In a (all_leaves t) -> inb (leaf a) t.
Proof using.
intros t; elim t; simpl in |- *; auto.
intros a a0 [H| H]; [ rewrite H | case H ]; auto.
intros b H b0 H0 a H1; case in_app_or with (1 := H1); auto.
Qed.

(* The property for a tree to have distinct leaves  *)
Definition distinct_leaves (t : btree) : Prop :=
  forall t0 t1 t2 : btree,
  inb (node t1 t2) t -> inb t0 t1 -> inb t0 t2 -> False.

(* A leaf tree has distinct leaves  *)
Theorem distinct_leaves_leaf : forall a : A, distinct_leaves (leaf a).
Proof using.
intros a; red in |- *.
intros a0 t1 t2 H; inversion H.
Qed.
Hint Resolve distinct_leaves_leaf : core.

(* An inversion theorem for node *)
Theorem distinct_leaves_l :
 forall t1 t2 : btree, distinct_leaves (node t1 t2) -> distinct_leaves t1.
Proof using.
intros t1 t2 H; red in |- *.
intros a t0 t3 H0 H1 H2.
apply (H a t0 t3); auto.
Qed.

(* An inversion theorem for node *)
Theorem distinct_leaves_r :
 forall t1 t2 : btree, distinct_leaves (node t1 t2) -> distinct_leaves t2.
Proof using.
intros t1 t2 H; red in |- *.
intros a t0 t3 H0 H1 H2.
apply (H a t0 t3); auto.
Qed.

(* If list of all the leaves of the tree is unique then the tree has distinct leaves *)
Theorem all_leaves_unique :
 forall t, ulist (all_leaves t) -> distinct_leaves t.
Proof using.
intros t; elim t; simpl in |- *; auto.
intros b H b0 H0 H1; red in |- *.
intros t0 t1 t2 H2; inversion H2.
intros H4 H7; case (inb_ex t0); intros a HH.
apply ulist_app_inv with (a := a) (1 := H1); auto; apply all_leaves_in;
 apply inb_trans with (1 := HH); auto.
apply H; auto; try apply ulist_app_inv_l with (1 := H1).
apply H0; auto; try apply ulist_app_inv_r with (1 := H1).
Qed.

(* If the tree has distinct leaves then the list of all the leaves of the tree is unique *)
Theorem all_leaves_ulist :
 forall t, distinct_leaves t -> ulist (all_leaves t).
Proof using.
intros t; elim t; simpl in |- *; auto.
intros b H b0 H0 H1; apply ulist_app; auto.
apply H; apply distinct_leaves_l with (1 := H1).
apply H0; apply distinct_leaves_r with (1 := H1).
intros a H2 H3; case (H1 (leaf a) b b0); auto.
apply all_leaves_inb with (1 := H2).
apply all_leaves_inb with (1 := H3).
Qed.

(* Uniqueleaf is decidable *)
Definition distinct_leaves_dec :
  forall a, {distinct_leaves a} + {~ distinct_leaves a}.
intros a; case (ulist_dec A eqA_dec (all_leaves a)); intros H.
left; apply all_leaves_unique; auto.
right; Contradict H; apply all_leaves_ulist; auto.
Defined.

(* Compute the code associated with a binary tree *)
Fixpoint compute_code (a : btree) : list (A * list bool) :=
  match a with
  | leaf b => (b, nil) :: nil
  | node l1 l2 =>
      map
        (fun v : A * list bool =>
         match v with
         | (a1, b1) => (a1, false :: b1)
         end) (compute_code l1) ++
      map
        (fun v : A * list bool =>
         match v with
         | (a1, b1) => (a1, true :: b1)
         end) (compute_code l2)
  end.

(* The computed code is never empty *)
Theorem length_compute_lt_O : forall t, 0 < length (compute_code t).
Proof using.
intros t; elim t; simpl in |- *; auto with arith.
intros b H b0 H0; rewrite length_app.
replace 0 with (0 + 0); auto with arith.
apply plus_lt_compat.
generalize H; elim (compute_code b); simpl in |- *; auto with arith.
generalize H0; elim (compute_code b0); simpl in |- *; auto with arith.
Qed.
Hint Resolve length_compute_lt_O : core.

(* If the computed code has a key it was a leaf of the tree *)
Theorem inCompute_inb :
 forall (t : btree) (a : A) (l : list bool),
 In (a, l) (compute_code t) -> inb (leaf a) t.
Proof using.
intros t; elim t; simpl in |- *; auto.
intros a a0 l [H1| H1]; try (case H1; fail).
injection H1; intros H2 H3; rewrite H3; auto.
intros h H h0 H0 a l H1.
case in_app_or with (1 := H1); auto; intros H2.
case in_map_inv with (1 := H2).
intros (a1, l1) (Ha1, Hl1); auto.
apply innodeL; apply (H a l1).
injection Hl1; intros Hl2 Hl3; rewrite Hl3; auto.
case in_map_inv with (1 := H2).
intros (a1, l1) (Ha1, Hl1); auto.
apply innodeR; apply (H0 a l1).
injection Hl1; intros Hl2 Hl3; rewrite Hl3; auto.
Qed.

(* For every leaf in the tree there is an associated key in the code *)
Theorem inb_compute_ex :
 forall a p, inb (leaf a) p -> exists l : _, In (a, l) (compute_code p).
Proof using.
intros a p; elim p; simpl in |- *; auto.
intros a0 H; inversion H.
exists (nil (A:=bool)); auto.
intros p0 H p1 H0 H1; inversion H1.
case H; auto.
intros x Hx; exists (false :: x).
apply in_or_app; left; auto.
change
  (In ((fun v => match v with
                 | (a1, b1) => (a1, false :: b1)
                 end) (a, x))
     (map (fun v => match v with
                    | (a1, b1) => (a1, false :: b1)
                    end) (compute_code p0))) in |- *;
 apply in_map; auto.
case H0; auto.
intros x Hx; exists (true :: x).
apply in_or_app; right; auto.
change
  (In ((fun v => match v with
                 | (a1, b1) => (a1, true :: b1)
                 end) (a, x))
     (map (fun v => match v with
                    | (a1, b1) => (a1, true :: b1)
                    end) (compute_code p1))) in |- *;
 apply in_map; auto.
Qed.

(* The computed code is in the alphabet of its leaves *)
Theorem in_alphabet_compute_code :
 forall m t,
 (forall a : A, In a m -> inb (leaf a) t) -> in_alphabet m (compute_code t).
Proof using.
intros m; elim m; simpl in |- *; auto.
intros a l H t H0; cut (inb (leaf a) t); auto; intros H1.
case inb_compute_ex with (1 := H1).
intros l1 Hl1; apply in_alphabet_cons with (ca := l1); auto.
Qed.

(* Two associations in the list with same prefix have same key *)
Theorem btree_unique_prefix1 :
 forall (t : btree) (a1 a2 : A) (lb1 lb2 : list bool),
 In (a1, lb1) (compute_code t) ->
 In (a2, lb2) (compute_code t) -> is_prefix lb1 lb2 -> a1 = a2.
Proof using.
intros t; elim t; simpl in |- *.
intros leaf1 a1 a2 lb1 lb2 H1 H2.
case H1; intros H3; [ injection H3 | case H3 ].
case H2; intros H4; [ injection H4 | case H4 ].
intros H H0 H5 H6 H7; apply trans_equal with (2 := H0); auto.
intros t1 Rec1 t2 Rec2 a1 a2 lb1 lb2 H1 H2.
case (in_app_or _ _ _ H1); case (in_app_or _ _ _ H2); clear H1 H2;
 intros H2 H1 H3.
generalize H1 H2; inversion H3.
intros H4; case in_map_inv with (1 := H4).
intros x; case x; intros x1 x2 (H5, H6); discriminate.
intros H5 H6; apply Rec1 with (lb1 := l1) (lb2 := l2); auto.
case in_map_inv with (1 := H5).
intros x; case x.
intros a l (H7, H8); injection H8.
intros R1 R2 R3; rewrite R1; rewrite R3; auto.
case in_map_inv with (1 := H6).
intros x; case x.
intros a l (H7, H8); injection H8.
intros R1 R2 R3; rewrite R1; rewrite R3; auto.
generalize H3.
case in_map_inv with (1 := H1).
intros x; case x; intros aa1 ll1 (H4, H5).
case in_map_inv with (1 := H2).
intros x1; case x1; intros aa2 ll2 (H6, H7).
inversion H5; inversion H7; intros tH8; inversion tH8.
generalize H3.
case in_map_inv with (1 := H1).
intros x; case x; intros aa1 ll1 (H4, H5).
case in_map_inv with (1 := H2).
intros x1; case x1; intros aa2 ll2 (H6, H7).
inversion H5; inversion H7; intros tH8; inversion tH8.
generalize H1 H2; inversion H3.
intros H4; case in_map_inv with (1 := H4).
intros x; case x; intros x1 x2 (H5, H6); discriminate.
intros H5 H6; apply Rec2 with (lb1 := l1) (lb2 := l2); auto.
case in_map_inv with (1 := H5).
intros x; case x.
intros a l (H7, H8); injection H8.
intros R1 R2 R3; rewrite R1; rewrite R3; auto.
case in_map_inv with (1 := H6).
intros x; case x.
intros a l (H7, H8); injection H8.
intros R1 R2 R3; rewrite R1; rewrite R3; auto.
Qed.

(* If a tree has distinc leaves its computed tree has unique keys *)
Theorem btree_unique_prefix2 :
 forall t : btree, distinct_leaves t -> unique_key (compute_code t).
Proof using.
intros t; elim t; simpl in |- *; auto.
intros b H b0 H0 H1.
apply unique_key_app; auto.
apply unique_key_map; auto.
apply H; apply distinct_leaves_l with (1 := H1); auto.
intros (a1, b1) (a2, b2); simpl in |- *; auto.
apply unique_key_map; auto.
apply H0; apply distinct_leaves_r with (1 := H1); auto.
intros (a1, b1) (a2, b2); simpl in |- *; auto.
intros a b1 c H2 H3.
case in_map_inv with (1 := H2); auto; case in_map_inv with (1 := H3); auto.
intros (a1, l1) (Ha1, Hl1) (a2, l2) (Ha2, Hl2).
apply (H1 (leaf a) b b0); auto.
injection Hl2; intros HH1 HH2; rewrite HH2.
apply inCompute_inb with (1 := Ha2).
injection Hl1; intros HH1 HH2; rewrite HH2.
apply inCompute_inb with (1 := Ha1).
Qed.

(* If a tree has distinct leaves its code is prefix *)
Theorem btree_unique_prefix :
 forall t : btree, distinct_leaves t -> unique_prefix (compute_code t).
Proof using.
intros t H1; split; try exact (btree_unique_prefix1 t);
 apply btree_unique_prefix2; auto.
Qed.

End Tree.
Arguments leaf [A].
Arguments node [A].
Arguments inb [A].
Arguments all_leaves [A].
Arguments distinct_leaves [A].
Arguments compute_code [A].
Arguments number_of_nodes [A].
Hint Constructors inb : core.
Hint Resolve distinct_leaves_leaf : core.
Hint Resolve length_compute_lt_O : core.


Require Import Rupicola.Lib.Core.
Require Import Rupicola.Lib.Notations.
Require Import Rupicola.Lib.Tactics.

Section CompilerBasics.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {memT: map.map word Byte.byte}.
  Context {localsT: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok memT}.
  Context {locals_ok : map.ok localsT}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Lemma compile_word_of_Z_constant {tr mem locals functions} (z: Z) :
    let v := word.of_Z z in
    forall {P} {pred: P v -> predicate}
      {k: nlet_eq_k P v} {k_impl}
      var,
      (let v := v in
       <{ Trace := tr;
          Memory := mem;
          Locals := map.put locals var v;
          Functions := functions }>
       k_impl
       <{ pred (k v eq_refl) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.set var (expr.literal z)) k_impl
      <{ pred (nlet_eq [var] v k) }>.
  Proof. repeat straightline; eassumption. Qed.

  Lemma compile_word_constant {tr mem locals functions} (w: word) :
    forall {P} {pred: P w -> predicate}
      {k: nlet_eq_k P w} {k_impl}
      var,
      <{ Trace := tr;
         Memory := mem;
         Locals := map.put locals var w;
         Functions := functions }>
      k_impl
      <{ pred (k w eq_refl) }> ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.set var (expr.literal (word.unsigned w))) k_impl
      <{ pred (nlet_eq [var] w k) }>.
  Proof. repeat straightline; subst_lets_in_goal; rewrite word.of_Z_unsigned; eauto. Qed.

  Lemma compile_Z_constant {tr mem locals functions} z :
    let v := z in
    forall {P} {pred: P v -> predicate}
      {k: nlet_eq_k P v} {k_impl}
      var,
      (let v := v in
       <{ Trace := tr;
          Memory := mem;
          Locals := map.put locals var (word.of_Z v);
          Functions := functions }>
       k_impl
       <{ pred (k v eq_refl) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.set var (expr.literal z)) k_impl
      <{ pred (nlet_eq [var] v k) }>.
  Proof. repeat straightline; eassumption. Qed.

  Lemma compile_nat_constant {tr mem locals functions} n :
    let v := n in
    forall {P} {pred: P v -> predicate}
      {k: nlet_eq_k P v} {k_impl}
      var,
      (let v := v in
       <{ Trace := tr;
          Memory := mem;
          Locals := map.put locals var (word.of_Z (Z.of_nat v));
          Functions := functions }>
       k_impl
       <{ pred (k v eq_refl) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.set var (expr.literal (Z.of_nat n))) k_impl
      <{ pred (nlet_eq [var] v k) }>.
  Proof. repeat straightline; eassumption. Qed.

  Lemma compile_bool_constant {tr mem locals functions} b :
    let v := b in
    forall {P} {pred: P v -> predicate}
      {k: nlet_eq_k P v} {k_impl}
      var,
      (let v := v in
       <{ Trace := tr;
          Memory := mem;
          Locals := map.put locals var (word.b2w v);
          Functions := functions }>
       k_impl
       <{ pred (k v eq_refl) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.set var (expr.literal (Z.b2z v))) k_impl
      <{ pred (nlet_eq [var] v k) }>.
  Proof. repeat straightline; eassumption. Qed.

  Lemma compile_binop_xxx {T} T2w op f
        (H: forall x y: T, T2w (f x y) = Semantics.interp_binop op (T2w x) (T2w y))
        {tr mem locals functions} (x y: T) :
    let v := f x y in
    forall {P} {pred: P v -> predicate}
      {k: nlet_eq_k P v} {k_impl}
      x_var y_var var,
      map.get locals x_var = Some (T2w x) ->
      map.get locals y_var = Some (T2w y) ->
      (let v := v in
       <{ Trace := tr;
          Memory := mem;
          Locals := map.put locals var (T2w v);
          Functions := functions }>
       k_impl
       <{ pred (k v eq_refl) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.set var (expr.op op (expr.var x_var) (expr.var y_var)))
              k_impl
      <{ pred (nlet_eq [var] v k) }>.
  Proof. repeat (eexists; split; eauto). Qed.

  Notation unfold_id term :=
    ltac:(let tm := fresh in pose term as tm;
          change (id ?x) with x in (type of tm);
          let t := type of tm in
          exact (tm: t)) (only parsing).

  Definition compile_word_add :=
    unfold_id (@compile_binop_xxx _ id bopname.add word.add ltac:(reflexivity)).
  Definition compile_word_sub :=
    unfold_id (@compile_binop_xxx _ id bopname.sub word.sub ltac:(reflexivity)).
  Definition compile_word_mul :=
    unfold_id (@compile_binop_xxx _ id bopname.mul word.mul ltac:(reflexivity)).
  Definition compile_word_mulhuu :=
    unfold_id (@compile_binop_xxx _ id bopname.mulhuu word.mulhuu ltac:(reflexivity)).
  Definition compile_word_divu :=
    unfold_id (@compile_binop_xxx _ id bopname.divu word.divu ltac:(reflexivity)).
  Definition compile_word_remu :=
    unfold_id (@compile_binop_xxx _ id bopname.remu word.modu ltac:(reflexivity)).
  Definition compile_word_and :=
    unfold_id (@compile_binop_xxx _ id bopname.and word.and ltac:(reflexivity)).
  Definition compile_word_or :=
    unfold_id (@compile_binop_xxx _ id bopname.or word.or ltac:(reflexivity)).
  Definition compile_word_xor :=
    unfold_id (@compile_binop_xxx _ id bopname.xor word.xor ltac:(reflexivity)).
  Definition compile_word_sru :=
    unfold_id (@compile_binop_xxx _ id bopname.sru word.sru ltac:(reflexivity)).
  Definition compile_word_slu :=
    unfold_id (@compile_binop_xxx _ id bopname.slu word.slu ltac:(reflexivity)).
  Definition compile_word_srs :=
    unfold_id (@compile_binop_xxx _ id bopname.srs word.srs ltac:(reflexivity)).

  Definition compile_Z_add :=
    @compile_binop_xxx _ word.of_Z bopname.add Z.add word.ring_morph_add.
  Definition compile_Z_sub :=
    @compile_binop_xxx _ word.of_Z bopname.sub Z.sub word.ring_morph_sub.
  Definition compile_Z_mul :=
    @compile_binop_xxx _ word.of_Z bopname.mul Z.mul word.ring_morph_mul.
  Definition compile_Z_and :=
    @compile_binop_xxx _ word.of_Z bopname.and Z.land word.morph_and.
  Definition compile_Z_or :=
    @compile_binop_xxx _ word.of_Z bopname.or Z.lor word.morph_or.
  Definition compile_Z_xor :=
    @compile_binop_xxx _ word.of_Z bopname.xor Z.lxor word.morph_xor.

  Lemma compile_binop_xxb {T} T2w op (f: T -> T -> bool)
        (H: forall x y, word.b2w (f x y) = Semantics.interp_binop op (T2w x) (T2w y))
        {tr mem locals functions} (x y: T) :
    let v := f x y in
    forall {P} {pred: P v -> predicate}
      {k: nlet_eq_k P v} {k_impl}
      x_var y_var var,
      map.get locals x_var = Some (T2w x) ->
      map.get locals y_var = Some (T2w y) ->
      (let v := v in
       <{ Trace := tr;
          Memory := mem;
          Locals := map.put locals var (word.b2w v);
          Functions := functions }>
       k_impl
       <{ pred (k v eq_refl) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.set var (expr.op op (expr.var x_var) (expr.var y_var)))
              k_impl
      <{ pred (nlet_eq [var] v k) }>.
  Proof. repeat (eexists; split; eauto). Qed.

  Ltac compile_binop_wwb_t :=
    unfold id; cbn; intros; destruct_one_match; reflexivity.

  Definition compile_word_lts :=
    unfold_id (@compile_binop_xxb _ id bopname.lts word.lts ltac:(compile_binop_wwb_t)).
  Definition compile_word_ltu :=
    unfold_id (@compile_binop_xxb _ id bopname.ltu word.ltu ltac:(compile_binop_wwb_t)).
  Definition compile_word_eqb :=
    unfold_id (@compile_binop_xxb _ id bopname.eq word.eqb ltac:(compile_binop_wwb_t)).

  Lemma bool_word_eq_compat {T} (T2w: T -> word) (eqb: T -> T -> bool)
        (T2w_inj: forall x y, T2w x = T2w y -> x = y)
        (eqb_compat: forall x y, eqb x y = true <-> x = y) :
    forall x y,
      word.b2w (eqb x y) =
      (if word.eqb (T2w x) (T2w y) then word.of_Z 1 else word.of_Z 0) :> word.
  Proof.
    intros; rewrite word.unsigned_eqb.
    destruct eqb eqn:Hb; destruct Z.eqb eqn:Hz; try reflexivity.
    - apply eqb_compat in Hb; subst.
      apply Z.eqb_neq in Hz; congruence.
    - apply Z.eqb_eq, word.unsigned_inj, T2w_inj in Hz; subst.
      rewrite (proj2 (eqb_compat _ _)) in Hb; congruence.
  Qed.

  Ltac compile_binop_bbb_t lemma :=
    unfold word.b2w; intros x y; cbn;
    match goal with
    | [  |- _ = ?w ] =>
      rewrite <- (word.of_Z_unsigned w);
      rewrite lemma, !word.unsigned_of_Z_b2z; destruct x, y; reflexivity
    end.

  Notation cbv_beta_b2w x :=
    ltac:(pose proof x as x0;
         change ((fun b => word.b2w b) ?y) with (word.b2w y : word) in (type of x0);
         let t := type of x0 in exact (x: t)) (only parsing).

  Definition compile_bool_eqb :=
    cbv_beta_b2w (@compile_binop_xxb
                    _ (fun x => word.b2w x) bopname.eq Bool.eqb
                    (bool_word_eq_compat (fun w => word.b2w w) _ word.b2w_inj Bool.eqb_true_iff)).

  (* FIXME add comparisons on bytes *)

  Definition compile_bool_andb :=
    cbv_beta_b2w (@compile_binop_xxb
                    _ (fun x => word.b2w x) bopname.and andb
                    ltac:(compile_binop_bbb_t word.unsigned_and_nowrap)).
  Definition compile_bool_orb :=
    cbv_beta_b2w (@compile_binop_xxb
                    _ (fun x => word.b2w x) bopname.or orb
                    ltac:(compile_binop_bbb_t word.unsigned_or_nowrap)).
  Definition compile_bool_xorb :=
    cbv_beta_b2w (@compile_binop_xxb
                    _ (fun x => word.b2w x) bopname.xor xorb
                    ltac:(compile_binop_bbb_t word.unsigned_xor_nowrap)).

  Lemma compile_copy_word {tr mem locals functions} v0 :
    let v := v0 in
    forall {P} {pred: P v -> predicate}
      {k: nlet_eq_k P v} {k_impl}
      src_var dst_var,
      map.get locals src_var = Some v0 ->
      (let v := v in
       <{ Trace := tr;
          Memory := mem;
          Locals := map.put locals dst_var v;
          Functions := functions }>
       k_impl
       <{ pred (k v eq_refl) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.set dst_var (expr.var src_var)) k_impl
      <{ pred (nlet_eq [dst_var] v k) }>.
  Proof.
    repeat straightline'; eauto.
  Qed.

  Lemma compile_copy_byte {tr mem locals functions} (b: byte) :
    let v := b in
    forall {P} {pred: P v -> predicate}
      {k: nlet_eq_k P v} {k_impl}
      src_var dst_var,
      map.get locals src_var = Some (word_of_byte b) ->
      (let v := v in
       <{ Trace := tr;
          Memory := mem;
          Locals := map.put locals dst_var (word_of_byte v);
          Functions := functions }>
       k_impl
       <{ pred (k v eq_refl) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.set dst_var (expr.var src_var)) k_impl
      <{ pred (nlet_eq [dst_var] v k) }>.
  Proof.
    repeat straightline'; eauto.
  Qed.
End CompilerBasics.

Module NoExprReflectionCompiler.
  #[export] Hint Extern 10 => simple eapply compile_word_constant; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_of_Z_constant; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_Z_constant; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_nat_constant; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_bool_constant; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_add; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_sub; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_mul; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_mulhuu; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_divu; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_remu; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_and; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_or; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_xor; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_sru; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_slu; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_srs; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_Z_add; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_Z_sub; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_Z_mul; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_Z_and; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_Z_or; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_Z_xor; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_lts; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_ltu; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_word_eqb; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_bool_eqb; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_bool_andb; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_bool_orb; shelve : compiler.
  #[export] Hint Extern 10 => simple eapply compile_bool_xorb; shelve : compiler.
End NoExprReflectionCompiler.