(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir *)

(** Provides a tactic for proving the uniqueness of objects. *)

Require Import Coq.Lists.List.
Require Import Coq.Logic.Eqdep_dec.

Require Import Coq.omega.Omega.

(* *********************************************************************** *)
(** * Auxiliary definitions *)

(** From a list of types, compute the type of a curried function whose
    arguments are those types. *)

Fixpoint arrow (xs : list Type) (res : Type) : Type :=
  match xs with
    | nil => res
    | cons y ys => y -> arrow ys res
  end.

(** From a list of types, compute the type of a heterogeneous list
    whose elements are of those types.  Heterogeneous lists are
    represented as nested tuples. *)

Fixpoint tuple (xs : list Type) : Type :=
  match xs with
    | nil => unit
    | cons y ys => (y * tuple ys)%type
  end.

(** Apply a curried function to a heterogeneous list of arguments. *)

Definition apply_tuple
  (xs : list Type) (res : Type) (f : arrow xs res) (arg : tuple xs)
  : res.
(* begin show *)
Proof.
  induction xs as [ | ? ? IH ].
  exact f.
  exact (IH  (f (fst arg)) (snd arg)).
Defined.
(* end show *)

(** Reverse a list onto the given accumulator.  Compared to
    [List.rev], this definition simplifies the implementation of
    heterogeneous list reversal (see below). *)

Fixpoint tr_list_rev (A : Type) (xs : list A) (acc : list A) : list A :=
  match xs with
    | nil => acc
    | cons y ys => tr_list_rev A ys (cons y acc)
  end.

Implicit Arguments tr_list_rev [ A ].

(** Reverse a list. *)

Definition list_rev (A : Type) (xs : list A) : list A :=
  tr_list_rev xs nil.

Implicit Arguments list_rev [ A ].

(** Reverse a heterogeneous list onto the given accumulator. *)

Definition tr_tuple_rev
  (xs : list Type) (ab : tuple xs)
  (acc : list Type) (acc' : tuple acc)
  : tuple (tr_list_rev xs acc).
(* begin show *)
Proof.
  generalize dependent acc'.
  generalize dependent acc.
  generalize dependent ab.
  induction xs as [ | ? ? IH ]; simpl; intros ab acc acc'.
  exact acc'.
  exact (IH (snd ab) (cons a acc) (fst ab, acc')).
Defined.
(* end show *)

(** Reverse a heterogenous list. *)

Definition tuple_rev
  (xs : list Type) (ab : tuple xs) : tuple (list_rev xs) :=
  tr_tuple_rev xs ab nil tt.

(* *********************************************************************** *)
(** * Auxiliary facts *)

(** This is the minimum set of facts about decidable equality that the
    [uniqueness] tactic (defined below) requires. *)

Lemma eq_unit_dec : forall (x y : unit),
  {x = y} + {x <> y}.
Proof. decide equality. Qed.

Lemma eq_pair_dec : forall (A B : Type),
  (forall x y : A, {x = y} + {x <> y}) ->
  (forall x y : B, {x = y} + {x <> y}) ->
  (forall x y : A * B, {x = y} + {x <> y}).
Proof. decide equality. Qed.

Hint Resolve eq_unit_dec eq_pair_dec : eq_dec.

(* *********************************************************************** *)
(** * Tactic for proving the uniqueness of objects *)

(** [uniqueness] analyzes goals of the form [C x1 .. xn = q] by
    destructing [q] using the [case] tactic.  It is mainly useful when
    [q] is an object of an indexed inductive type [Q], since it
    generalizes the goal such that [case] will succeed.  The argument
    should be the number of indices to [Q], and the indices should not
    depend on each other.

    Subgoals generated by the tactic will require one of three things:
    showing that the goal state is impossible, proving that equality
    at some type is decidable, and proving that any two objects of
    some type are equal.  The tactic [auto with eq_dec] is used to
    discharge subgoals of the second form.  The tactic [auto] is used
    to discharge subgoals of the third form. *)

Ltac uniqueness icount :=
  (** Expose the conclusion. *)
  intros;

  (** If the right hand side looks like a function application, flip
      the equality around.  This is merely so that the remainder of
      this tactic can assume that the goal is in a certain form. *)
  try (match goal with |- _ = ?f _ => symmetry end);

  (** Record the proof on the left hand side of the equality. *)
  let lhs := match goal with |- ?lhs = _ => constr:(lhs) end in

  (** Record the proof on the right hand side of the equality. *)
  let rhs := match goal with |- _ = ?rhs => constr:(rhs) end in

  (** Record the sort of the predicate. *)
  let sort := match type of rhs with
                | ?pred => match type of pred with ?sort => sort end
              end
  in

  (** Extract out the predicate applied only to its parameters.  We
      use the value of [icount] to determine the number of indices. *)
  let rec get_pred_type i pred :=
    match i with
      | O => pred
      | S ?n => match pred with ?f ?x => get_pred_type n f end
    end
  in
  let pred := get_pred_type icount ltac:(type of rhs) in

  (** Extract out the types of the predicate's indices.  We use the
      value of [icount] to determine the number of indices. *)
  let rec get_ind_types i pred acc :=
    match i with
      | O => acc
      | S ?n => match pred with
                  | ?f ?x => let ind := type of x in
                             get_ind_types n f (@cons Type ind acc)
                end
    end
  in
  let ind_types := get_ind_types icount ltac:(type of rhs) (@nil Type) in

  (** Extract out the predicate's indices.  We use the value of
      [icount] to determine the number of indices. *)
  let rec get_inds i pred acc :=
    match i with
      | O => acc
      | S ?n => match pred with ?f ?x => get_inds n f (x, acc) end
    end
  in
  let inds := get_inds icount ltac:(type of rhs) tt in

  (** For technical reasons that will become clear later in this
      tactic, we record reversed versions of the list of types of the
      predicate's indices and of the list of indices. *)
  let rind_types := constr:(list_rev ind_types) in
  let rinds := constr:(tuple_rev ind_types inds) in

  (** Now the real fun begins.  We need massage the goal so that it
      looks like [P index1 ... indexN rhs].  The trick is to define
      [P] appropriately.  The definition of [core] below is the first
      step in defining [P].  Compared to what we want, it is uncurried
      and the indices are in reverse order. *)
  let core :=
    constr:(fun (ainds : tuple rind_types)
                (rhs   : apply_tuple (list_rev rind_types)
                                     sort
                                     pred
                                     (tuple_rev rind_types ainds))
            =>
            forall eqpf : rinds = ainds,
              @eq (apply_tuple (list_rev rind_types)
                               sort
                               pred
                               (tuple_rev rind_types ainds))
                  (@eq_rect (tuple rind_types)
                            rinds
                            (fun rinds =>
                              apply_tuple (list_rev rind_types)
                                          sort
                                          pred
                                          (tuple_rev rind_types rinds))
                            lhs
                            ainds
                            eqpf)
                 rhs)
  in
  let core := eval simpl in core in

  (** Now, we take [core] and curry it.  When we curry [core], we end
      up "reversing" the order of arguments.  Because they started out
      reversed, what we end up with is function that takes the
      predicate's indices in the correct order when compared to the
      predicate's elimination principle.

      Implementation note (BEA): I don't see how to arrive at this
      curried form with out going through the "reversed list" stage. *)
  let rec curry f :=
    match type of f with
      | forall _ : (unit), _ => constr:(f tt)
      | forall _ : (_ * unit), _ => constr:(fun a => f (a, tt))
      | forall _ : (_ * _), _ =>
        let f' := constr:(fun b a => f (a, b)) in curry f'
    end
  in
  let core := curry core in
  let core := eval simpl in core in

  (** Now we supply to [core] the indices and the proof on the right
      hand side of the equality (the one we want to apply [case] to). *)
  let rec apply_core f args :=
    match args with
      | tt => constr:(f)
      | (?x, ?xs) => apply_core (f x) xs
    end
  in
  let core := apply_core core inds in
  let core := constr:(core rhs) in

  (** In order to make [core] convertible with the goal, we need to
      introduce an equality for the predicate's indices and generalize
      over that equality. *)
  change lhs with (@eq_rect (tuple rind_types)
                            rinds
                            (fun rinds =>
                              apply_tuple (list_rev rind_types)
                                          sort
                                          pred
                                          (tuple_rev rind_types rinds))
                            lhs
                            rinds
                            (refl_equal rinds));
  generalize (refl_equal rinds);

  (** We now have everything we need in order to use the [case] tactic. *)
  change core;
  case rhs;

  (** At this point, all that remains is to simplify everything.
      We begin by making sure all functions have reduced. *)
  unfold list_rev, tuple_rev in *;
  simpl tr_list_rev in *;
  simpl tr_tuple_rev in *;

  (** Next, we simplify the equality that we introduced earlier,
      checking for "obvious" contradictions in the process. *)
  repeat (match goal with
            | |- (_, _) = (_, _) -> _ =>
              let H := fresh in intros H; try discriminate; injection H
            | _ => progress intro
          end);
  subst;

  (** All that is left now is to use [eq_rect_eq_dec] to simplify
      occurrences of [eq_rect].  Since we have an equality between
      constructors, we can use [f_equal] to safely make progress from
      there.  We use [auto] and [auto with eq_dec] to clean up any
      subgoals. *)
  try (rewrite <- eq_rect_eq_dec; [ f_equal; auto | auto with eq_dec ]).


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(* $Id: DecidableTypeEx.v 12641 2010-01-07 15:32:52Z letouzey $ *)

Require Import DecidableType OrderedType OrderedTypeEx.
Set Implicit Arguments.
Unset Strict Implicit.

(** NB: This file is here only for compatibility with earlier version of
    [FSets] and [FMap]. Please use [Structures/Equalities.v] directly now. *)

(** * Examples of Decidable Type structures. *)

(** A particular case of [DecidableType] where
    the equality is the usual one of Coq. *)

Module Type UsualDecidableType := Equalities.UsualDecidableTypeOrig.

(** a [UsualDecidableType] is in particular an [DecidableType]. *)

Module UDT_to_DT (U:UsualDecidableType) <: DecidableType := U.

(** an shortcut for easily building a UsualDecidableType *)

Module Type MiniDecidableType := Equalities.MiniDecidableType.

Module Make_UDT (M:MiniDecidableType) <: UsualDecidableType
 := Equalities.Make_UDT M.

(** An OrderedType can now directly be seen as a DecidableType *)

Module OT_as_DT (O:OrderedType) <: DecidableType := O.

(** (Usual) Decidable Type for [nat], [positive], [N], [Z] *)

Module Nat_as_DT <: UsualDecidableType := Nat_as_OT.
Module Positive_as_DT <: UsualDecidableType := Positive_as_OT.
Module N_as_DT <: UsualDecidableType := N_as_OT.
Module Z_as_DT <: UsualDecidableType := Z_as_OT.

(** From two decidable types, we can build a new DecidableType
   over their cartesian product. *)

Module PairDecidableType(D1 D2:DecidableType) <: DecidableType.

 Definition t := prod D1.t D2.t.

 Definition eq x y := D1.eq (fst x) (fst y) /\ D2.eq (snd x) (snd y).

 Lemma eq_refl : forall x : t, eq x x.
 Proof.
 intros (x1,x2); red; simpl; auto.
 Qed.

 Lemma eq_sym : forall x y : t, eq x y -> eq y x.
 Proof.
 intros (x1,x2) (y1,y2); unfold eq; simpl; intuition.
 Qed.

 Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
 Proof.
 intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto.
 Qed.

 Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
 Proof.
 intros (x1,x2) (y1,y2); unfold eq; simpl.
 destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); intuition.
 Defined.

End PairDecidableType.

(** Similarly for pairs of UsualDecidableType *)

Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType.
 Definition t := prod D1.t D2.t.
 Definition eq := @eq t.
 Definition eq_refl := @refl_equal t.
 Definition eq_sym := @sym_eq t.
 Definition eq_trans := @trans_eq t.
 Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
 Proof.
 intros (x1,x2) (y1,y2);
 destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
 unfold eq, D1.eq, D2.eq in *; simpl;
 (left; f_equal; auto; fail) ||
 (right; intro H; injection H; auto).
 Defined.

End PairUsualDecidableType.


Require Export Iron.Language.SystemF2Data.Exp.
Require Export Iron.Language.SystemF2Data.Step.Context.
Require Export Iron.Language.SystemF2Data.Step.Step.

(********************************************************************)
(* Multi-step evaluation
   A sequence of small step transitions.

   As opposed to STEPSL, this version has an append constructor
   EsAppend that makes it easy to join two evaluations together.
   We use this when converting big-step evaluations to small-step. *)
Inductive STEPS : exp -> exp -> Prop :=

 (* After no steps, we get the same exp.
    We need this constructor to match the EVDone constructor
    in the big-step evaluation, so we can convert between big-step
    and multi-step evaluations. *)
 | EsNone
   :  forall x1
   ,  STEPS x1 x1

 (* Take a single step. *)
 | EsStep
   :  forall x1 x2
   ,  STEP  x1 x2
   -> STEPS x1 x2

 (* Combine two evaluations into a third. *)
 | EsAppend
   :  forall x1 x2 x3
   ,  STEPS x1 x2 -> STEPS x2 x3
   -> STEPS x1 x3.

Hint Constructors STEPS.

(********************************************************************)
(* Multi-step evaluating a wnf doesn't change it. *)
Lemma steps_wnfX
 :  forall x v
 ,  wnfX x -> STEPS x v -> v = x.
Proof.
 intros x v HW HS.
 induction HS; auto.
  Case "EsStep".
   apply step_wnfX; auto.

  Case "EsAppend".
   have (x2 = x1).
   subst. auto.
Qed.

(********************************************************************)
(* Multi-step evaluation in a context. *)
Lemma steps_context
 :  forall C x1 x1'
 ,  exp_ctx C
 -> STEPS x1 x1'
 -> STEPS (C x1) (C x1').
Proof.
 intros C x1 x1' HC HS.
 induction HS; eauto.
Qed.

(********************************************************************)
(* Multi-step evaluation of a data constructor argument. *)
Lemma steps_context_XCon
 :  forall C x v dc ts
 ,  exps_ctx wnfX C
 -> STEPS x v
 -> STEPS (XCon dc ts (C x)) (XCon dc ts (C v)).
Proof.
 intros C x v dc ts HC HS.
 induction HS; auto.
 - lets D: EsContext XcCon; eauto.
 - eauto.
Qed.

Lemma steps_in_XCon
 :  forall xs ts vs dc
 ,  Forall2 STEPS xs vs
 -> Forall wnfX vs
 -> STEPS (XCon dc ts xs) (XCon dc ts vs).
Proof.
 intros xs ts vs dc HS HW.
 lets HC: make_chain HS HW.
 - eapply steps_wnfX.
 - clear HS. clear HW.
   induction HC; auto.
   eapply (EsAppend (XCon dc ts (C x)) (XCon dc ts (C v))); auto.
   eapply steps_context_XCon; auto.
Qed.

(********************************************************************)
(* Multi-step evaluation of a primitive operator argument. *)
Lemma steps_context_XPrim
 :  forall C x v p
 ,  exps_ctx wnfX C
 -> STEPS x v
 -> STEPS (XPrim p (C x)) (XPrim p (C v)).
Proof.
 intros C x v p HC HS.
 induction HS; auto.
 - lets D: EsContext XcPrim; eauto.
 - eauto.
Qed.

Lemma steps_in_XPrim
 :  forall xs vs p
 ,  Forall2 STEPS xs vs
 -> Forall wnfX vs
 -> STEPS (XPrim p xs) (XPrim p vs).
Proof.
 intros xs vs p HS HW.
 lets HC: make_chain HS HW.
 - eapply steps_wnfX.
 - clear HS. clear HW.
   induction HC; auto.
   eapply (EsAppend (XPrim p (C x)) (XPrim p (C v))); auto.
   eapply steps_context_XPrim; auto.
Qed.


(************************************************************
* Lambda-calculus,                                          *
* Pretty-big-step trace semantics                           *
*************************************************************)

Set Implicit Arguments.
Require Export Lambda_Syntax LibStream Common.

Inductive act :=
  | act_epsilon : act
  | act_echo : nat -> act.

Definition itrace := stream act.
Implicit Types i : itrace.

Inductive instr :=
  | instr_skip : instr
  | instr_echo : nat -> instr.

Definition prog := list instr.

CoInductive cored : prog -> prog -> itrace -> Prop :=
  | cored_nil : forall P i,
     cored P P i ->
     cored P nil (act_epsilon:::i)
  | cored_skip : forall P L i,
     cored P L i ->
     cored P (instr_skip::L) (act_epsilon:::i)
  | cored_echo : forall P L i n,
     cored P L i ->
     cored P (instr_echo n::L) ((act_echo n)::: i).

Fixpoint trans L :=
  match L with
  | nil => nil
  | instr_skip::L' => trans L'
  | instr_echo n::L' => (instr_echo n)::(trans L')
  end.

(*
Fixpoint epsilons n :=
  match n with
  | O => nil
  | S n' => act_epsilon::epsilons n'
  end.
*)

Fixpoint epsilons n i :=
  match n with
  | O => i
  | S n' => act_epsilon:::epsilons n' i
  end.

CoInductive sim : binary itrace :=
  | sim_intro : forall n1 n2 w i1 i2,
     sim i1 i2 ->
     sim (epsilons n1 (w:::i1)) (epsilons n2 (w:::i2)).

CoInductive coredn : nat -> prog -> prog -> itrace -> Prop :=
  | coredn_nil : forall P i p q,
     coredn p P P i ->
     coredn q P nil (act_epsilon:::i)
  | coredn_skip : forall P L i p q,
     coredn p P L i ->
     coredn q P (instr_skip::L) (act_epsilon:::i)
  | coredn_echo : forall P L i n p q,
     coredn p P L i ->
     coredn q P (instr_echo n::L) ((act_echo n):::i)
  | coredn_epsilons : forall a b p P L i,
     coredn p P L (epsilons a i) ->
     coredn (S p) P L (epsilons b i).

CoInductive corednT : nat -> prog -> prog -> itrace -> Type :=
  | corednT_nil : forall P i p q,
     corednT p P P i ->
     corednT (S q) P nil (act_epsilon:::i)
  | corednT_skip : forall P L i p q,
     corednT p P L i ->
     corednT (S q) P (instr_skip::L) (act_epsilon:::i)
  | corednT_echo : forall P L i n p q,
     corednT p P L i ->
     corednT (S q) P (instr_echo n::L) ((act_echo n):::i)
  | corednT_epsilons : forall a b p P L i,
     corednT p P L (epsilons a i) ->
     corednT (S p) P L (epsilons b i).

CoFixpoint wit : forall p P L i (H:corednT p P L i), itrace.
Proof.
  cofix IH.
  introv H.
  assert (next : act*itrace).
    gen p L i. fix 1.
    destruct p; introv M.
    inversion M.
    inversion M.
    exact (act_epsilon,IH _ _ _ _ H0).
    exact (act_epsilon,i).
    exact (act_echo n,i).
    exact (wit0 _ _ _ H0).
  destruct next as [a' i'].
  exact (a':::i').
Defined.

Print wit.

(*

CoFixpoint wit : forall p P L i (H:corednT p P L i), itrace.
Proof.
  cofix IH.
  introv H. destruct H.
  exact (act_epsilon:::(IH _ _ _ _ H)).
  exact (act_epsilon:::(IH _ _ _ _ H)).
  exact (act_echo n:::(IH _ _ _ _ H)).
  assert (next : act*itrace).
  gen H. generalize (epsilons a i) as j. clear a i.
  gen p. fix 1.
    destruct p; introv M.
    inversion M.
    exact (act_epsilon,i).
    exact (act_epsilon,i).
    exact (act_echo n,i).
    inversion M.
    exact (act_epsilon,i).
    exact (act_epsilon,i).
    exact (act_echo n,i).
    exact (wit0 _ _ H0).
  destruct next as [w j].
  exact (w:::j).
Defined.
*)

Lemma sim_one : forall w i1 i2,
     sim i1 i2 ->
     sim (w:::i1) (w:::i2).
Proof.
intros. apply* (sim_intro 0 0).
Defined.

Lemma sim_step : forall i1 i2,
  match i1,i2 with
  | x1:::j1, x2:::j2 => x1 = x2 /\ sim j1 j2
  end ->
  sim i1 i2.
Proof.
  introv H. destruct i1. destruct i2. destruct H. subst.
  apply sim_one. auto.
Qed.

Lemma wit_coredn_sim : forall p P L i
  (H:corednT p P L i),
  sim i (wit H).
Proof.
  cofix IH. intros.
  asserts (?&?&?&?&?&?&?): (exists w p' L' i', exists H':corednT p' P L' i',
    i = w:::i' /\ sim (wit H) (w:::wit H')).
  induction p.
    inversion H.
    destruct H.
    exists __ __ __ __ H. split. eauto.
    eapply sim_step. simpl. split. auto. apply IH.

    unfold wit.
  subst. rewrite H1. apply sim_one. apply IH.
Qed.

 /\ cored P L (wit H i')

Lemma coredn_cored : forall n P L i,
  coredn n P L i ->
  exists i', sim i i' /\ cored P L i'.
Proof.

Qed.

Lemma coredn_epsilon : forall p P L i,
  coredn p P L i ->
  coredn (S p) P L (act_epsilon:::i).
Proof. applys coredn_epsilons O (S O). Defined.

Lemma trans_sim_core : forall P L i,
  cored P L i ->
  coredn (length L) (trans P) (trans L) i.
Proof.
  cofix IH. introv H.
  inverts H; rew_list; simpl.
  constructors*.
  applys* coredn_epsilon.
  constructors*.
Qed.

Lemma trans_sim : forall P L i,
  cored P L i ->
  exists i', sim i i' /\ cored (trans P) (trans L) i'.
Proof.
  introv H.
  applys coredn_cored.
  applys* trans_sim_core.
Qed.

Implicit Types v : val.
Implicit Types t : trm.

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

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

(** Grammar of actions *)

Inductive act :=
  | act_epsilon : act.

(** Grammar of traces *)

Definition ftrace := list act.
Definition itrace := stream act.

Implicit Types f : ftrace.
Implicit Types i : itrace.

(** Grammar of outcomes *)

Inductive beh :=
  | beh_val : val -> beh
  | beh_err : beh.

Coercion beh_val : val >-> beh.

Inductive out :=
  | out_ter : ftrace -> beh -> out
  | out_div : itrace -> out.

Implicit Types o : out.

Definition out_prepend f o :=
  match o with
  | out_ter f' b => out_ter (f ++ f') b
  | out_div i => out_div (stream_prepend f i)
  end.

Notation "f ^^ o" := (out_prepend f o) (at level 60, right associativity).

Definition one_step := act_epsilon::nil.

Definition step o :=
  one_step ^^ o.

(** Grammar of extended terms *)

Inductive ext : Type :=
  | ext_trm : trm -> ext
  | ext_app_1 : out -> trm -> ext
  | ext_app_2 : val -> out -> ext.

Coercion ext_trm : trm >-> ext.
Implicit Types e : ext.

(** Abort behavior *)

Inductive abort : out -> Prop :=
  | abort_err : forall f, abort (out_ter f beh_err)
  | abort_div : forall i, abort (out_div i).

(** "One rule applies" judgment *)

Inductive one : ext -> Prop :=
  | one_val : forall v,
      one v
  | one_abs : forall x t,
      one (trm_abs x t)
  | one_app : forall t1 t2,
      one (trm_app t1 t2)
  | one_app_1_abort : forall o1 t2,
      abort o1 ->
      one (ext_app_1 o1 t2)
  | one_app_1 : forall v1 t2 f,
      one (ext_app_1 (out_ter f v1) t2)
  | one_app_2_abort : forall v1 o2,
      abort o2 ->
      one (ext_app_2 v1 o2)
  | one_app_2 : forall x t3 v2 f,
      one (ext_app_2 (val_clo x t3) (out_ter f v2)).

(** Evaluation judgment *)

Inductive red : ext -> out -> Prop :=
  | red_val : forall v,
      red v (out_ter one_step v)
  | red_abs : forall x t,
      red (trm_abs x t) (out_ter one_step (val_clo x t))
  | red_app : forall o1 t1 t2 o2,
      red t1 o1 ->
      red (ext_app_1 o1 t2) o2 ->
      red (trm_app t1 t2) (step o2)
  | red_app_1_abort : forall t2 i,
      red (ext_app_1 (out_div i) t2) (step (out_div i))
  | red_app_1 : forall o2 v1 t2 o f,
      red t2 o2 ->
      red (ext_app_2 v1 o2) o ->
      red (ext_app_1 (out_ter f v1) t2) (step (f ^^ o))
  | red_app_2_abort : forall v1 i,
      red (ext_app_2 v1 (out_div i)) (step (out_div i))
  | red_app_2 : forall x t3 v2 o f,
      red (subst x v2 t3) o ->
      red (ext_app_2 (val_clo x t3) (out_ter f v2)) (step (f ^^ o))
  | red_err : forall e,
      ~ one e ->
      red e (out_ter one_step beh_err).

(** Co-evaluation judgment: copy-paste of the above
    definition, where [red] is replaced with [cored]
    and where [Inductive] becomes [CoInductive]. *)

CoInductive cored : ext -> out -> Prop :=
  | cored_val : forall v,
      cored v (out_ter one_step v)
  | cored_abs : forall x t,
      cored (trm_abs x t) (out_ter one_step (val_clo x t))
  | cored_app : forall o1 t1 t2 o2,
      cored t1 o1 ->
      cored (ext_app_1 o1 t2) o2 ->
      cored (trm_app t1 t2) (step o2)
  | cored_app_1_abort : forall t2 i,
      cored (ext_app_1 (out_div i) t2) (step (out_div i))
  | cored_app_1 : forall o2 v1 t2 o f,
      cored t2 o2 ->
      cored (ext_app_2 v1 o2) o ->
      cored (ext_app_1 (out_ter f v1) t2) (step (f ^^ o))
  | cored_app_2_abort : forall v1 i,
      cored (ext_app_2 v1 (out_div i)) (step (out_div i))
  | cored_app_2 : forall x t3 v2 o f,
      cored (subst x v2 t3) o ->
      cored (ext_app_2 (val_clo x t3) (out_ter f v2)) (step (f ^^ o))
  | cored_err : forall e,
      ~ one e ->
      cored e (out_ter one_step beh_err).

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

(************************************************************)
(* ** Basic properties of the semantics *)

Hint Constructors red cored.
Hint Extern 1 (_ <> _) => congruence.

(** Proof that [cored] contains [red] *)

Theorem red_cored : forall e o,
  red e o -> cored e o.
Proof. introv H. induction* H. Qed.

(** Proof that [cored] on a finite trace implies [red] *)

Hint Extern 1 (length _ < length _) =>
   unfold one_step; rew_list; math.

(*
Theorem cored_ter_red : forall f e v,
  cored e (out_ter f v) -> red e (out_ter f v).
Proof.
  intros f. gen_eq n: (length f). gen f.
  induction n using peano_induction.
  introv E R. subst.
  asserts IH: (forall e v f', cored e (out_ter f' v) ->
    length f' < length f -> red e (out_ter f' v)).
    introv M L. applys* H. clear H.
  inverts R as.
  auto.
  auto.
  introv R1 R2 E. destruct o2; simpls; inverts E.
   forwards~ M1: IH R2. inverts M1 as R3 R4 F.
   destruct o; simpls; inverts F.
   forwards~ M2: IH R1. applys_eq* red_app 1.
  introv R1 R2 E. destruct o; simpls; inverts E.
   forwards~ M1: IH R2. inverts M1 as R3 F.
   destruct o; simpls; inverts F.
   forwards~ M2: IH R1. applys_eq* red_app_1 1.
  introv R1 E. destruct o; simpls; inverts E.
   forwards~ M1: IH R1. applys_eq* red_app_2 1.
Qed.
*)

(************************************************************)
(* ** Complete coverage *)

Lemma complete : forall e,
  exists o, cored e o.
Proof.
  skip.
Qed.

(************************************************************)
(* ** Determinacy *)

(* when traces contain only act_epsilon, we have: *)
Lemma itrace_bisim : forall i1 i2,
  i1 === i2.
Proof.
  cofix IH. intros. destruct i1 as [[]].
  destruct i2 as [[]]. constructor. apply IH.
Qed.

Hint Resolve itrace_bisim.

Inductive out_sim : binary out :=
  | out_sim_ter : forall f1 f2 b,
     (* sim_epsilon f1 f2 ->*)
     out_sim (out_ter f1 b) (out_ter f2 b)
  | out_sim_div : forall q1 q2,
     (* sim_epsilon q1 q2 ->*)
     out_sim (out_div q1) (out_div q2).

Hint Constructors one.
Hint Constructors abort.

Lemma determinacy_ter : forall f e b o,
  cored e (out_ter f b) -> cored e o ->
  o = out_ter f b.
Proof.
  intros f. gen_eq n: (length f). gen f.
  induction n using peano_induction.
  asserts IH: (forall e f b o,
    cored e (out_ter f b) -> cored e o ->
    length f < n ->
    o = out_ter f b).
    intros. apply* H. clear H.
  introv E R1 R2. subst. inverts R1.
  inverts R2; [|false*H]. eauto.
  inverts R2; [|false*H]. eauto.
Focus 1.
  inverts R2; [|false*H].
    destruct o2; [|false]. inverts H.
    asserts (fa&ba&E&L): (exists ba fa, o1 = out_ter fa ba /\
     length fa < length f0).
      inverts H2.
        exists___. split. eauto. skip.
        destruct o1.
           exists___. split. eauto.
           false* H3.
     subst. forwards* E: (>> IH H0 H4).

      inverts H2. false* H3.

  inverts R2; [|false*H].
    destruct o0; [|false]. inverts H.
    destruct o2.
      inverts H2. skip.
      forwards* E: (>> IH H0 H6).
      inverts H2. false* H3.
  inverts R2; [|false*H].
    destruct o0; [|false]. inverts H.
    rewrites* (>> IH H1 H6).
  inverts R2; try solve [ false* H1 ]. eauto.
Qed.

*)

Lemma determinacy_ter' : forall f e b o,
  cored e (out_ter f b) -> cored e o ->
    exists f', o = out_ter f' b.
Proof.
  intros f. gen_eq n: (length f). gen f.
  induction n using peano_induction.
  asserts IH: (forall e f b o,
    cored e (out_ter f b) -> cored e o ->
    length f < n ->
    exists f', o = out_ter f' b).
    intros. apply* H. clear H.
  introv E R1 R2. subst. inverts R1.
  inverts R2; [|false*H]. eauto.
  inverts R2; [|false*H]. eauto.
  inverts R2; [|false*H]. skip.
  inverts R2; [|false*H].
    destruct o0; [|false]. inverts H.
    destruct o2.
      skip.
      inverts H2. false* H3.
  inverts R2; [|false*H].
    destruct o0; [|false]. inverts H.
    forwards* [f' E]: IH H1 H6. subst. simple*.
  inverts R2; try solve [ false* H1 ]. eauto.
Qed.

Lemma determinacy_div : forall e i1 i2,
  cored e (out_div i1) -> cored e (out_div i2) ->
    i1 === i2.
Proof.
  intros. apply itrace_bisim.
Qed.

Lemma determinacy : forall e o1 o2,
  cored e o1 -> cored e o2 -> out_sim o1 o2.
Proof.
  intros.
  destruct o1 as [f1 b|i1].
    forwards* [f' E]: determinacy_ter H. subst.
     constructor.
    destruct o2 as [f2 b|i2].
      forwards* [f' E]: determinacy_ter H. false.
      constructor.
Qed.

(************************************************************)
(* ** Interpreter *)

CoInductive phi :=
  | phi_now : beh -> phi
  | phi_later : act -> phi -> phi.

(** Bind-style operators *)

Definition if_success (r:res) (k:val->phi) : phi :=
  match r with
  | res_return (beh_ret v) => k v
  | _ => r
  end.

Definition if_isclo (v:val) (k:var->trm->phi) : phi :=
  match v with
  | val_clo x t => k x t
  | _ => phi_now beh_err
  end.

CoFixpoint run (t:trm) : phi :=
  phi_later (match t with
    | trm_val v => phi_now v
    | trm_abs x t1 => phi_now (val_clo x t1)
    | trm_var x => phi_now beh_err
    | trm_app t1 t2 =>
       if_success (run t1) (fun v1 =>
         if_success (run t2) (fun v2 =>
            if_isclo v1 (fun x t3 =>
              run (subst x v2 t3))))
    end).

Hint Resolve bisimilar_mod_equiv.

(*
Lemma stream_prepend_bisimilar_inv : forall f i1 i2',
  stream_prepend f i1 === i2' ->
  exists i2, i1 === i2 /\ stream_prepend f i2 = i2'.
Proof.
  intros f. induction f; introv E; simpls.
  exists* i2'.
  destruct i2' as [b i2']. inverts E.
  forwards (i3&?&?): IHf.
  skip.
  exists i3. split*. fequals.
Qed.

*)

Lemma equates_1 : forall A0,
  forall (P:A0->Prop) x1 y1,
  P y1 -> x1 = y1 -> P x1.
Proof. intros. subst. auto. Defined.

Ltac equates_lemma n ::=
  match nat_from_number n with
  | 0%nat => constr:(equates_0)
  | 1%nat => constr:(equates_1)
  | 2%nat => constr:(equates_2)
  | 3%nat => constr:(equates_3)
  | 4%nat => constr:(equates_4)
  | 5%nat => constr:(equates_5)
  | 6%nat => constr:(equates_6)
  end.

Hint Extern 1 (_ === _) =>
  apply equiv_refl; apply bisimilar_mod_equiv.

Theorem cored_div_bisim : forall t i i',
  cored t (out_div i) -> bisimilar i i' -> cored t (out_div i').
Proof.
  cofix IH. introv R B. inverts R as.
  introv R1 R2 E. destruct o2; simpls; tryfalse.
   destruct i as [x i1]. destruct i' as [x' i1']. inverts B as B.
   inverts E. inverts R2 as.
     inverts B. forwards* M1: IH R1. applys_eq* cored_app 1.
     introv R2 R3 E. destruct o; simpls; tryfalse.
      destruct i1 as [x i2]. destruct i1' as [x' i2']. inverts B as B.
      inverts E. lets (i2&B1&B2): stream_prepend_bisimilar_inv B.
      inverts R3 as.
        inverts B1. subst. forwards* M1: IH R2. applys_eq* cored_app 1.
        introv R3 E. destruct o; simpls; tryfalse.
         inverts E. inverts B1 as B1.
          lets (i3&B3&B4): stream_prepend_bisimilar_inv B1.
           forwards* M1: IH R3. subst. applys_eq* cored_app 1.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal84.

Set Printing Depth 1000.
Definition lfind_eval  z y:=
mult y z.

Compute lfind_eval  (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Zero).

Compute lfind_eval  (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Zero) (Zero).

Compute lfind_eval  (Zero) (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))).

Compute lfind_eval  (Succ Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Succ Zero) (Zero).

Compute lfind_eval  (Succ Zero) (Succ Zero).

Compute lfind_eval  (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Succ Zero) (Succ Zero).

Compute lfind_eval  (Zero) (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)) (Succ Zero).

Compute lfind_eval  (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Zero) (Zero).

Compute lfind_eval  (Succ Zero) (Zero).

Compute lfind_eval  (Succ (Succ (Succ (Succ (Succ Zero))))) (Zero).

Compute lfind_eval  (Zero) (Zero).

Compute lfind_eval  (Zero) (Succ Zero).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Zero).

Compute lfind_eval  (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Succ Zero) (Zero).

Compute lfind_eval  (Zero) (Zero).


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import Reals.
Require Import Tactiques.
Require Import Rbase_doubles_inegalites.

Lemma Rabsolu_def2_moins : forall r r1 : R, (Rabs r < r1)%R -> (- r1 < r)%R.
Proof.
intros.
apply proj1 with (r < r1)%R.
apply penible; apply Rabs_def2; auto.
Qed.
Hint Resolve Rabsolu_complements.Rabsolu_def2_moins: real.

Lemma Rabsolu_not_eq : forall x : R, Rabs x <> 0%R -> 0%R <> x.
Proof.
intros.
elim (Req_dec x 0); intro.
rewrite H0 in H.
rewrite Rabs_R0 in H.
rewrite H0; auto.
auto with real.
Qed.
Hint Resolve Rabsolu_complements.Rabsolu_not_eq: real.

Lemma Rabsolu_def4 : forall x a : R, (- a < x < a)%R -> (Rabs x < a)%R.
Proof.
intros.
apply Rabs_def1; elim H; auto.
Qed.
Hint Resolve Rabsolu_complements.Rabsolu_def4: real.


From Hammer Require Import Hammer.

Require Export Bool DecidableType OrderedType.
Set Implicit Arguments.
Unset Strict Implicit.

Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true.

Module Type WSfun (E : DecidableType).

Definition key := E.t.
Hint Transparent key.

Parameter t : Type -> Type.

Section Types.

Variable elt:Type.

Parameter empty : t elt.

Parameter is_empty : t elt -> bool.

Parameter add : key -> elt -> t elt -> t elt.

Parameter find : key -> t elt -> option elt.

Parameter remove : key -> t elt -> t elt.

Parameter mem : key -> t elt -> bool.

Variable elt' elt'' : Type.

Parameter map : (elt -> elt') -> t elt -> t elt'.

Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'.

Parameter map2 :
(option elt -> option elt' -> option elt'') -> t elt -> t elt' ->  t elt''.

Parameter elements : t elt -> list (key*elt).

Parameter cardinal : t elt -> nat.

Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A.

Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool.

Section Spec.

Variable m m' m'' : t elt.
Variable x y z : key.
Variable e e' : elt.

Parameter MapsTo : key -> elt -> t elt -> Prop.

Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m.

Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.

Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p').

Definition eq_key_elt (p p':key*elt) :=
E.eq (fst p) (fst p') /\ (snd p) = (snd p').

Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.

Parameter mem_1 : In x m -> mem x m = true.
Parameter mem_2 : mem x m = true -> In x m.

Parameter empty_1 : Empty empty.

Parameter is_empty_1 : Empty m -> is_empty m = true.
Parameter is_empty_2 : is_empty m = true -> Empty m.

Parameter add_1 : E.eq x y -> MapsTo y e (add x e m).
Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.

Parameter remove_1 : E.eq x y -> ~ In y (remove x m).
Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.

Parameter find_1 : MapsTo x e m -> find x m = Some e.
Parameter find_2 : find x m = Some e -> MapsTo x e m.

Parameter elements_1 :
MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
Parameter elements_2 :
InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.

Parameter elements_3w : NoDupA eq_key (elements m).

Parameter cardinal_1 : cardinal m = length (elements m).

Parameter fold_1 :
forall (A : Type) (i : A) (f : key -> elt -> A -> A),
fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.

Definition Equal m m' := forall y, find y m = find y m'.
Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
(forall k, In k m <-> In k m') /\
(forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp).

Variable cmp : elt -> elt -> bool.

Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true.
Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'.

End Spec.
End Types.

Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
MapsTo x e m -> MapsTo x (f e) (map f m).
Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
In x (map f m) -> In x m.

Parameter mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
(f:key->elt->elt'), MapsTo x e m ->
exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
(f:key->elt->elt'), In x (mapi f m) -> In x m.

Parameter map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
(x:key)(f:option elt->option elt'->option elt''),
In x m \/ In x m' ->
find x (map2 f m m') = f (find x m) (find x m').

Parameter map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
(x:key)(f:option elt->option elt'->option elt''),
In x (map2 f m m') -> In x m \/ In x m'.

Hint Immediate MapsTo_1 mem_2 is_empty_2
map_2 mapi_2 add_3 remove_3 find_2
: map.
Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1
remove_2 find_1 fold_1 map_1 mapi_1 mapi_2
: map.

End WSfun.

Module Type WS.
Declare Module E : DecidableType.
Include WSfun E.
End WS.

Module Type Sfun (E : OrderedType).
Include WSfun E.
Section elt.
Variable elt:Type.
Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p').

Parameter elements_3 : forall m, sort lt_key (elements m).

End elt.
End Sfun.

Module Type S.
Declare Module E : OrderedType.
Include Sfun E.
End S.

Module Type Sord.

Declare Module Data : OrderedType.
Declare Module MapS : S.
Import MapS.

Definition t := MapS.t Data.t.

Parameter eq : t -> t -> Prop.
Parameter lt : t -> t -> Prop.

Axiom eq_refl : forall m : t, eq m m.
Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.

Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end.

Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'.

Parameter compare : forall m1 m2, Compare lt eq m1 m2.

End Sord.


Require Import Bool String List Lia.
Require Import Lib.CommonTactics Lib.NatLib Lib.Indexer
        Lib.Struct Lib.DepEq Lib.Word Lib.FMap Lib.Reflection.
Require Import Kami.Syntax Kami.Notations Kami.Semantics Kami.SemFacts Kami.Tactics.

Require Import ZArith Eqdep Program.Equality.

Set Implicit Arguments.
Open Scope string.

(* Some useful facts about [word], only for the multiplier implementation. *)
Section WordEx.

  Definition rtrunc1 sz (w: word (S sz)): word sz:=
    match w with
    | WO => tt
    | WS _ w' => w'
    end.

  Definition rtrunc2 sz (w: word (S (S sz))): word sz :=
    match w with
    | WO => tt
    | WS _ w' =>
      match w' with
      | WO => tt
      | WS _ w'' => w''
      end
    end.

  Lemma wordToNat_rtrunc1:
    forall sz (w: word (S sz)),
      wordToNat (rtrunc1 w) = wordToNat w / 2.
  Proof.
    dependent destruction w.
    unfold rtrunc1, wordToNat; fold wordToNat.
    destruct b.
    - change (S (wordToNat w * 2)) with (1 + wordToNat w * 2).
      rewrite Nat.div_add by discriminate.
      reflexivity.
    - apply eq_sym, Nat.div_mul; discriminate.
  Qed.

  Lemma combine_wrshifta_rtrunc1_sext:
    forall s (w: word s) sl (wl: word (S (S sl))) su (wu: word (S su)),
      existT word s w =
      existT word ((S (S sl)) + S su) (combine wl wu) ->
      existT word s (wrshifta w 1) =
      existT word ((S sl) + (S su + 1)) (combine (rtrunc1 wl) (sext wu 1)).
  Proof.
    intros.
    pose proof (eq_sigT_fst H); subst.
    destruct_existT.
    apply wordToNat_existT; [lia|].

    rewrite wordToNat_wrshifta.
    change (pow2 1) with 2.
    rewrite wordToNat_combine.
    pose proof (combine_sext wl wu 1).
    apply existT_wordToNat in H; rewrite <-H.
    rewrite wordToNat_combine.
    change (pow2 (S (S sl))) with (2 * pow2 (S sl)).
    rewrite <-Nat.mul_assoc.
    rewrite Nat.mul_comm with (n:= 2).
    rewrite Nat.div_add by discriminate.
    rewrite wordToNat_rtrunc1.
    reflexivity.
  Qed.

  Lemma wordToNat_rtrunc2:
    forall sz (w: word (S (S sz))),
      wordToNat (rtrunc2 w) = wordToNat w / 4.
  Proof.
    do 2 dependent destruction w.
    unfold rtrunc2, wordToNat; fold wordToNat.
    destruct b, b0.
    - replace (S (S (wordToNat w * 2) * 2))
        with (3 + wordToNat w * 4) by lia.
      rewrite Nat.div_add by discriminate.
      reflexivity.
    - replace (S (wordToNat w * 2 * 2))
        with (1 + wordToNat w * 4) by lia.
      rewrite Nat.div_add by discriminate.
      reflexivity.
    - replace (S (wordToNat w * 2) * 2)
        with (2 + wordToNat w * 4) by lia.
      rewrite Nat.div_add by discriminate.
      reflexivity.
    - replace (wordToNat w * 2 * 2)
        with (wordToNat w * 4) by lia.
      apply eq_sym, Nat.div_mul; discriminate.
  Qed.

  Lemma combine_wrshifta_rtrunc2_sext:
    forall s (w: word s) sl (wl: word (S (S (S sl)))) su (wu: word (S su)),
      existT word s w =
      existT word ((S (S (S sl))) + S su) (combine wl wu) ->
      existT word s (wrshifta w 2) =
      existT word ((S sl) + (S su + 2)) (combine (rtrunc2 wl) (sext wu 2)).
  Proof.
    intros.
    pose proof (eq_sigT_fst H); subst.
    destruct_existT.
    apply wordToNat_existT; [lia|].

    rewrite wordToNat_wrshifta.
    change (pow2 2) with 4.
    rewrite wordToNat_combine.
    pose proof (combine_sext wl wu 2).
    apply existT_wordToNat in H; rewrite <-H.
    rewrite wordToNat_combine.
    replace (pow2 (S (S (S sl)))) with (4 * pow2 (S sl)) by (simpl; lia).
    rewrite <-Nat.mul_assoc.
    rewrite Nat.mul_comm with (n:= 4).
    rewrite Nat.div_add by discriminate.
    rewrite wordToNat_rtrunc2.
    reflexivity.
  Qed.

End WordEx.

(** A radix-4 Booth Multiplier.*)

(* Note that the Booth multiplication algorithm is naturally designed
 * for signed integers, so we need to add sign bits (0) for unsigned integers
 * and their multiplication. It means we have to deal with 65 bits for 64-bit
 * unsigned multiplication.
 *
 * Here we assume the multiplier always takes _65-bit signed integers_ as
 * arguments.
 *)
Section Multiplier32.
  (* NOTE: it's hard to declare [LogNumPhases] and [NumBitsPerPhase] as
   * variables, since truncation and extension require certain equation
   * w.r.t. bit-lengths.
   *)
  (* Variable MultLogNumPhases MultNumStepsPerPhase: nat. *)
  Definition MultLogNumPhases := 2.
  Definition MultNumStepsPerPhase := 4.
  (* 2*4 = 8 bits are calculated per a phase. *)
  Definition MultNumBitsPerPhase := 2 * MultNumStepsPerPhase.

  Definition MultNumPhases := wordToNat (wones MultLogNumPhases) + 1. (* 2^2 = 4 *)
  Definition MultNumBits := MultNumPhases * MultNumBitsPerPhase. (* 4*8 = 32 *)
  Definition MultNumBitsExt := MultNumBits + 1. (* 4*8 + 1 = 33 *)
  Definition MultBits := 2 * MultNumBitsExt + 2.

  Definition MultInStr := STRUCT { "multiplicand" :: Bit MultNumBitsExt;
                                   "multiplier" :: Bit MultNumBitsExt }.
  Definition MultOutStr := STRUCT { "high" :: Bit MultNumBits;
                                    "low" :: Bit MultNumBits }.

  (* NOTE: must use shirt-right-arithmetic to preserve the sign bit. *)
  Definition boothStep' {ty}
             (m_pos m_neg: fullType ty (SyntaxKind (Bit MultBits)))
             (p: Expr ty (SyntaxKind (Bit MultBits)))
             (pr: Expr ty (SyntaxKind (Bit 2))) :=
    let pSra := (p ~>> $$(WO~1))%kami_expr in
    (IF (pr == $$(WO~0~1)) then pSra + (#m_pos ~>> $$(WO~1))
     else IF (pr == $$(WO~1~0)) then pSra + (#m_neg ~>> $$(WO~1))
     else pSra)%kami_expr.

  Definition boothStep {ty}
             (m_pos m_neg: fullType ty (SyntaxKind (Bit MultBits)))
             (p: Expr ty (SyntaxKind (Bit ((MultBits - 2) + 2))))
    : Expr ty (SyntaxKind (Bit MultBits)) :=
    (boothStep' m_pos m_neg p (UniBit (Trunc 2 _) p))%kami_expr.

  Lemma boothStep'_eval:
    forall m_pos m_neg p pr,
      evalExpr (boothStep' m_pos m_neg p pr) =
      if weq (evalExpr pr) WO~0~1 then (wrshifta (evalExpr p) 1) ^+ (wrshifta m_pos 1)
      else if weq (evalExpr pr) WO~1~0 then (wrshifta (evalExpr p) 1) ^+ (wrshifta m_neg 1)
           else wrshifta (evalExpr p) 1.
  Proof.
    intros; simpl.
    destruct (weq _ _); try reflexivity.
    destruct (weq _ _); reflexivity.
  Qed.

  Definition boothStepEvalM (m_pos m_neg: word MultBits)
             (p: Expr type (SyntaxKind (Bit (MultBits - 2 + 2)))) :=
    wrshifta
      (if weq (split1 2 (MultBits - 2) (evalExpr p)) WO~0~1
       then m_pos
       else
         if weq (split1 2 (MultBits - 2) (evalExpr p)) WO~1~0
         then m_neg
         else $0) 1.

  Lemma boothStep_eval:
    forall m_pos m_neg p,
      evalExpr (boothStep m_pos m_neg p) =
      wrshifta (evalExpr p) 1 ^+ boothStepEvalM m_pos m_neg p.
  Proof.
    intros; unfold boothStep, boothStepEvalM.
    rewrite boothStep'_eval.
    repeat destruct (weq _ _); try reflexivity.
    rewrite wrshifta_wzero, wplus_comm, wplus_unit; reflexivity.
  Qed.

  Opaque boothStep.

  Definition booth4Step' {ty}
             (m_pos m_neg: fullType ty (SyntaxKind (Bit MultBits)))
             (p: Expr ty (SyntaxKind (Bit MultBits)))
             (pr: Expr ty (SyntaxKind (Bit 3))) :=
    let pSra := (p ~>> $$(WO~1~0))%kami_expr in
    (IF (pr == $$(WO~0~0~1)) then pSra + (#m_pos ~>> $$(WO~1~0))
     else IF (pr == $$(WO~0~1~0)) then pSra + (#m_pos ~>> $$(WO~1~0))
     else IF (pr == $$(WO~0~1~1)) then pSra + ((#m_pos << $$(WO~1)) ~>> $$(WO~1~0))
     else IF (pr == $$(WO~1~0~0)) then pSra + ((#m_neg << $$(WO~1)) ~>> $$(WO~1~0))
     else IF (pr == $$(WO~1~0~1)) then pSra + (#m_neg ~>> $$(WO~1~0))
     else IF (pr == $$(WO~1~1~0)) then pSra + (#m_neg ~>> $$(WO~1~0))
     else pSra)%kami_expr.

  (* NOTE: must use shirt-right-arithmetic to preserve the sign bit. *)
  Definition booth4Step {ty}
             (m_pos m_neg: fullType ty (SyntaxKind (Bit MultBits)))
             (p: Expr ty (SyntaxKind (Bit ((MultBits - 3) + 3))))
    : Expr ty (SyntaxKind (Bit MultBits)) :=
    (booth4Step' m_pos m_neg p (UniBit (Trunc 3 _) p))%kami_expr.

  Lemma booth4Step'_eval:
    forall m_pos m_neg p pr,
      evalExpr (booth4Step' m_pos m_neg p pr) =
      if weq (evalExpr pr) WO~0~0~1 then wrshifta (evalExpr p) 2 ^+ wrshifta m_pos 2
      else if weq (evalExpr pr) WO~0~1~0 then wrshifta (evalExpr p) 2 ^+ wrshifta m_pos 2
      else if weq (evalExpr pr) WO~0~1~1 then wrshifta (evalExpr p) 2 ^+ wrshifta (wlshift m_pos 1) 2
      else if weq (evalExpr pr) WO~1~0~0 then wrshifta (evalExpr p) 2 ^+ wrshifta (wlshift m_neg 1) 2
      else if weq (evalExpr pr) WO~1~0~1 then wrshifta (evalExpr p) 2 ^+ wrshifta m_neg 2
      else if weq (evalExpr pr) WO~1~1~0 then wrshifta (evalExpr p) 2 ^+ wrshifta m_neg 2
      else wrshifta (evalExpr p) 2.
  Proof.
    intros; simpl.
    repeat destruct (weq _ _); reflexivity.
  Qed.

  Definition booth4StepEvalM (m_pos m_neg: word MultBits)
             (p: Expr type (SyntaxKind (Bit (MultBits - 3 + 3)))) :=
    wrshifta
      (if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~0~0~1
       then m_pos
       else
         if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~0~1~0
         then m_pos
         else
           if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~0~1~1
           then (wlshift m_pos 1)
           else
             if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~1~0~0
             then (wlshift m_neg 1)
             else
               if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~1~0~1
               then m_neg
               else
                 if weq (split1 3 (MultBits - 3) (evalExpr p)) WO~1~1~0
                 then m_neg
                 else $0) 2.

  Lemma booth4Step_eval:
    forall m_pos m_neg p,
      evalExpr (booth4Step m_pos m_neg p) =
      wrshifta (evalExpr p) 2 ^+ (booth4StepEvalM m_pos m_neg p).
  Proof.
    intros; unfold booth4Step, booth4StepEvalM.
    rewrite booth4Step'_eval.

    repeat destruct (weq _ _); try reflexivity.
    rewrite wrshifta_wzero, wplus_comm, wplus_unit; reflexivity.
  Qed.

  Opaque booth4Step.

  Fixpoint booth4Steps (cnt: nat)
           {ty} (m_pos m_neg: fullType ty (SyntaxKind (Bit MultBits)))
           (p: fullType ty (SyntaxKind (Bit ((MultBits - 3) + 3))))
           (cont: fullType ty (SyntaxKind (Bit ((MultBits - 3) + 3))) ->
                  ActionT ty Void)
    : ActionT ty Void :=
    match cnt with
    | O => (cont p)%kami_action
    | S n => (LET np <- booth4Step m_pos m_neg #p;
              booth4Steps n m_pos m_neg np cont)%kami_action
    end.

  Definition multPull := MethodSig "multPull"(): Struct MultInStr.
  Definition multPush := MethodSig "multPush"(Struct MultOutStr): Void.

  Definition boothMultiplierImpl :=
    MODULE {
      Register "m_pos" : Bit MultBits <- Default
      with Register "m_neg" : Bit MultBits <- Default
      with Register "p" : Bit MultBits <- Default
      with Register "m" : Bit MultNumBitsExt <- Default
      with Register "r" : Bit MultNumBitsExt <- Default
      with Register "cnt" : Bit (S MultLogNumPhases) <- Default

      with Rule "boothMultRegister" :=
        Call src <- multPull();

        LET m : Bit (pred MultNumBitsExt + 1) <- #src!MultInStr@."multiplicand";

        (* Make sure msb(m) = 0 *)
        Assert (UniBit (TruncLsb _ 1) #m == $0);

        LET m_neg <- UniBit (Neg _) #m;

        LET m_pos : Bit MultBits <-
          BinBit (Concat _ (S MultNumBitsExt))
                 (UniBit (SignExtendTrunc _ (S MultNumBitsExt)) #m) $0;
        LET m_neg : Bit MultBits <-
          BinBit (Concat _ (S MultNumBitsExt))
                 (UniBit (SignExtendTrunc _ (S MultNumBitsExt)) #m_neg) $0;

        Write "m_pos" <- #m_pos;
        Write "m_neg" <- #m_neg;
        Write "m" <- #m;

        LET r <- #src!MultInStr@."multiplier";
        Write "r" <- #r;

        LET p : Bit MultBits <-
          BinBit (Concat (S MultNumBitsExt) _) $0 (BinBit (Concat _ 1) #r $0);

        (* Handle one bit in advance, in order to deal with other 64 bits
         * consistently in a rule [boothStep].
         *)
        LET np : Bit MultBits <- boothStep m_pos m_neg #p;
        Write "p" <- #np;

        Write "cnt" : Bit (S MultLogNumPhases) <- $(MultNumPhases);
        Retv

      with Rule "boothMultGetResult" :=
        Read cnt : Bit (S MultLogNumPhases) <- "cnt";
        Assert (#cnt == $0);

        Read p : Bit MultBits <- "p";
        LET highlowe : Bit (2 * MultNumBitsExt) <-
          UniBit (ConstExtract 1 (2 * MultNumBitsExt) 1) #p;
        LET highlow : Bit (2 * MultNumBits) <-
          UniBit (SignExtendTrunc _ _) #highlowe;

        LET high : Bit MultNumBits <- UniBit (TruncLsb _ _) #highlow;
        LET low : Bit MultNumBits <- UniBit (Trunc _ _) #highlow;

        Call multPush(STRUCT { "high" ::= #high; "low" ::= #low });

        Retv

      with Rule "boothStep" :=
        Read cnt : Bit (S MultLogNumPhases) <- "cnt";
        Assert (#cnt != $0);

        Read m_pos : Bit MultBits <- "m_pos";
        Read m_neg : Bit MultBits <- "m_neg";
        Read p : Bit MultBits <- "p";

        Write "cnt" <- #cnt - $1;

        booth4Steps
          MultNumStepsPerPhase m_pos m_neg p
          (fun np => Write "p" <- #np; Retv)
    }.

  Definition multiplierSpec :=
    MODULE {
      Register "m" : Bit MultNumBitsExt <- Default
      with Register "r" : Bit MultNumBitsExt <- Default

      with Rule "multRegister" :=
        Call src <- multPull();
        LET m : Bit MultNumBitsExt <- #src!MultInStr@."multiplicand";
        LET r : Bit MultNumBitsExt <- #src!MultInStr@."multiplier";

        Write "m" <- #m;
        Write "r" <- #r;
        Retv

      with Rule "multGetResult" :=
        Read m : Bit MultNumBitsExt <- "m";
        LET m_ext : Bit (2 * MultNumBitsExt) <- UniBit (SignExtendTrunc _ _) #m;
        Read r : Bit MultNumBitsExt <- "r";
        LET r_ext : Bit (2 * MultNumBitsExt) <- UniBit (SignExtendTrunc _ _) #r;

        LET p : Bit (2 * MultNumBitsExt) <- #m_ext *s #r_ext;
        LET highlow : Bit (2 * MultNumBits) <- UniBit (SignExtendTrunc _ _) #p;

        LET high : Bit MultNumBits <- UniBit (TruncLsb _ _) #highlow;
        LET low : Bit MultNumBits <- UniBit (Trunc _ _) #highlow;

        Call multPush(STRUCT { "high" ::= #high; "low" ::= #low });

        Retv
    }.

  (*! Correctness of the multiplier *)

  Section BoothEncoding.

    Inductive Booth := BZero | BPlus | BMinus.

    Definition boothToZ (b: Booth): Z :=
      match b with
      | BZero => 0
      | BPlus => 1
      | BMinus => -1
      end.

    Definition bbToZ (bb: Booth * Booth): Z :=
      match bb with
      | (BZero, b) => boothToZ b
      | (BPlus, b) => boothToZ b + 2
      | (BMinus, b) => boothToZ b - 2
      end.

    Inductive bword: nat -> Set :=
    | BWO: bword 0
    | BWS: Booth -> forall n, bword n -> bword (S n).

    Fixpoint bwordToZ sz (bw: bword sz): Z :=
      match bw with
      | BWO => 0
      | BWS BZero bw' => bwordToZ bw' * 2
      | BWS BPlus bw' => (bwordToZ bw' * 2) + 1
      | BWS BMinus bw' => (bwordToZ bw' * 2) - 1
      end.

    Declare Scope bword_scope.
    Notation "w ~ 0" := (BWS BZero w) (at level 7, left associativity,
                                       format "w '~' '0'"): bword_scope.
    Notation "w ~ 'P'" := (BWS BPlus w) (at level 7, left associativity,
                                         format "w '~' 'P'"): bword_scope.
    Notation "w ~ 'N'" := (BWS BMinus w) (at level 7, left associativity,
                                          format "w '~' 'N'"): bword_scope.
    Delimit Scope bword_scope with bword.

    Definition encodeB2 (mst lst: bool) :=
      match mst, lst with
      | false, true => BPlus
      | true, false => BMinus
      | _, _ => BZero
      end.

    Definition wencodeB2 (w: word 2): Booth.
    Proof.
      dependent destruction w.
      dependent destruction w.
      exact (encodeB2 b0 b).
    Defined.

    Fixpoint wordToB2' sz (w: word sz) (p: bool): bword sz :=
      match w with
      | WO => BWO
      | WS b w' => BWS (encodeB2 b p) (wordToB2' w' b)
      end.

    Lemma wordToB2'_rtrunc1_wlsb:
      forall sz (w: word (S sz)) p,
        wordToB2' w p = BWS (encodeB2 (wlsb w) p) (wordToB2' (rtrunc1 w) (wlsb w)).
    Proof.
      intros; dependent destruction w; simpl; reflexivity.
    Qed.

    Definition wordToB2 sz (w: word (S sz)): bword sz :=
      match w with
      | WO => tt
      | WS b w' => wordToB2' w' b
      end.

    Lemma wordToB2_one:
      forall (w: word 1), bwordToZ (wordToB2 w) = 0%Z.
    Proof.
      dependent destruction w.
      dependent destruction w.
      simpl; reflexivity.
    Qed.

    Lemma wordToB2_bwordToZ':
      forall sz (w: word (S sz)) b,
        bwordToZ (wordToB2 (WS b w)) = (wordToZ w + (if b then 1 else 0))%Z.
    Proof.
      dependent induction w; simpl; intros.
      dependent destruction w.
      - destruct b, b0; cbn; reflexivity.
      - specialize (IHw _ _ eq_refl JMeq_refl).
        unfold wordToB2 in IHw; rewrite IHw; clear IHw.
        destruct b, b1, b0; cbn;
          repeat (rewrite wordToZ_WS_0 || rewrite wordToZ_WS_1); lia.
    Qed.

    Lemma wordToB2_bwordToZ:
      forall sz (w: word sz),
        bwordToZ (wordToB2 w~0) = wordToZ w.
    Proof.
      dependent destruction w; [reflexivity|].
      rewrite wordToB2_bwordToZ'; lia.
    Qed.

    Lemma wordToB2_bwordToZ_step:
      forall sz (w: word (S (S sz))),
        bwordToZ (wordToB2 w) =
        (2 * bwordToZ (wordToB2 (rtrunc1 w)) +
         boothToZ (wencodeB2 (split1 2 _ w)))%Z.
    Proof.
      do 2 dependent destruction w; cbn.
      remember (bwordToZ (wordToB2' w b0)) as ww; clear Heqww.
      destruct ww.
      - destruct b, b0; cbn; reflexivity.
      - rewrite Pos2Z.inj_xO with (p:= p).
        rewrite Z.mul_comm; remember (2 * Z.pos p)%Z as tp; clear Heqtp.
        destruct b, b0; cbn; lia.
      - rewrite Pos2Z.neg_xO with (p:= p).
        rewrite Z.mul_comm; remember (2 * Z.neg p)%Z as tp; clear Heqtp.
        destruct b, b0; cbn; lia.
    Qed.

    Definition encodeB4 (b1 b2 b3: bool) :=
      match b1, b2, b3 with
      | false, false, true
      | false, true, false => (BZero, BPlus)
      | false, true, true => (BPlus, BZero)
      | true, false, false => (BMinus, BZero)
      | true, false, true
      | true, true, false => (BZero, BMinus)
      | _, _, _ => (BZero, BZero)
      end.

    Definition wencodeB4 (w: word 3): Booth * Booth.
    Proof.
      dependent destruction w.
      dependent destruction w.
      dependent destruction w.
      exact (encodeB4 b1 b0 b).
    Defined.

    Fixpoint wordToB4' sz (w: word sz) (p1 p2: bool): bword (S sz).
    Proof.
      dependent destruction w.
      - exact (BWS (encodeB2 p1 p2) BWO).
      - dependent destruction w.
        + exact (BWS (snd (encodeB4 b p1 p2)) (BWS (fst (encodeB4 b p1 p2)) BWO)).
        + refine (BWS (snd (encodeB4 b p1 p2)) (BWS (fst (encodeB4 b p1 p2)) _)).
          exact (wordToB4' _ w b0 b).
    Defined.

    Definition wordToB4 sz (w: word (S sz)): bword sz.
    Proof.
      dependent destruction w.
      dependent destruction w.
      - exact BWO.
      - exact (wordToB4' w b0 b).
    Defined.

    Lemma wordToB2_wordToB4:
      forall sz (w: word (S sz)),
        bwordToZ (wordToB2 w) = bwordToZ (wordToB4 w).
    Proof.
      dependent destruction w.
      move b at bottom.
      dependent induction w; [reflexivity|].
      cbn; cbn in IHw; rewrite IHw; clear IHw.
      move b at bottom.
      dependent induction w.
      - destruct b, b0; cbn; reflexivity.
      - rewrite <-IHw; clear IHw.
        dependent destruction w.
        + destruct b, b0, b1; cbn; reflexivity.
        + cbn; remember (bwordToZ (wordToB4' w b0 b)) as ww; clear Heqww.
          destruct b, b0, b1, b2; cbn; lia.
    Qed.

    Lemma wordToB4_bwordToZ_step:
      forall sz (w: word (S (S (S sz)))),
        bwordToZ (wordToB4 w) =
        (4 * bwordToZ (wordToB4 (rtrunc2 w)) +
         bbToZ (wencodeB4 (split1 3 _ w)))%Z.
    Proof.
      do 3 dependent destruction w; cbn.
      dependent destruction w.
      - destruct b, b0, b1; cbn; reflexivity.
      - cbn; remember (bwordToZ (wordToB4' w b2 b1)) as ww; clear Heqww.
        destruct ww.
        + destruct b, b0, b1; cbn; reflexivity.
        + rewrite Pos2Z.inj_xO with (p:= (p~0)%positive).
          rewrite Pos2Z.inj_xO with (p:= p).
          rewrite Z.mul_comm with (n:= Z.pos p); remember (2 * Z.pos p)%Z as tp; clear Heqtp.
          Opaque Z.mul.
          destruct b, b0, b1; cbn; lia.
          Transparent Z.mul.
        + rewrite Pos2Z.neg_xO with (p:= (p~0)%positive).
          rewrite Pos2Z.neg_xO with (p:= p).
          rewrite Z.mul_comm with (n:= Z.neg p); remember (2 * Z.neg p)%Z as tp; clear Heqtp.
          Opaque Z.mul.
          destruct b, b0, b1; cbn; lia.
          Transparent Z.mul.
    Qed.

  End BoothEncoding.

  Inductive BoothStepInv {sz} (m p: word sz)
    : forall sl, word sl -> forall su, word su -> Prop :=
  | BSInv: forall sl su (wl: word (S sl)) (wu: word su) u,
      (sl = 0 -> exists tsu (twu: word tsu), existT word _ wu = existT word _ (sext twu 1)) ->
      wordToZ wu = (wordToZ m * u)%Z ->
      (u + bwordToZ (wordToB2 wl) * Z.of_nat (pow2 (su - sz - 1)))%Z = wordToZ p ->
      BoothStepInv m p wl wu.

  Lemma boothStepInv_inv:
    forall {sz} (m p: word sz) sl su (wl: word (S sl)) (wu: word su),
      BoothStepInv m p wl wu ->
      (sl = 0 -> exists tsu (twu: word tsu), existT word _ wu = existT word _ (sext twu 1)) /\
      exists u,
        wordToZ wu = (wordToZ m * u)%Z /\
        (u + bwordToZ (wordToB2 wl) * Z.of_nat (pow2 (su - sz - 1)))%Z = wordToZ p.
  Proof.
    intros.
    inv H; destruct_existT.
    split; auto.
    eexists; repeat (split; try eassumption).
  Qed.

  Lemma natToWord_ZToWord_zero:
    forall sz, natToWord sz 0 = ZToWord sz 0%Z.
  Proof.
    intros; simpl.
    induction sz; simpl; auto.
    rewrite IHsz; reflexivity.
  Qed.

  Lemma wmsb_wzero'_false:
    forall sz, wmsb (wzero' sz) false = false.
  Proof.
    induction sz; simpl; intros; auto.
  Qed.

  Lemma boothStepInv_init:
    forall sz m p,
      BoothStepInv m (p: word sz)
                   (combine (natToWord 1 0) p)
                   (natToWord (S sz) 0).
  Proof.
    intros; econstructor; try reflexivity.
    - intros; subst.
      eexists; exists WO.
      reflexivity.
    - instantiate (1:= 0%Z).
      rewrite <-Zmult_0_r_reverse.
      rewrite natToWord_ZToWord_zero.
      rewrite wordToZ_wzero'.
      reflexivity.
    - rewrite Z.add_0_l.
      replace (S sz - sz - 1) with 0 by lia.
      simpl; rewrite <-wordToB2_bwordToZ.
      rewrite Z.mul_1_r.
      reflexivity.
  Qed.

  Lemma boothStepInv_finish:
    forall {sz} (m p: word sz) (wl: word 1) su (wu: word su),
      BoothStepInv m p wl wu ->
      exists tsu (twu: word tsu),
        existT word _ wu = existT word _ (sext twu 1) /\
        wordToZ wu = (wordToZ m * wordToZ p)%Z.
  Proof.
    intros.
    apply boothStepInv_inv in H; dest.
    specialize (H eq_refl); destruct H as [tsu [twu ?]].
    rewrite wordToB2_one in H1.
    rewrite Z.add_0_r in H1; subst.
    repeat eexists; eassumption.
  Qed.

  Definition booth2AddM (m: word MultNumBitsExt) (wl: word 2) {sus}
    : word (S sus + MultNumBitsExt).
  Proof.
    assert (Hsu: sus + MultNumBitsExt + 1 = S sus + MultNumBitsExt)
      by (abstract lia).
    refine (if weq wl WO~0~1 then _
            else if weq wl WO~1~0 then _
                 else _).
    - exact (eq_rect _ word (sext (extz m sus) 1) _ Hsu).
    - exact (eq_rect _ word (sext (extz (wneg m) sus) 1) _ Hsu).
    - exact $0.
  Defined.

  Definition booth4AddM (m: word MultNumBitsExt) (wl: word 3) {sus}
    : word (S sus + MultNumBitsExt).
  Proof.
    assert (Hsu: sus + (MultNumBitsExt + 1) = S sus + MultNumBitsExt)
      by (abstract lia).
    refine (if weq wl WO~0~0~1 then _
            else if weq wl WO~0~1~0 then _
                 else if weq wl WO~0~1~1 then _
                      else if weq wl WO~1~0~0 then _
                           else if weq wl WO~1~0~1 then _
                                else if weq wl WO~1~1~0 then _
                                     else _).
    - exact (eq_rect _ word (extz (sext m 1) sus) _ Hsu).
    - exact (eq_rect _ word (extz (sext m 1) sus) _ Hsu).
    - exact (extz m (S sus)).
    - exact (extz (wneg m) (S sus)).
    - exact (eq_rect _ word (extz (sext (wneg m) 1) sus) _ Hsu).
    - exact (eq_rect _ word (extz (sext (wneg m) 1) sus) _ Hsu).
    - exact $0.
  Defined.

  Definition booth2AddU (wl: word 2) (sus: nat) :=
    (if weq wl WO~0~1 then (Z.of_nat (pow2 sus))
     else if weq wl WO~1~0 then -(Z.of_nat (pow2 sus))
          else 0)%Z.

  Definition booth4AddU (wl: word 3) (sus: nat) :=
    (if weq wl WO~0~0~1 then (Z.of_nat (pow2 sus))
     else if weq wl WO~0~1~0 then (Z.of_nat (pow2 sus))
          else if weq wl WO~0~1~1 then (Z.of_nat (pow2 (S sus)))
               else if weq wl WO~1~0~0 then -(Z.of_nat (pow2 (S sus)))
                    else if weq wl WO~1~0~1 then -(Z.of_nat (pow2 sus))
                         else if weq wl WO~1~1~0 then -(Z.of_nat (pow2 sus))
                              else 0)%Z.

  Lemma wencodeB2_zero:
    forall (wl: word 2),
      wl <> WO~0~1 -> wl <> WO~1~0 ->
      wencodeB2 wl = BZero.
  Proof.
    intros.
    dependent destruction wl.
    dependent destruction wl.
    dependent destruction wl.
    destruct b, b0; intuition idtac.
  Qed.

  Lemma wencodeB4_zero:
    forall (wl: word 3),
      wl <> WO~0~0~1 -> wl <> WO~0~1~0 -> wl <> WO~0~1~1 ->
      wl <> WO~1~0~0 -> wl <> WO~1~0~1 -> wl <> WO~1~1~0 ->
      wencodeB4 wl = (BZero, BZero).
  Proof.
    intros.
    dependent destruction wl.
    dependent destruction wl.
    dependent destruction wl.
    dependent destruction wl.
    destruct b, b0, b1; intuition idtac.
  Qed.

  Ltac wordToZ_red :=
    repeat (first [rewrite extz_pow2_wordToZ
                  |rewrite sext_wordToZ
                  |rewrite wordToZ_eq_rect]).

  Lemma boothStepEvalM_booth2AddM:
    forall (m: word MultNumBitsExt) we sl sus,
      MultBits - 2 + 2 = S (S sl) + (S sus + MultNumBitsExt) ->
      existT word (1 + S MultNumBitsExt + MultNumBitsExt)
             (boothStepEvalM
                (extz (sext m 1) (S MultNumBitsExt))
                (extz (sext (^~ m) 1) (S MultNumBitsExt)) we) =
      existT word (S sl + (S sus + MultNumBitsExt + 1))
             (extz (sext (booth2AddM m (split1 2 (MultBits - 2) (evalExpr we))) 1)
                   (S sl)).
  Proof.
    unfold boothStepEvalM, booth2AddM; intros.
    repeat destruct (weq _ _).

    - change (1 + S MultNumBitsExt + MultNumBitsExt)
        with (1 + MultNumBitsExt + S MultNumBitsExt).
      rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace MultNumBitsExt with (sus + S sl) at 2 by (cbn; cbn in H; lia).
      reflexivity.
    - change (1 + S MultNumBitsExt + MultNumBitsExt)
        with (1 + MultNumBitsExt + S MultNumBitsExt).
      rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace MultNumBitsExt with (sus + S sl) at 3 by (cbn; cbn in H; lia).
      reflexivity.

    - rewrite wrshifta_wzero, sext_wzero, extz_zero.
      replace (S sl + (S sus + MultNumBitsExt + 1)) with MultBits by lia.
      reflexivity.
  Qed.

  Lemma booth4StepEvalM_booth4AddM:
    forall (m: word MultNumBitsExt) we sl sus,
      MultBits - 3 + 3 = S (S (S sl)) + (S sus + MultNumBitsExt) ->
      existT word (2 + (MultNumBitsExt - 1) + S MultNumBitsExt)
             (booth4StepEvalM (extz (sext m 1) (S MultNumBitsExt))
                              (extz (sext (^~ m) 1) (S MultNumBitsExt)) we) =
      existT word (S sl + (S sus + MultNumBitsExt + 2))
             (extz (sext (booth4AddM m (split1 3 (MultBits - 3) (evalExpr we))) 2) (S sl)).
  Proof.
    unfold booth4StepEvalM, booth4AddM; intros.
    repeat destruct (weq _ _).

    - rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace (MultNumBitsExt - 1) with (sus + S sl) by (cbn; cbn in H; lia).
      reflexivity.
    - rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace (MultNumBitsExt - 1) with (sus + S sl) by (cbn; cbn in H; lia).
      reflexivity.

    - erewrite existT_wrshifta
        by (erewrite existT_wlshift
             by (change MultBits with ((S MultNumBitsExt) + (MultNumBitsExt + 1));
                 apply extz_sext);
            apply wlshift_sext_extz).
      erewrite existT_wrshifta by apply extz_extz.
      change (1 + S MultNumBitsExt) with (2 + MultNumBitsExt).
      rewrite wrshifta_extz_sext.
      rewrite extz_sext.
      apply existT_sext.
      rewrite extz_extz.
      replace (S sl + S sus) with MultNumBitsExt by (cbn; cbn in H; lia).
      reflexivity.
    - erewrite existT_wrshifta
        by (erewrite existT_wlshift
             by (change MultBits with ((S MultNumBitsExt) + (MultNumBitsExt + 1));
                 apply extz_sext);
            apply wlshift_sext_extz).
      erewrite existT_wrshifta by apply extz_extz.
      change (1 + S MultNumBitsExt) with (2 + MultNumBitsExt).
      rewrite wrshifta_extz_sext.
      rewrite extz_sext.
      apply existT_sext.
      rewrite extz_extz.
      replace (S sl + S sus) with MultNumBitsExt by (cbn; cbn in H; lia).
      reflexivity.

    - rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace (MultNumBitsExt - 1) with (sus + S sl) by (cbn; cbn in H; lia).
      reflexivity.
    - rewrite wrshifta_extz_sext.
      apply wordToZ_existT; [cbn; cbn in H; lia|].
      wordToZ_red.
      rewrite <-Z.mul_assoc, <-Nat2Z.inj_mul.
      rewrite <-pow2_add_mul.
      replace (MultNumBitsExt - 1) with (sus + S sl) by (cbn; cbn in H; lia).
      reflexivity.

    - rewrite wrshifta_wzero, sext_wzero, extz_zero.
      replace (S sl + (S sus + MultNumBitsExt + 2)) with MultBits by lia.
      reflexivity.
  Qed.

  Lemma booth2AddM_booth2AddU:
    forall sus (m: word MultNumBitsExt) (Hm: m <> wpow2 MultNumBits)
           wu w,
      wordToZ (sext wu 1 ^+ sext (booth2AddM (sus:= sus) m (split1 2 (MultBits - 2) w)) 1) =
      (wordToZ wu + wordToZ m * booth2AddU (split1 2 (MultBits - 2) w) sus)%Z.
  Proof.
    unfold booth2AddM, booth2AddU; intros.
    repeat destruct (weq _ _).
    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite sext_wordToZ.
      rewrite extz_pow2_wordToZ.
      reflexivity.
    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite sext_wordToZ.
      rewrite extz_pow2_wordToZ.
      change MultNumBitsExt with (S MultNumBits).
      rewrite wneg_wordToZ by assumption.
      ring.
    - rewrite sext_wzero, wplus_wzero_1.
      rewrite Z.mul_0_r.
      rewrite sext_wordToZ.
      lia.
  Qed.

  Lemma booth4AddM_booth4AddU:
    forall sus (m: word MultNumBitsExt) (Hm: m <> wpow2 MultNumBits)
           wu w,
      wordToZ (sext wu 2 ^+ sext (booth4AddM (sus:= sus) m (split1 3 (MultBits - 3) w)) 2) =
      (wordToZ wu + wordToZ m * booth4AddU (split1 3 (MultBits - 3) w) sus)%Z.
  Proof.
    unfold booth4AddM, booth4AddU; intros.
    repeat destruct (weq _ _).

    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite extz_pow2_wordToZ.
      rewrite sext_wordToZ.
      reflexivity.
    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite extz_pow2_wordToZ.
      rewrite sext_wordToZ.
      reflexivity.

    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite extz_pow2_wordToZ.
      reflexivity.
    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite extz_pow2_wordToZ.
      change MultNumBitsExt with (S MultNumBits).
      rewrite wneg_wordToZ by assumption.
      ring.

    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite extz_pow2_wordToZ.
      rewrite sext_wordToZ.
      change MultNumBitsExt with (S MultNumBits).
      rewrite wneg_wordToZ by assumption.
      ring.
    - rewrite sext_wplus_wordToZ_distr by discriminate.
      do 2 rewrite sext_wordToZ.
      rewrite wordToZ_eq_rect.
      rewrite extz_pow2_wordToZ.
      rewrite sext_wordToZ.
      change MultNumBitsExt with (S MultNumBits).
      rewrite wneg_wordToZ by assumption.
      ring.
    - rewrite sext_wzero.
      rewrite wplus_comm, wplus_unit.
      rewrite sext_wordToZ.
      rewrite Z.mul_0_r.
      ring.
  Qed.

  Lemma booth2AddU_boothToZ:
    forall wl n,
      booth2AddU wl n =
      (boothToZ (wencodeB2 wl) * Z.of_nat (pow2 n))%Z.
  Proof.
    unfold booth2AddU, boothToZ; intros.
    repeat destruct (weq _ _); subst.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - rewrite wencodeB2_zero by assumption.
      reflexivity.
  Qed.

  Lemma booth4AddU_bbToZ:
    forall wl n,
      booth4AddU wl n =
      (bbToZ (wencodeB4 wl) * Z.of_nat (pow2 n))%Z.
  Proof.
    unfold booth4AddU, bbToZ; intros.
    repeat destruct (weq _ _); subst.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - rewrite pow2_S_z; simpl; reflexivity.
    - rewrite pow2_S_z; simpl.
      destruct (Z.of_nat (pow2 n)); reflexivity.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - simpl; destruct (Z.of_nat (pow2 n)); reflexivity.
    - rewrite wencodeB4_zero by assumption.
      reflexivity.
  Qed.

  Lemma wordToZ_sext_wplus_distr:
    forall (sz: nat) (w1 w2: word (S sz)) n,
      (- Z.of_nat (pow2 sz) <= wordToZ w1 + wordToZ w2 < Z.of_nat (pow2 sz))%Z ->
      wordToZ (sext (w1 ^+ w2) n) = wordToZ (sext w1 n ^+ sext w2 n).
  Proof.
    intros.
    rewrite sext_wordToZ.
    rewrite <-wordToZ_wplus_bound by assumption.
    change (S sz + n) with (S (sz + n)).
    rewrite <-wordToZ_wplus_bound; change (S (sz + n)) with (S sz + n).
    - do 2 rewrite sext_wordToZ.
      reflexivity.
    - do 2 rewrite sext_wordToZ.
      destruct H; split.
      + etransitivity; [|eassumption].
        rewrite <-Z.opp_le_mono.
        apply Nat2Z.inj_le.
        rewrite pow2_add_mul.
        pose proof (zero_lt_pow2 n).
        replace (pow2 sz) with (pow2 sz * 1)%nat at 1 by lia.
        apply mult_le_compat_l; lia.
      + eapply Z.lt_le_trans; [eassumption|].
        apply Nat2Z.inj_le.
        rewrite pow2_add_mul.
        pose proof (zero_lt_pow2 n).
        replace (pow2 sz) with (pow2 sz * 1)%nat at 1 by lia.
        apply mult_le_compat_l; lia.
  Qed.

  Lemma boothStepInv_booth4Step:
    forall (m: word MultNumBitsExt) (Hm: m <> wpow2 MultNumBits)
           mp mn p we nwe,
      mp = extz (sext m 1) (S MultNumBitsExt) ->
      mn = extz (sext (wneg m) 1) (S MultNumBitsExt) ->
      booth4Step mp mn we = nwe ->
      forall sl su (wl: word (S (S (S sl)))) (wu: word su) sus,
        (S sus) + MultNumBitsExt = su ->
        existT word _ (evalExpr we) = existT word _ (combine wl wu) ->
        BoothStepInv m p wl wu ->
        exists (nwl: word (S sl)) (nwu: word (su + 2)),
          existT word _ (evalExpr nwe) = existT word _ (combine nwl nwu) /\
          BoothStepInv m p nwl nwu.
  Proof.
    intros; subst.
    apply boothStepInv_inv in H4; destruct H4 as [_ H4].
    rewrite wordToB2_wordToB4 in H4.
    destruct H4 as [u ?]; dest.

    exists (rtrunc2 wl).
    exists (sext wu 2 ^+ sext (booth4AddM m (split1 3 (MultBits - 3) (evalExpr we))) 2).
    split.

    - rewrite booth4Step_eval.
      rewrite combine_wplus_1.
      apply existT_wplus.
      + apply combine_wrshifta_rtrunc2_sext; assumption.
      + apply booth4StepEvalM_booth4AddM.
        apply eq_sigT_fst in H3; assumption.

    - pose proof (sext_wplus_exist wu (booth4AddM m (split1 3 (MultBits - 3) (evalExpr we))) 1).
      destruct H1 as [twu ?].
      eapply @BSInv
        with (u:= (u + booth4AddU (split1 3 (MultBits - 3) (evalExpr we)) sus)%Z).
      + intros; rewrite H1; do 2 eexists; reflexivity.
      + rewrite Z.mul_add_distr_l, <-H.
        apply booth4AddM_booth4AddU; assumption.
      + rewrite wordToB2_wordToB4.
        rewrite <-H0, <-Z.add_assoc.
        replace (S sus + MultNumBitsExt + 2 - MultNumBitsExt - 1)
          with (S (S sus)) by lia.
        apply Z.add_cancel_l.
        replace (S sus + MultNumBitsExt - MultNumBitsExt - 1) with sus by lia.
        rewrite wordToB4_bwordToZ_step.
        rewrite Z.mul_add_distr_r.
        rewrite Z.add_comm.
        f_equal.
        * replace (Z.of_nat (pow2 (S (S sus)))) with (4 * Z.of_nat (pow2 sus))%Z
            by (do 2 rewrite pow2_S_z; ring).
          rewrite Z.mul_assoc; f_equal; lia.
        * replace (split1 3 (MultBits - 3) (evalExpr we)) with (split1 3 sl wl)
            by (apply eq_sym; eauto using split1_combine_existT).
          apply booth4AddU_bbToZ.
  Qed.

  Lemma boothStepInv_boothStep:
    forall (m: word MultNumBitsExt) (Hm: m <> wpow2 MultNumBits)
           mp mn p we nwe,
      mp = extz (sext m 1) (S MultNumBitsExt) ->
      mn = extz (sext (wneg m) 1) (S MultNumBitsExt) ->
      boothStep mp mn we = nwe ->
      forall sl su (wl: word (S (S sl))) (wu: word su) sus,
        sl <> 0 ->
        (S sus) + MultNumBitsExt = su ->
        existT word _ (evalExpr we) = existT word _ (combine wl wu) ->
        BoothStepInv m p wl wu ->
        exists (nwl: word (S sl)) (nwu: word (su + 1)),
          existT word _ (evalExpr nwe) = existT word _ (combine nwl nwu) /\
          BoothStepInv m p nwl nwu.
  Proof.
    intros; subst.
    apply boothStepInv_inv in H5; destruct H5 as [_ H5].
    destruct H5 as [u ?]; dest.

    exists (rtrunc1 wl).
    exists (sext wu 1 ^+ sext (booth2AddM m (split1 2 (MultBits - 2) (evalExpr we))) 1).
    split.

    - rewrite boothStep_eval.
      rewrite combine_wplus_1.
      apply existT_wplus.
      + apply combine_wrshifta_rtrunc1_sext; assumption.
      + apply boothStepEvalM_booth2AddM.
        apply eq_sigT_fst in H4; assumption.

    - eapply @BSInv
        with (u:= (u + booth2AddU (split1 2 (MultBits - 2) (evalExpr we)) sus)%Z).
      + intros; subst.
        elim H2; reflexivity.
      + rewrite Z.mul_add_distr_l, <-H.
        apply booth2AddM_booth2AddU; assumption.
      + rewrite <-H0, <-Z.add_assoc.
        replace (S sus + MultNumBitsExt + 1 - MultNumBitsExt - 1) with (S sus) by lia.
        apply Z.add_cancel_l.
        replace (S sus + MultNumBitsExt - MultNumBitsExt - 1) with sus by lia.
        rewrite wordToB2_bwordToZ_step.
        rewrite Z.mul_add_distr_r.
        rewrite Z.add_comm.
        f_equal.
        * replace (Z.of_nat (pow2 (S sus))) with (2 * Z.of_nat (pow2 sus))%Z
            by (rewrite pow2_S_z; ring).
          rewrite Z.mul_assoc; f_equal; lia.
        * replace (split1 2 (MultBits - 2) (evalExpr we)) with (split1 2 sl wl)
            by (apply eq_sym; eauto using split1_combine_existT).
          apply booth2AddU_boothToZ.
  Qed.

  Lemma booth4Step_evalExpr_var:
    forall m_pos m_neg e,
      evalExpr (booth4Step m_pos m_neg (Var _ _ (evalExpr e))) =
      evalExpr (booth4Step m_pos m_neg e).
  Proof.
    intros; do 2 rewrite booth4Step_eval; reflexivity.
  Qed.

  Record BoothMultiplierInv (o: RegsT): Prop :=
    { bsiM : fullType type (SyntaxKind (Bit MultNumBitsExt));
      HbsiM : M.find "m" o = Some (existT _ _ bsiM);
      bsiR : fullType type (SyntaxKind (Bit MultNumBitsExt));
      HbsiR : M.find "r" o = Some (existT _ _ bsiR);

      bsiMp : fullType type (SyntaxKind (Bit MultBits));
      HbsiMp : M.find "m_pos" o = Some (existT _ _ bsiMp);
      bsiMn : fullType type (SyntaxKind (Bit MultBits));
      HbsiMn : M.find "m_neg" o = Some (existT _ _ bsiMn);

      bsiP : fullType type (SyntaxKind (Bit MultBits));
      HbsiP : M.find "p" o = Some (existT _ _ bsiP);

      bsiCnt : fullType type (SyntaxKind (Bit (S MultLogNumPhases)));
      HbsiCnt : M.find "cnt" o = Some (existT _ _ bsiCnt);

      HbsiMmp : bsiMp = extz (sext bsiM 1) (S MultNumBitsExt);
      HbsiMmn : bsiMn = extz (sext (wneg bsiM) 1) (S MultNumBitsExt);

      HmInv : bsiM <> wpow2 MultNumBits;
      HbsiInv :
        exists sl (wl: word sl) sus su (wu: word su),
          sl = 8 * (wordToNat bsiCnt) + 1 /\
          su = S sus + MultNumBitsExt /\
          existT word _ bsiP = existT word _ (combine wl wu) /\
          BoothStepInv bsiM bsiR wl wu
    }.

  Ltac boothMultiplierInv_old :=
    repeat match goal with
           | [H: BoothMultiplierInv _ |- _] => destruct H
           end;
    kinv_red.

  Ltac boothMultiplierInv_new :=
    econstructor; (* let's prove that the invariant holds for the next state *)
    try (findReify; (reflexivity || eassumption); fail);
    kinv_red; (* unfolding invariant definitions *)
    repeat (* cheaper than "intuition" *)
      (match goal with
       | [ |- _ /\ _ ] => split
       end);
    try eassumption; intros; try reflexivity;
    intuition kinv_simpl; intuition idtac.

  Variable n: nat.

  Lemma boothMultiplierInv_ok':
    forall init n ll,
      init = initRegs (getRegInits boothMultiplierImpl) ->
      Multistep boothMultiplierImpl init n ll ->
      BoothMultiplierInv n.
  Proof.
    induction 2; intros.

    - boothMultiplierInv_old.
      unfold getRegInits, fst, boothMultiplierImpl, projT1.
      boothMultiplierInv_new; [discriminate|].
      eexists; exists (natToWord 1 0).
      eexists; eexists; exists (natToWord (2 * MultNumBitsExt + 1) 0).
      split; [|split; [|split]].
      + reflexivity.
      + instantiate (1:= MultNumBitsExt); reflexivity.
      + reflexivity.
      + econstructor.
        * intros.
          eexists; exists (wzero (2 * MultNumBitsExt)).
          reflexivity.
        * instantiate (1:= 0%Z); reflexivity.
        * reflexivity.

    - kinvert; [mred|mred| | |].
      + (* boothMultRegister *)
        Opaque natToWord evalExpr combine.
        kinv_action_dest.
        Transparent natToWord evalExpr.
        kinv_custom boothMultiplierInv_old.
        boothMultiplierInv_new.

        * cbn; unfold eq_rec; eq_rect_simpl.
          reflexivity.
        * cbn; unfold eq_rec; eq_rect_simpl.
          reflexivity.
        * clear -H4 H12.
          Opaque split2.
          simpl in *.
          Transparent split2.
          find_if_inside; [|discriminate].
          assert (wmsb (x Fin.F1) false = true) by (rewrite H12; reflexivity).
          remember (x Fin.F1) as x1; simpl in x1; clear Heqx1 x.
          change MultNumBitsExt with (MultNumBits + 1) in *.
          rewrite wmsb_split2 in H.
          find_if_inside; [discriminate|].
          elim n; assumption.

        * simpl; unfold eq_rec; eq_rect_simpl.

          assert (Hx1: x Fin.F1 <> wpow2 MultNumBits).
          { intro Hx.
            clear -Hx H4.
            Opaque split2.
            simpl in H4.
            Transparent split2.
            find_if_inside; [|discriminate].
            assert (wmsb (x Fin.F1) false = true) by (rewrite Hx; reflexivity).
            remember (x Fin.F1) as x1; simpl in x1; clear Heqx1 x.
            change MultNumBitsExt with (MultNumBits + 1) in *.
            rewrite wmsb_split2 in H.
            find_if_inside; [discriminate|].
            elim n; assumption.
          }

          set (extz (combine (x (Fin.FS Fin.F1)) (natToWord (MultNumBitsExt + 1) 0)) 1) as ww.
          pose proof (boothStepInv_init (x Fin.F1) (x (Fin.FS Fin.F1))) as Hinv0.

          assert (pred MultNumBitsExt <> 0) by (cbn; lia).
          eapply (boothStepInv_boothStep
                    (we:= Var type (SyntaxKind (Bit MultBits)) ww) (sus:= O)
                    Hx1 eq_refl eq_refl eq_refl H12 eq_refl) in Hinv0; [|reflexivity].
          simpl in Hinv0.
          destruct Hinv0 as [nwl [nwu [? ?]]].

          eexists; exists nwl.
          exists 1; eexists; exists nwu.

          repeat split.
          { subst ww.
            cbv [evalSignExtendTrunc].
            simpl; unfold eq_rec; eq_rect_simpl.
            rewrite <-H13.
            reflexivity.
          }
          { assumption. }

      + (* boothMultGetResult *)
        Opaque MultNumBits.
        kinv_action_dest.
        mred.
        Transparent MultNumBits.

      + (* boothStep *)
        kinv_action_dest.
        kinv_custom boothMultiplierInv_old.
        boothMultiplierInv_new.

        remember (8 * wordToNat x + 1) as psl.
        assert (psl >= 9)%nat.
        { subst; clear -n1.
          unfold type in x.
          do 4 (dependent destruction x).
          destruct b, b0, b1; cbn; try lia.
          elim n1; reflexivity.
        }
        do 9 (destruct psl as [|psl]; [lia|]); clear H.

        rename H12 into Hinv0.
        eapply (boothStepInv_booth4Step
                  (we:= Var type (SyntaxKind (Bit MultBits)) x2)
                  HmInv eq_refl eq_refl eq_refl eq_refl) in Hinv0; [|eassumption].
        replace (S x5 + MultNumBitsExt + 2)
          with ((S (S (S x5))) + MultNumBitsExt) in Hinv0 by lia.
        destruct Hinv0 as [nwl1 [nwu1 [Heq1 Hinv1]]].

        eapply (boothStepInv_booth4Step
                  HmInv eq_refl eq_refl eq_refl eq_refl) in Hinv1; [|eassumption].
        replace (S (S (S x5)) + MultNumBitsExt + 2)
          with (S (S (S (S (S x5)))) + MultNumBitsExt) in Hinv1 by lia.
        destruct Hinv1 as [nwl2 [nwu2 [Heq2 Hinv2]]].

        eapply (boothStepInv_booth4Step
                  HmInv eq_refl eq_refl eq_refl eq_refl) in Hinv2; [|eassumption].
        replace (S (S (S (S (S x5)))) + MultNumBitsExt + 2)
          with (S (S (S (S (S (S (S x5)))))) + MultNumBitsExt) in Hinv2 by lia.
        destruct Hinv2 as [nwl3 [nwu3 [Heq3 Hinv3]]].

        eapply (boothStepInv_booth4Step
                  HmInv eq_refl eq_refl eq_refl eq_refl) in Hinv3; [|eassumption].
        replace (S (S (S (S (S (S (S x5)))))) + MultNumBitsExt + 2)
          with (S (S (S (S (S (S (S (S (S x5)))))))) + MultNumBitsExt) in Hinv3 by lia.
        destruct Hinv3 as [nwl4 [nwu4 [Heq4 Hinv4]]].

        eexists; exists nwl4.
        eexists; eexists; exists nwu4.

        repeat split.
        * intros.
          match goal with
          | [ |- context [_ ^- ?w] ] =>
            replace w with (natToWord (S MultLogNumPhases) 1) by reflexivity
          end.
          rewrite <-wordToNat_natToWord_pred by assumption.
          lia.
        * rewrite booth4Step_evalExpr_var with (e:= booth4Step _ _ (#x2)%kami_expr).
          rewrite booth4Step_evalExpr_var with (e:= booth4Step _ _ (booth4Step _ _ _)).
          rewrite booth4Step_evalExpr_var.
          assumption.
        * assumption.

  Qed.

  Lemma boothMultiplierInv_ok:
    forall o,
      reachable o boothMultiplierImpl ->
      BoothMultiplierInv o.
  Proof.
    intros; inv H; inv H0.
    eapply boothMultiplierInv_ok'; eauto.
  Qed.

  Local Definition thetaR (ir sr: RegsT): Prop.
  Proof.
    kexistv "m_pos" m_pos ir (Bit MultBits).
    kexistv "m_neg" m_neg ir (Bit MultBits).
    kexistv "p" p ir (Bit MultBits).
    kexistv "m" m ir (Bit MultNumBitsExt).
    kexistv "r" r ir (Bit MultNumBitsExt).
    kexistv "cnt" cnt ir (Bit (S MultLogNumPhases)).

    exact (sr = ["r" <- existT _ _ r]
                +["m" <- existT _ _ m])%fmap.
  Defined.
  #[local] Hint Unfold thetaR: MapDefs.

  Local Definition ruleMap (o: RegsT): string -> option string :=
    "boothMultRegister" |-> "multRegister";
      "boothMultGetResult" |-> "multGetResult"; ||.
  #[local] Hint Unfold ruleMap: MethDefs.

  Theorem multiplier_ok: boothMultiplierImpl <<== multiplierSpec.
  Proof.
    kdecomposeR_nodefs thetaR ruleMap.
    kinv_add boothMultiplierInv_ok.
    kinvert.

    - (* "boothMultRegister" |-> "multRegister" *)
      Opaque natToWord evalExpr combine.
      kinv_action_dest.
      kinv_custom boothMultiplierInv_old.
      kinv_regmap_red.
      eexists; split; kinv_constr.
      kinv_eq.
      Transparent natToWord evalExpr combine.

    - (* "boothMultGetResult" |-> "multGetResult" *)
      Opaque MultNumBits.
      kinv_action_dest.
      kinv_custom boothMultiplierInv_old.
      kinv_regmap_red.
      Transparent MultNumBits.

      eexists; split; kinv_constr.
      apply boothStepInv_finish in H7; dest.
      assert (x3 = MultNumBitsExt) by (apply eq_sigT_fst in H6; cbn; cbn in H6; lia).
      subst; destruct_existT.
      rewrite idElementwiseId; unfold id.
      do 3 f_equal.
      fin_func_eq.

      + Opaque split1 split2 wordToZ.
        simpl.
        unfold eq_rec_r, eq_rec; repeat rewrite <-eq_rect_eq.
        unfold ilist.ilist_to_fun_m; simpl.
        repeat f_equal.
        rewrite wtl_combine.
        unfold wmultZ, wordBinZ.
        pose proof (sext_wordToZ 33 bsiM).
        cbv [evalSignExtendTrunc]; cbn.
        unfold eq_rec; eq_rect_simpl.
        cbn in H1; rewrite H1.
        pose proof (sext_wordToZ 33 bsiR).
        cbn; cbn in H2; rewrite H2.
        cbn in H0; rewrite <-H0.
        assert (x = 2 * MultNumBitsExt) by (apply eq_sigT_fst in H; lia); subst.
        destruct_existT.
        pose proof (sext_wordToZ 1 x4); cbn; cbn in H; rewrite H.
        rewrite sext_split1.
        rewrite ZToWord_wordToZ.
        reflexivity.
        Transparent split1 split2 wordToZ.

      + Opaque split1 split2 wordToZ.
        simpl.
        unfold eq_rec_r, eq_rec; repeat rewrite <-eq_rect_eq.
        unfold ilist.ilist_to_fun_m; simpl.
        repeat f_equal.
        rewrite wtl_combine.
        unfold wmultZ, wordBinZ.
        pose proof (sext_wordToZ 33 bsiM).
        cbv [evalSignExtendTrunc]; cbn.
        unfold eq_rec; eq_rect_simpl.
        cbn in H1; rewrite H1.
        pose proof (sext_wordToZ 33 bsiR).
        cbn; cbn in H2; rewrite H2.
        cbn in H0; rewrite <-H0.
        assert (x = 2 * MultNumBitsExt) by (apply eq_sigT_fst in H; lia); subst.
        destruct_existT.
        pose proof (sext_wordToZ 1 x4); cbn; cbn in H; rewrite H.
        rewrite sext_split1.
        rewrite ZToWord_wordToZ.
        reflexivity.
        Transparent split1 split2 wordToZ.

    - (* "boothStep" |-> . *)
      kinv_action_dest.
      kinv_custom boothMultiplierInv_old.
      kinv_regmap_red.
      eexists; split; kinv_constr.

  Qed.

End Multiplier32.


(***************************************************************************
* Church-Rosser Property in Pure Lambda-Calculus - Proofs                  *
* Arthur Charguéraud, March 2007, Coq v8.1                                 *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory Lambda_Definitions Lambda_Infrastructure.

(* ********************************************************************** *)
(** ** Main Development *)

(* ********************************************************************** *)
(** Putting constructors as hints for auto *)

Hint Constructors beta star_ equiv_ iter_.

Hint Resolve para_var para_app.

Hint Extern 1 (para (trm_abs _) (trm_abs _)) =>
  let y := fresh "y" in apply_fresh para_abs as y.

Hint Extern 1 (para (trm_app (trm_abs _) _) (_ ^^ _)) =>
  let y := fresh "y" in apply_fresh para_red as y.

(* ********************************************************************** *)
(** Some relations between the properties of relations *)

Lemma red_all_to_out : forall (R : relation),
  red_all R -> red_refl R -> red_out R.
Proof.
  introz. auto*.
Qed.

Lemma red_out_to_rename : forall (R : relation),
  red_out R -> red_rename R.
Proof.
  introz.
  rewrite* (@subst_intro x t).
  rewrite* (@subst_intro x t').
Qed.

Lemma red_all_to_through : forall (R : relation),
  red_regular R -> red_all R -> red_through R.
Proof.
  introz. puts (H _ _ H4).
  rewrite* (@subst_intro x t1).
  rewrite* (@subst_intro x u1).
Qed.

(* ********************************************************************** *)
(** Properties of beta relation *)

Lemma beta_red_out : red_out beta.
Proof.
  introz. induction H0; simpl.
  rewrite* subst_open.
  apply* beta_app1.
  apply* beta_app2.
  apply_fresh* beta_abs as y. cross*.
Qed.

Lemma beta_red_rename : red_rename beta.
Proof.
  apply* (red_out_to_rename beta_red_out).
Qed.

(* ********************************************************************** *)
(** Properties of beta star relation *)

Lemma beta_star_app1 : forall t1 t1' t2,
  (beta star) t1 t1' -> term t2 ->
  (beta star) (trm_app t1 t2) (trm_app t1' t2).
Proof.
  intros. induction H.
  apply* star_refl.
  apply* (@star_trans beta (trm_app t0 t2)).
  apply* star_step.
Qed.

Lemma beta_star_app2 : forall t1 t2 t2',
  (beta star) t2 t2' -> term t1 ->
  (beta star) (trm_app t1 t2) (trm_app t1 t2').
Proof.
  intros. induction H.
  apply* star_refl.
  apply* (@star_trans beta (trm_app t1 t2)).
  apply* star_step.
Qed.

Lemma beta_star_abs : forall L t1 t1',
  (forall x, x \notin L -> (beta star) (t1 ^ x) (t1' ^ x)) ->
  (beta star) (trm_abs t1) (trm_abs t1').
Proof.
  introv R. pick_fresh x. forward~ (R x) as Red.
  asserts B1 (term (trm_abs t1')).
    apply_fresh term_abs as y. forward* (R y).
  asserts B2 (term (trm_abs t1')).
    apply_fresh term_abs as y. forward* (R y).
  gen_eq (t1 ^ x) as u. gen_eq (t1' ^ x) as u'.
  clear R. gen t1 t1'.
  induction Red; intros; subst.
  rewrite* (@open_var_inj x t1 t1').
  destruct~ (@close_var_spec t2 x) as [u [P [Q R]]].
   apply* (@star_trans beta (trm_abs u)).
  apply star_step.
   apply_fresh* beta_abs as y.
   apply* (@beta_red_rename x).
Qed.

Lemma beta_star_red_in : red_in (beta star).
Proof.
  introv Wf Red. puts term. induction Wf; simpl.
  case_var*.
  apply~ (@star_trans beta (trm_app ([x ~> u']t1) ([x ~> u]t2))).
    apply* beta_star_app1.
    apply* beta_star_app2.
  apply_fresh* beta_star_abs as y. cross*.
Qed.

Lemma beta_star_red_all : red_all (beta star).
Proof.
  introv Redt. induction Redt; simpl; intros u u' Redu.
  apply* beta_star_red_in.
  apply* (@star_trans beta ([x ~> u]t2)).
  apply* (@star_trans beta ([x ~> u]t')).
   apply* star_step. apply* beta_red_out.
   apply* beta_star_red_in.
Qed.

Lemma beta_star_red_through : red_through (beta star).
Proof.
  apply (red_all_to_through red_regular_beta_star beta_star_red_all).
Qed.

(* ********************************************************************** *)
(** Properties of parallel relation and its iterated version *)

Section ParaProperties.

Hint Extern 1 (para (if _ == _ then _ else _) _) => case_var.

Lemma para_red_all : red_all para.
Proof.
  intros x t t' H. induction H; intros; simpl*.
  rewrite* subst_open. apply_fresh* para_red as y. cross*.
  apply_fresh* para_abs as y. cross*.
Qed.

Lemma para_red_refl : red_refl para.
Proof.
  introz. induction* H.
Qed.

Lemma para_red_out : red_out para.
Proof.
  apply* (red_all_to_out para_red_all para_red_refl).
Qed.

Lemma para_red_rename : red_rename para.
Proof.
  apply* (red_out_to_rename para_red_out).
Qed.

Lemma para_red_through : red_through para.
Proof.
  apply* (red_all_to_through red_regular_para para_red_all).
Qed.

Lemma para_iter_red_refl : red_refl (para iter).
Proof.
  introz. use para_red_refl.
Qed.

End ParaProperties.

(* ********************************************************************** *)
(** Confluence of parallel relation *)

Lemma para_abs_inv : forall t1 u,
  para (trm_abs t1) u -> exists L, exists t2, u = (trm_abs t2) /\
  forall x : var, x \notin L -> para (t1 ^ x) (t2 ^ x).
Proof.
  intros. inversion* H.
Qed.

Lemma para_confluence : confluence para.
Proof.
  introv HS. gen T. induction HS; intros T HT; inversions HT.
    (* case: red / red *)
  destructi~ (IHHS t2'0) as [u2 [U2a U2b]].
  pick_fresh x. forward~ (H0 x) as K.
  destruct~ (K (t1'0 ^ x)) as [u1x [U1a U1b]].
  destruct~ (@close_var_spec u1x x) as [u1 [EQu1 termu1]].
  rewrite EQu1 in U1a, U1b.
  exists (u1 ^^ u2). split; apply* (@para_red_through x).
    (* case: red / trm_app *)
  destructi~ (IHHS t2'0) as [u2 [U2a U2b]].
  destruct (para_abs_inv H3) as [L2 [t1'0x [EQ Ht1'0]]].
  rewrite EQ in H3 |- *.
  pick_fresh x. forward~ (H0 x) as K.
  destruct ~ (K (t1'0x ^ x)) as [u1x [U1a U1b]].
  destruct~ (@close_var_spec u1x x) as [u1 [EQu1 termu1]].
  rewrite EQu1 in U1a, U1b.
  exists (u1 ^^ u2). split.
    apply* (@para_red_through x).
    apply_fresh para_red as y; auto.
     apply* (@para_red_rename x).
    (* case: var / var *)
  auto*.
    (* case: trm_app / red *)
  destruct~ (IHHS2 t2'0) as [u2 [U2a U2b]].
  destruct (para_abs_inv HS1) as [L2 [t1'x [EQ Ht1'x]]].
  destruct (IHHS1 (trm_abs t1'0)) as [u1x [U1a U1b]].
   apply_fresh* para_abs as y.
  rewrite EQ in HS1, U1a |- *.
  destruct (para_abs_inv U1b) as [L1 [u1 [EQ' Hu1]]].
  rewrite EQ' in U1a, U1b.
  exists (u1 ^^ u2). split.
    inversion U1a. apply* (@para_red L0).
    pick_fresh x. apply* (@para_red_through x).
    (* case: trm_app / trm_app *)
  destructi~ (IHHS1 t1'0) as [P1 [HP11 HP12]].
  destructi~ (IHHS2 t2'0) as [P2 [HP21 HP22]].
  exists* (trm_app P1 P2).
    (* case: trm_abs / trm_abs *)
  pick_fresh x. forward~ (H0 x) as K.
  destruct~ (K (t1'0 ^ x)) as [px [P0 P1]].
  destruct~ (@close_var_spec px x) as [p [EQP termp]].
  rewrite EQP in P0, P1.
  exists (trm_abs p). split;
   apply_fresh* para_abs as y; apply* (@para_red_rename x).
Qed.

(* ********************************************************************** *)
(** Confluence of iterated parallel relation *)

Lemma para_iter_parallelogram :
  forall M S, (para iter) M S -> forall T, para M T ->
    exists P : trm, para S P /\ (para iter) T P.
Proof.
  introv H. induction H; introv MtoT.
  destructi~ (IHiter_1 T) as [P [HP1 HP2]].
   destructi~ (IHiter_2 P) as [Q [HQ1 HQ2]].
   exists Q. use (@iter_trans para P).
  destruct* (para_confluence H MtoT).
Qed.

Lemma para_iter_confluence : confluence (para iter).
Proof.
  introv MtoS MtoT. gen T.
  induction MtoS; introv MtoT.
  destructi~ (IHMtoS1 T) as [P [HP1 HP2]].
   destructi~ (IHMtoS2 P) as [Q [HQ1 HQ2]]. exists* Q.
  destruct* (para_iter_parallelogram MtoT H).
Qed.

(* ********************************************************************** *)
(** Equality of beta star and iterated parallel relations *)

Lemma beta_star_to_para_iter :
  (beta star) simulated_by (para iter).
Proof.
  introz. induction* H.
  apply* para_iter_red_refl.
  apply iter_step. induction H; use para_red_refl.
Qed.

Lemma para_iter_to_beta_star :
  (para iter) simulated_by (beta star).
Proof.
  introz. induction H; eauto.
  induction H.
  apply~ (@star_trans beta (t1 ^^ t2)).
   pick_fresh x. apply* (@beta_star_red_through x).
  apply* star_refl.
  apply~ (@star_trans beta (trm_app t1' t2)).
   apply* beta_star_app1. apply* beta_star_app2.
  apply* beta_star_abs.
Qed.

(* ********************************************************************** *)
(** Church-Rosser property of beta relation *)

Lemma beta_star_confluence : confluence (beta star).
Proof.
  introz. destruct (@para_iter_confluence M S T).
  use beta_star_to_para_iter.
  use beta_star_to_para_iter.
  use para_iter_to_beta_star.
Qed.

Lemma beta_church_rosser : church_rosser beta.
Proof.
  introz. induction H.
  exists* t.
  destruct* IHequiv_.
  destruct IHequiv_1 as [u [Pu Qu]].
   destruct IHequiv_2 as [v [Pv Qv]].
   destruct (beta_star_confluence Qu Pv) as [w [Pw Qw]].
   exists w. split.
     apply* (@star_trans beta u).
     apply* (@star_trans beta v).
  exists* t'.
Qed.