(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 7: Model Checking
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Set Warnings "-notation-overridden". (* <-- needed while we play with defining one
                                      * of the book's notations ourselves locally *)
Require Import Frap TransitionSystems.

Set Implicit Arguments.

(* Coming up with invariants ourselves can be tedious!  Let's investigate how we
 * can automate the choice of invariants, for systems with only finitely many
 * reachable states.  This style is known as model checking. *)
Definition oneStepClosure_current {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  forall st, invariant1 st
             -> invariant2 st.

Definition oneStepClosure_new {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  forall st st', invariant1 st
                 -> sys.(Step) st st'
                 -> invariant2 st'.

Definition oneStepClosure {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  oneStepClosure_current sys invariant1 invariant2
  /\ oneStepClosure_new sys invariant1 invariant2.

Theorem prove_oneStepClosure : forall state (sys : trsys state) (inv1 inv2 : state -> Prop),
  (forall st, inv1 st -> inv2 st)
  -> (forall st st', inv1 st -> sys.(Step) st st' -> inv2 st')
  -> oneStepClosure sys inv1 inv2.
Proof.
  unfold oneStepClosure.
  propositional.
Qed.

Theorem oneStepClosure_done : forall state (sys : trsys state) (invariant : state -> Prop),
  (forall st, sys.(Initial) st -> invariant st)
  -> oneStepClosure sys invariant invariant
  -> invariantFor sys invariant.
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new.
  propositional.
  apply invariant_induction.
  assumption.
  simplify.
  eapply H2.
  eassumption.
  assumption.
Qed.

Inductive multiStepClosure {state} (sys : trsys state)
  : (state -> Prop) -> (state -> Prop) -> Prop :=

(* We might be done, if one-step closure has no effect. *)
| MscDone : forall inv,
    oneStepClosure sys inv inv
    -> multiStepClosure sys inv inv

(* Or we might need to run another one-step closure and recurse. *)
| MscStep : forall inv inv' inv'',
    oneStepClosure sys inv inv'
    -> multiStepClosure sys inv' inv''
    -> multiStepClosure sys inv inv''.

Lemma multiStepClosure_ok' : forall state (sys : trsys state) (inv inv' : state -> Prop),
  multiStepClosure sys inv inv'
  -> (forall st, sys.(Initial) st -> inv st)
  -> invariantFor sys inv'.
Proof.
  induct 1; simplify.

  apply oneStepClosure_done.
  assumption.
  assumption.

  apply IHmultiStepClosure.
  simplify.
  unfold oneStepClosure, oneStepClosure_current in *.
  propositional.
  apply H3.
  apply H1.
  assumption.
Qed.

Theorem multiStepClosure_ok : forall state (sys : trsys state) (inv : state -> Prop),
  multiStepClosure sys sys.(Initial) inv
  -> invariantFor sys inv.
Proof.
  simplify.
  eapply multiStepClosure_ok'.
  eassumption.
  propositional.
Qed.

Theorem oneStepClosure_empty : forall state (sys : trsys state),
  oneStepClosure sys (constant nil) (constant nil).
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; propositional.
Qed.

Theorem oneStepClosure_split : forall state (sys : trsys state) st sts (inv1 inv2 : state -> Prop),
  (forall st', sys.(Step) st st' -> inv1 st')
  -> oneStepClosure sys (constant sts) inv2
  -> oneStepClosure sys (constant (st :: sts)) ({st} \cup inv1 \cup inv2).
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; propositional.

  invert H0.

  left.
  (* [left] and [right]: prove a disjunction by proving the left or right case,
   *   respectively.  Note that here, we are using the fact that set union
   *   [\cup] is defined in terms of disjunction. *)
  left.
  simplify.
  propositional.

  right.
  apply H1.
  assumption.

  simplify.
  propositional.

  right.
  left.
  apply H.
  equality.

  right.
  right.
  eapply H2.
  eassumption.
  assumption.
Qed.

Theorem singleton_in : forall {A} (x : A) rest,
  ({x} \cup rest) x.
Proof.
  simplify.
  left.
  simplify.
  equality.
Qed.

(* OK, back to our example from last chapter, of factorial as a transition
 * system.  Here's a good overall correctness condition, which we didn't bother
 * to state before. *)
Definition fact_correct (original_input : nat) (st : fact_state) : Prop :=
  match st with
  | AnswerIs ans => fact original_input = ans
  | WithAccumulator _ _ => True
  end.

(* Let's also restate the initial-states set using a singleton set. *)
Theorem fact_init_is : forall original_input,
  fact_init original_input = {WithAccumulator original_input 1}.
Proof.
  simplify.
  apply sets_equal; simplify.
  propositional.

  invert H.
  equality.

  rewrite <- H0.
  constructor.
Qed.

(* Now we will prove that factorial is correct, for the input 2, without needing
 * to write out an inductive invariant ourselves. *)
Theorem factorial_ok_2 :
  invariantFor (factorial_sys 2) (fact_correct 2).
Proof.
  simplify.
  eapply invariant_weaken.

  apply multiStepClosure_ok.
  simplify.
  rewrite fact_init_is.

  eapply MscStep.
  apply oneStepClosure_split.
  simplify.
  invert H.
  simplify.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  eapply MscStep.
  apply oneStepClosure_split.
  simplify.
  invert H.
  simplify.
  apply singleton_in.
  apply oneStepClosure_split.
  simplify.
  invert H.
  simplify.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  eapply MscStep.
  apply oneStepClosure_split.
  simplify.
  invert H.
  simplify.
  apply singleton_in.
  apply oneStepClosure_split.
  simplify.
  invert H.
  simplify.
  apply singleton_in.
  apply oneStepClosure_split.
  simplify.
  invert H.
  simplify.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  apply MscDone.
  apply prove_oneStepClosure; simplify.
  assumption.
  propositional; subst; invert H0; simplify; propositional.

  simplify.
  unfold fact_correct.
  propositional; subst; trivial.
Qed.

(* BEGIN CODE THAT WILL NOT BE EXPLAINED IN DETAIL! *)

Local Hint Rewrite fact_init_is.

Ltac model_check_done :=
  apply MscDone; apply prove_oneStepClosure; simplify; propositional; subst;
  repeat match goal with
         | [ H : _ |- _ ] => invert H
         end; simplify; equality.

Theorem singleton_in_other : forall {A} (x : A) (s1 s2 : set A),
  s2 x
  -> (s1 \cup s2) x.
Proof.
  simplify.
  right.
  right.
  assumption.
Qed.

Ltac singletoner :=
  repeat match goal with
         | _ => apply singleton_in
         | [ |- (_ \cup _) _ ] => apply singleton_in_other
         end.

Ltac model_check_step0 :=
  eapply MscStep; [
    repeat ((apply oneStepClosure_empty; simplify)
            || (apply oneStepClosure_split; [ simplify;
                                              repeat match goal with
                                                     | [ H : _ |- _ ] => invert H; try congruence
                                                     end; solve [ singletoner ] | ]))
  | simplify ].

Ltac model_check_step :=
  match goal with
  | [ |- multiStepClosure _ ?inv1 _ ] =>
    model_check_step0;
    match goal with
    | [ |- multiStepClosure _ ?inv2 _ ] =>
      (assert (inv1 = inv2) by compare_sets; fail 3)
      || idtac
    end
  end.

Ltac model_check_steps1 := model_check_step || model_check_done.
Ltac model_check_steps := repeat model_check_steps1.

Ltac model_check_finish := simplify; propositional; subst; simplify; equality.

Ltac model_check_infer :=
  apply multiStepClosure_ok; simplify; model_check_steps.

Ltac model_check_find_invariant :=
  simplify; eapply invariant_weaken; [ model_check_infer | ]; cbv beta in *.

Ltac model_check := model_check_find_invariant; model_check_finish.

(* END CODE THAT WILL NOT BE EXPLAINED IN DETAIL! *)

(* Now watch this.  We can check various instances of factorial
 * automatically. *)

Theorem factorial_ok_2_snazzy :
  invariantFor (factorial_sys 2) (fact_correct 2).
Proof.
  model_check.
Qed.

Theorem factorial_ok_3 :
  invariantFor (factorial_sys 3) (fact_correct 3).
Proof.
  model_check.
Qed.

Theorem factorial_ok_5 :
  invariantFor (factorial_sys 5) (fact_correct 5).
Proof.
  model_check.
Qed.

(* Let's see that last one broken into two steps, so that we get a look at the
 * inferred invariant. *)
Theorem factorial_ok_5_again :
  invariantFor (factorial_sys 5) (fact_correct 5).
Proof.
  model_check_find_invariant.
  model_check_finish.
Qed.

(** * Abstraction *)

Inductive isEven : nat -> Prop :=
| EvenO : isEven 0
| EvenSS : forall n, isEven n -> isEven (S (S n)).

Inductive add2_thread :=
| Read
| Write (local : nat).

Inductive add2_init : threaded_state nat add2_thread -> Prop :=
| Add2Init : add2_init {| Shared := 0; Private := Read |}.

Inductive add2_step : threaded_state nat add2_thread -> threaded_state nat add2_thread -> Prop :=
| StepRead : forall global,
    add2_step {| Shared := global; Private := Read |}
              {| Shared := global; Private := Write global |}
| StepWrite : forall global local,
    add2_step {| Shared := global; Private := Write local |}
              {| Shared := S (S local); Private := Read |}.

Definition add2_sys1 := {|
  Initial := add2_init;
  Step := add2_step
|}.

Definition add2_sys := parallel add2_sys1 add2_sys1.

Definition add2_correct (st : threaded_state nat (add2_thread * add2_thread)) :=
  isEven st.(Shared).

Inductive simulates state1 state2 (R : state1 -> state2 -> Prop)
  (* [R] is a relation connecting the states of the two systems. *)
  (sys1 : trsys state1) (sys2 : trsys state2) : Prop :=
| Simulates :
  (* Every initial state of [sys1] has some matching initial state of [sys2]. *)
  (forall st1, sys1.(Initial) st1
               -> exists st2, R st1 st2
                              /\ sys2.(Initial) st2)

  (* Starting from a pair of related states, every step in [sys1] can be matched
   * in [sys2], to destinations that are also related. *)
  -> (forall st1 st2, R st1 st2
                      -> forall st1', sys1.(Step) st1 st1'
                                      -> exists st2', R st1' st2'
                                                      /\ sys2.(Step) st2 st2')

  -> simulates R sys1 sys2.

(* Given an invariant for [sys2], we now have a generic way of defining an
 * invariant for [sys1], by composing with [R]. *)
Inductive invariantViaSimulation state1 state2 (R : state1 -> state2 -> Prop)
  (inv2 : state2 -> Prop)
  : state1 -> Prop :=
| InvariantViaSimulation : forall st1 st2, R st1 st2
  -> inv2 st2
  -> invariantViaSimulation R inv2 st1.

(* By way of a lemma, let's prove that, given a simulation, any
 * invariant-via-simulation really is an invariant for the original system. *)
Lemma invariant_simulates' : forall state1 state2 (R : state1 -> state2 -> Prop)
  (sys1 : trsys state1) (sys2 : trsys state2),
  (forall st1 st2, R st1 st2
                   -> forall st1', sys1.(Step) st1 st1'
                                   ->  exists st2', R st1' st2'
                                                    /\ sys2.(Step) st2 st2')
  -> forall st1 st1', sys1.(Step)^* st1 st1'
                      -> forall st2, R st1 st2
                                     -> exists st2', R st1' st2'
                                                     /\ sys2.(Step)^* st2 st2'.
Proof.
  induct 2.

  simplify.
  exists st2.
  (* [exists E]: prove [exists x, P(x)] by proving [P(E)]. *)
  propositional.
  constructor.

  simplify.
  eapply H in H2.
  first_order.
  (* [first_order]: simplify first-order logic structure.  Be forewarned: this
   *   one is especially likely to run forever! *)
  apply IHtrc in H2.
  first_order.
  exists x1.
  propositional.
  econstructor.
  eassumption.
  assumption.
  assumption.
Qed.

Theorem invariant_simulates : forall state1 state2 (R : state1 -> state2 -> Prop)
  (sys1 : trsys state1) (sys2 : trsys state2) (inv2 : state2 -> Prop),
  simulates R sys1 sys2
  -> invariantFor sys2 inv2
  -> invariantFor sys1 (invariantViaSimulation R inv2).
Proof.
  simplify.
  invert H.
  unfold invariantFor; simplify.
  apply H1 in H.
  first_order.
  apply invariant_simulates' with (sys2 := sys2) (R := R) (st2 := x) in H3; try assumption.
  first_order.
  unfold invariantFor in H0.
  apply H0 with (s' := x0) in H4; try assumption.
  econstructor.
  eassumption.
  assumption.
Qed.

(*Theorem add2_ok :
  invariantFor add2_sys add2_correct.
Proof.
Admitted.*)

Inductive add2_bthread :=
| BRead
| BWrite (local : bool).

Inductive add2_binit : threaded_state bool add2_bthread -> Prop :=
| Add2BInit : add2_binit {| Shared := true; Private := BRead |}.

Inductive add2_bstep : threaded_state bool add2_bthread -> threaded_state bool add2_bthread -> Prop :=
| StepBRead : forall global,
    add2_bstep {| Shared := global; Private := BRead |}
               {| Shared := global; Private := BWrite global |}
| StepBWrite : forall global local,
    add2_bstep {| Shared := global; Private := BWrite local |}
               {| Shared := local; Private := BRead |}.

Definition add2_bsys1 := {|
  Initial := add2_binit;
  Step := add2_bstep
|}.

Definition add2_bsys := parallel add2_bsys1 add2_bsys1.

(* This invariant formalizes the connection between local states of threads, in
 * the original and abstracted systems. *)
Inductive R_private1 : add2_thread -> add2_bthread -> Prop :=
| RpRead : R_private1 Read BRead
| RpWrite : forall n b, (b = true <-> isEven n)
                        -> R_private1 (Write n) (BWrite b).

(* We lift [R_private1] to a relation over whole states. *)
Inductive add2_R : threaded_state nat (add2_thread * add2_thread)
                   -> threaded_state bool (add2_bthread * add2_bthread)
                   -> Prop :=
| Add2_R : forall n b th1 th2 th1' th2',
  (b = true <-> isEven n)
  -> R_private1 th1 th1'
  -> R_private1 th2 th2'
  -> add2_R {| Shared := n; Private := (th1, th2) |}
            {| Shared := b; Private := (th1', th2') |}.

(* Let's also recharacterize the initial states via a singleton set. *)
Theorem add2_init_is :
  parallel_init add2_binit add2_binit = { {| Shared := true; Private := (BRead, BRead) |} }.
Proof.
  simplify.
  apply sets_equal; simplify.
  propositional.

  invert H.
  invert H2.
  invert H4.
  equality.

  invert H0.
  constructor.
  constructor.
  constructor.
Qed.

(* We ask Coq to remember this lemma as a hint, which will be used by the
 * model-checking tactics that we refrain from explaining in detail. *)
Local Hint Rewrite add2_init_is.

(* Now, let's verify the original system. *)
Theorem add2_ok :
  invariantFor add2_sys add2_correct.
Proof.
  (* First step: strengthen the invariant.  We leave an underscore for the
   * unknown invariant, to be found by model checking. *)
  eapply invariant_weaken with (invariant1 := invariantViaSimulation add2_R _).

  (* One way to find an invariant-by-simulation is to find an invariant for the
   * abstracted system, as this step asks to do. *)
  apply invariant_simulates with (sys2 := add2_bsys).

  (* Now we must prove that the simulation via [add2_R] is valid, which is
   * routine. *)
  constructor; simplify.

  invert H.
  invert H0.
  invert H1.
  exists {| Shared := true; Private := (BRead, BRead) |}; simplify.
  propositional.
  constructor.
  propositional.
  constructor.
  constructor.
  constructor.

  invert H.
  invert H0; simplify.

  invert H7.

  invert H2.
  exists {| Shared := b; Private := (BWrite b, th2') |}.
  propositional.
  constructor.
  propositional.
  constructor.
  propositional.
  assumption.
  constructor.
  constructor.

  invert H2.
  exists {| Shared := b0; Private := (BRead, th2') |}.
  propositional.
  constructor.
  propositional.
  constructor.
  assumption.
  invert H0.
  propositional.
  constructor.
  assumption.
  constructor.
  constructor.

  invert H7.

  invert H3.
  exists {| Shared := b; Private := (th1', BWrite b) |}.
  propositional.
  constructor.
  propositional.
  assumption.
  constructor.
  propositional.
  constructor.
  constructor.

  invert H3.
  exists {| Shared := b0; Private := (th1', BRead) |}.
  propositional.
  constructor.
  propositional.
  constructor.
  assumption.
  invert H0.
  propositional.
  assumption.
  constructor.
  constructor.
  constructor.

  (* OK, we're glad to have that over with!  Such a process could also be
   * automated, but we won't bother doing so here.  However, we are now in a
   * good state, where our model checker can find the invariant
   * automatically. *)
  model_check_infer.
  (* It finds exactly four reachable states.  We finish by showing that they all
   * obey the original invariant. *)

  invert 1.
  invert H0.
  simplify.
  unfold add2_correct.
  simplify.
  propositional; subst.

  invert H.
  propositional.

  invert H1.
  propositional.

  invert H.
  propositional.

  invert H1.
  propositional.
Qed.

(** * Another abstraction example *)

Inductive pc :=
| i_gets_0
| j_gets_0
| Loop
| i_add_n
| j_add_n
| n_sub_1
| Done.

Record vars := {
  N : nat;
  I : nat;
  J : nat
}.

Record state := {
  Pc : pc;
  Vars : vars
}.

Inductive initial : state -> Prop :=
| Init : forall vs, initial {| Pc := i_gets_0; Vars := vs |}.

Inductive step : state -> state -> Prop :=
| Step_i_gets_0 : forall n i j,
  step {| Pc := i_gets_0; Vars := {| N := n;
                                     I := i;
                                     J := j |} |}
       {| Pc := j_gets_0; Vars := {| N := n;
                                     I := 0;
                                     J := j |} |}
| Step_j_gets_0 : forall n i j,
  step {| Pc := j_gets_0; Vars := {| N := n;
                                     I := i;
                                     J := j |} |}
       {| Pc := Loop; Vars := {| N := n;
                                 I := i;
                                 J := 0 |} |}
| Step_Loop_done : forall i j,
  step {| Pc := Loop; Vars := {| N := 0;
                                 I := i;
                                 J := j |} |}
       {| Pc := Done; Vars := {| N := 0;
                                 I := i;
                                 J := j |} |}
| Step_Loop_enter : forall n i j,
  step {| Pc := Loop; Vars := {| N := S n;
                                 I := i;
                                 J := j |} |}
       {| Pc := i_add_n; Vars := {| N := S n;
                                    I := i;
                                    J := j |} |}
| Step_i_add_n : forall n i j,
  step {| Pc := i_add_n; Vars := {| N := n;
                                    I := i;
                                    J := j |} |}
       {| Pc := j_add_n; Vars := {| N := n;
                                    I := i + n;
                                    J := j |} |}
| Step_j_add_n : forall n i j,
  step {| Pc := j_add_n; Vars := {| N := n;
                                    I := i;
                                    J := j |} |}
       {| Pc := n_sub_1; Vars := {| N := n;
                                    I := i;
                                    J := j + n |} |}
| Step_n_sub_1 : forall n i j,
  step {| Pc := n_sub_1; Vars := {| N := n;
                                    I := i;
                                    J := j |} |}
       {| Pc := Loop; Vars := {| N := n - 1;
                                 I := i;
                                 J := j |} |}.

Definition loopy_sys := {|
  Initial := initial;
  Step := step
|}.

Definition loopy_correct (st : state) :=
  st.(Pc) = Done -> st.(Vars).(I) = st.(Vars).(J).

(* Spoiler alert: here's a good abstraction! *)
Inductive absvars :=
| Unknown
  (* We don't know anything about the values of the variables. *)
| i_is_0
  (* We know [i == 0]. *)
| i_eq_j
  (* We know [i == j]. *)
| i_eq_j_plus_n.
  (* We know [i == j + n]. *)

(* To get our abstract states, we keep the same program counters and just change
 * out the variable state. *)
Record absstate := {
  APc : pc;
  AVars : absvars
}.

(* Here's the rather boring new abstract step relation.  Note the clever state
 * transformations, in terms of our new abstraction. *)
Inductive absstep : absstate -> absstate -> Prop :=
| AStep_i_gets_0 : forall vs,
  absstep {| APc := i_gets_0; AVars := vs |}
          {| APc := j_gets_0; AVars := i_is_0 |}
| AStep_j_gets_0_i_is_0 :
  absstep {| APc := j_gets_0; AVars := i_is_0 |}
          {| APc := Loop; AVars := i_eq_j |}
| AStep_j_gets_0_Other : forall vs,
  vs <> i_is_0
  -> absstep {| APc := j_gets_0; AVars := vs |}
             {| APc := Loop; AVars := Unknown |}
| AStep_Loop_done : forall vs,
  absstep {| APc := Loop; AVars := vs |}
          {| APc := Done; AVars := vs |}
| AStep_Loop_enter : forall vs,
  absstep {| APc := Loop; AVars := vs |}
          {| APc := i_add_n; AVars := vs |}
| AStep_i_add_n_i_eq_j :
  absstep {| APc := i_add_n; AVars := i_eq_j |}
          {| APc := j_add_n; AVars := i_eq_j_plus_n |}
| AStep_i_add_n_Other : forall vs,
  vs <> i_eq_j
  -> absstep {| APc := i_add_n; AVars := vs |}
             {| APc := j_add_n; AVars := Unknown |}
| AStep_j_add_n_i_eq_j_plus_n :
  absstep {| APc := j_add_n; AVars := i_eq_j_plus_n |}
          {| APc := n_sub_1; AVars := i_eq_j |}
| AStep_j_add_n_i_Other : forall vs,
  vs <> i_eq_j_plus_n
  -> absstep {| APc := j_add_n; AVars := vs |}
             {| APc := n_sub_1; AVars := Unknown |}
| AStep_n_sub_1_bad :
  absstep {| APc := n_sub_1; AVars := i_eq_j_plus_n |}
          {| APc := Loop; AVars := Unknown |}
| AStep_n_sub_1_good : forall vs,
  vs <> i_eq_j_plus_n
  -> absstep {| APc := n_sub_1; AVars := vs |}
             {| APc := Loop; AVars := vs |}.

Definition absloopy_sys := {|
  Initial := { {| APc := i_gets_0; AVars := Unknown |} };
  Step := absstep
|}.

(* Now we need our simulation relation.  First, we define one just at the level
 * of local-variable state.  It formalizes our intuition about those values. *)
Inductive Rvars : vars -> absvars -> Prop :=
| Rv_Unknown : forall vs, Rvars vs Unknown
| Rv_i_is_0 : forall vs, vs.(I) = 0 -> Rvars vs i_is_0
| Rv_i_eq_j : forall vs, vs.(I) = vs.(J) -> Rvars vs i_eq_j
| Rv_i_eq_j_plus_n : forall vs, vs.(I) = vs.(J) + vs.(N) -> Rvars vs i_eq_j_plus_n.

(* We lift to full states in the obvious way. *)
Inductive R : state -> absstate -> Prop :=
| Rcon : forall pc vs avs, Rvars vs avs -> R {| Pc := pc; Vars := vs |}
                                             {| APc := pc; AVars := avs |}.

(* Now we are ready to prove the original system correct. *)
Theorem loopy_ok :
  invariantFor loopy_sys loopy_correct.
Proof.
  eapply invariant_weaken with (invariant1 := invariantViaSimulation R _).
  apply invariant_simulates with (sys2 := absloopy_sys).

  (* Here comes another boring simulation proof. *)
  constructor; simplify.

  invert H.
  exists {| APc := i_gets_0; AVars := Unknown |}.
  propositional.
  constructor.
  constructor.

  invert H0.

  invert H.
  exists {| APc := j_gets_0; AVars := i_is_0 |}.
  propositional; repeat constructor.

  invert H.
  invert H3.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := i_eq_j |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.

  exists {| APc := Done; AVars := st2.(AVars) |}.
  invert H; simplify; propositional; repeat constructor; equality.

  exists {| APc := i_add_n; AVars := st2.(AVars) |}.
  invert H; simplify; propositional; repeat constructor; equality.

  invert H.
  invert H3.
  exists {| APc := j_add_n; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := j_add_n; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := j_add_n; AVars := i_eq_j_plus_n |}; repeat constructor; simplify; equality.
  exists {| APc := j_add_n; AVars := Unknown |}; repeat constructor; equality.

  invert H.
  invert H3.
  exists {| APc := n_sub_1; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := n_sub_1; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := n_sub_1; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := n_sub_1; AVars := i_eq_j |}; repeat constructor; simplify; equality.

  invert H.
  invert H3.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := i_is_0 |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := i_eq_j |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.

  (* Finally, we can call the model checker to find an invariant of the abstract
   * system. *)
  model_check_infer.
  (* We get 7 neat little states, one per program counter.  Next, we prove that
   * each of them implies the original invariant. *)

  invert 1. (* Note that this [1] means "first premise below the double
             * line." *)
  invert H0.
  unfold loopy_correct.
  simplify.
  propositional; subst.

  (* Most of the hypotheses we invert are contradictory, implying that distinct
   * program counters are equal. *)

  invert H2.

  invert H1.

  invert H2.

  invert H1.
  invert H.
  assumption.

  invert H2.

  invert H1.

  invert H2.
Qed.

(** * Modularity *)

Inductive stepWithInterference shared private (inv : shared -> Prop)
          (step : threaded_state shared private -> threaded_state shared private -> Prop)
          : threaded_state shared private -> threaded_state shared private -> Prop :=

(* First kind of step: this thread runs in the normal way. *)
| StepSelf : forall st st',
  step st st'
  -> stepWithInterference inv step st st'

(* Second kind of step: other threads change shared state to some new value
 * satisfying [inv]. *)
| StepEnvironment : forall sh pr sh',
  inv sh'
  -> stepWithInterference inv step
                          {| Shared := sh; Private := pr |}
                          {| Shared := sh'; Private := pr |}.

(* Via this relation, we have an operator to build a new transition system from
 * an old one, given [inv]. *)
Definition withInterference shared private (inv : shared -> Prop)
           (sys : trsys (threaded_state shared private))
  : trsys (threaded_state shared private) := {|
  Initial := sys.(Initial);
  Step := stepWithInterference inv sys.(Step)
|}.

(* Tired of simulation proofs yet?  Then you'll love this theorem, which shows
 * a free simulation for any use of [withInterference]!  We even get to pick the
 * trivial simulation relation, state equality. *)
Theorem withInterference_abstracts : forall shared private (inv : shared -> Prop)
                                           (sys : trsys (threaded_state shared private)),
  simulates (fun st st' => st = st') sys (withInterference inv sys).
Proof.
  simplify.
  constructor; simplify.

  exists st1; propositional.

  exists st1'; propositional.
  constructor.
  equality.
Qed.

Lemma withInterference_parallel_init : forall shared private1 private2
                                          (invs : shared -> Prop)
                                          (sys1 : trsys (threaded_state shared private1))
                                          (sys2 : trsys (threaded_state shared private2))
                                          st st',
  (withInterference invs (parallel sys1 sys2)).(Step)^* st st'
  -> forall st1 st2,
      (forall st1', (withInterference invs sys1).(Step)^* st1 st1' -> invs st1'.(Shared))
      -> (forall st2', (withInterference invs sys2).(Step)^* st2 st2' -> invs st2'.(Shared))
      -> (withInterference invs sys1).(Step)^* st1
                                            {| Shared := st.(Shared);
                                               Private := fst st.(Private) |}
      -> (withInterference invs sys2).(Step)^* st2
                                            {| Shared := st.(Shared);
                                               Private := snd st.(Private) |}
      -> (withInterference invs sys1).(Step)^* st1
                                            {| Shared := st'.(Shared);
                                               Private := fst st'.(Private) |}.
Proof.
  induct 1; simplify.

  assumption.

  invert H; simplify.
  invert H5; simplify.

  apply IHtrc with (st2 := {| Shared := sh'; Private := pr2 |}).
  simplify.
  apply H1.
  assumption.
  simplify.
  eapply H2.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H1 with (st1' := {| Shared := sh'; Private := pr1' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  assumption.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  constructor.

  apply IHtrc with (st2 := {| Shared := sh'; Private := pr2' |}).
  assumption.
  simplify.
  apply H2.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  constructor.
  eassumption.
  eassumption.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H2 with (st2' := {| Shared := sh'; Private := pr2' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  constructor.
  constructor.

  apply IHtrc with (st2 := {| Shared := sh'; Private := snd pr |}).
  assumption.
  simplify.
  eapply H2.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  assumption.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  constructor.
  constructor.
Qed.

Lemma withInterference_parallel_step : forall shared private1 private2
                                              (invs : shared -> Prop)
                                              (sys1 : trsys (threaded_state shared private1))
                                              (sys2 : trsys (threaded_state shared private2))
                                              st st',
  (withInterference invs (parallel sys1 sys2)).(Step)^* st st'
  -> forall st1 st2,
      (forall st1', (withInterference invs sys1).(Step)^* st1 st1' -> invs st1'.(Shared))
      -> (forall st2', (withInterference invs sys2).(Step)^* st2 st2' -> invs st2'.(Shared))
      -> (withInterference invs sys1).(Step)^* st1
                                            {| Shared := st.(Shared);
                                               Private := fst st.(Private) |}
      -> (withInterference invs sys2).(Step)^* st2
                                            {| Shared := st.(Shared);
                                               Private := snd st.(Private) |}
      -> (withInterference invs sys2).(Step)^* st2
                                            {| Shared := st'.(Shared);
                                               Private := snd st'.(Private) |}.
Proof.
  induct 1; simplify.

  assumption.

  invert H; simplify.
  invert H5; simplify.

  apply IHtrc with (st1 := {| Shared := sh'; Private := pr1' |}).
  simplify.
  apply H1.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  assumption.
  assumption.
  constructor.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H1 with (st1' := {| Shared := sh'; Private := pr1' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  constructor.

  apply IHtrc with (st1 := {| Shared := sh'; Private := pr1 |}).
  simplify.
  apply H1.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H2 with (st2' := {| Shared := sh'; Private := pr2' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  constructor.
  eassumption.
  constructor.
  assumption.
  assumption.
  constructor.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  constructor.
  eassumption.
  constructor.

  apply IHtrc with (st1 := {| Shared := sh'; Private := fst pr |}).
  simplify.
  eapply H1.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  assumption.
  assumption.
  constructor.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  constructor.
Qed.

Theorem withInterference_parallel : forall shared private1 private2
                                           (invs : shared -> Prop)
                                           (sys1 : trsys (threaded_state shared private1))
                                           (sys2 : trsys (threaded_state shared private2)),
    invariantFor (withInterference invs sys1)
                 (fun st => invs st.(Shared))
    -> invariantFor (withInterference invs sys2)
                    (fun st => invs st.(Shared))
    -> invariantFor (withInterference invs (parallel sys1 sys2))
                    (fun st => invs st.(Shared)).
Proof.
  unfold invariantFor.
  simplify.
  invert H1.

  (* [assert P]: first prove proposition [P], then continue with it as a new
   *   hypothesis. *)
  assert ((withInterference invs sys1).(Step)^*
             {| Shared := sh; Private := pr1 |}
             {| Shared := s'.(Shared); Private := fst s'.(Private) |}).
  apply withInterference_parallel_init with (sys2 := sys2)
                                            (st := {| Shared := sh; Private := (pr1, pr2) |})
                                            (st2 := {| Shared := sh; Private := pr2 |});
    simplify; propositional.
  apply H in H1; propositional.
  apply H0 in H1; propositional.
  constructor.
  constructor.

  assert ((withInterference invs sys2).(Step)^*
             {| Shared := sh; Private := pr2 |}
             {| Shared := s'.(Shared); Private := snd s'.(Private) |}).
  apply withInterference_parallel_step with (sys1 := sys1)
                                            (st := {| Shared := sh; Private := (pr1, pr2) |})
                                            (st1 := {| Shared := sh; Private := pr1 |});
    simplify; propositional.
  apply H in H5; propositional.
  apply H0 in H5; propositional.
  constructor.
  constructor.

  apply H in H1; try assumption.
Qed.

Inductive twoadd_pc := ReadIt | Add3 | Add7 | WriteIt.

Definition twoadd_initial := { {| Shared := 0; Private := (ReadIt, 0) |} }.

Inductive twoadd_step : threaded_state nat (twoadd_pc * nat)
                        -> threaded_state nat (twoadd_pc * nat) -> Prop :=
| Step_ReadIt : forall g l,
  twoadd_step {| Shared := g; Private := (ReadIt, l) |}
              {| Shared := g; Private := (Add3, g) |}
| Step_Add3 : forall g l,
  twoadd_step {| Shared := g; Private := (Add3, l) |}
              {| Shared := g; Private := (Add7, 3 + l) |}
| Step_Add7 : forall g l,
  twoadd_step {| Shared := g; Private := (Add7, l) |}
              {| Shared := g; Private := (WriteIt, 7 + l) |}
| Step_WriteIt : forall g l,
  twoadd_step {| Shared := g; Private := (WriteIt, l) |}
              {| Shared := l; Private := (ReadIt, l) |}.

Definition twoadd_sys := {|
  Initial := twoadd_initial;
  Step := twoadd_step
|}.

(* Invariant to prove: the global variable is always even, again. *)
Definition twoadd_correct private (st : threaded_state nat private) :=
  isEven st.(Shared).

(* Here's an abstract version of the system where, much like before, we model
 * integers as Booleans, recording whether they are even or not. *)

Definition twoadd_ainitial := { {| Shared := true; Private := (ReadIt, true) |} }.

Inductive twoadd_astep : threaded_state bool (twoadd_pc * bool)
                        -> threaded_state bool (twoadd_pc * bool) -> Prop :=
| AStep_ReadIt : forall g l,
  twoadd_astep {| Shared := g; Private := (ReadIt, l) |}
               {| Shared := g; Private := (Add3, g) |}
| AStep_Add3 : forall g l,
  twoadd_astep {| Shared := g; Private := (Add3, l) |}
               {| Shared := g; Private := (Add7, negb l) |}
| AStep_Add7 : forall g l,
  twoadd_astep {| Shared := g; Private := (Add7, l) |}
               {| Shared := g; Private := (WriteIt, negb l) |}
| AStep_WriteIt : forall g l,
  twoadd_astep {| Shared := g; Private := (WriteIt, l) |}
               {| Shared := l; Private := (ReadIt, l) |}
| AStep_Someone_Made_It_Even : forall g pr,
  twoadd_astep {| Shared := g; Private := pr |}
               {| Shared := true; Private := pr |}.

Definition twoadd_asys := {|
  Initial := twoadd_ainitial;
  Step := twoadd_astep
|}.

(* Here's a simulation relation at the level of integers and their Boolean
 * counterparts. *)
Definition even_R (n : nat) (b : bool) :=
  isEven n <-> b = true.

(* A few unsurprising properties hold of [even_R]. *)

Lemma even_R_0 : even_R 0 true.
Proof.
  unfold even_R; propositional.
  constructor.
Qed.

Lemma even_R_forward : forall n, isEven n -> even_R n true.
Proof.
  unfold even_R; propositional.
Qed.

Lemma even_R_backward : forall n, even_R n true -> isEven n.
Proof.
  unfold even_R; propositional.
Qed.

Lemma even_R_add2 : forall n b,
  even_R n b
  -> even_R (S (S n)) b.
Proof.
  unfold even_R; propositional.
  invert H; propositional.
  constructor; assumption.
Qed.

(* The cases for evenness of an integer and its successor *)
Lemma isEven_decide : forall n,
  (isEven n /\ ~isEven (S n)) \/ (~isEven n /\ isEven (S n)).
Proof.
  induct n; simplify; propositional.

  left; propositional.
  constructor.
  invert H.

  right; propositional.
  constructor; assumption.

  left; propositional.
  invert H.
  propositional.
Qed.

Lemma even_R_add1 : forall n b,
  even_R n b
  -> even_R (S n) (negb b).
Proof.
  unfold even_R; simplify.
  assert ((isEven n /\ ~isEven (S n)) \/ (~isEven n /\ isEven (S n))).
  apply isEven_decide.
  cases b; simplify; propositional.
  equality.
  equality.
Qed.

(* Here's the top-level simulation relation for our choice of abstraction. *)
Inductive twoadd_R : threaded_state nat (twoadd_pc * nat)
                     -> threaded_state bool (twoadd_pc * bool) -> Prop :=
| Twoadd_R : forall pc gn ln gb lb,
  even_R gn gb
  -> even_R ln lb
  -> twoadd_R {| Shared := gn; Private := (pc, ln) |}
              {| Shared := gb; Private := (pc, lb) |}.

(* Step 1 of main proof: model-check an individual thread. *)
Lemma twoadd_ok :
  invariantFor (withInterference isEven twoadd_sys)
               (fun st => isEven (Shared st)).
Proof.
  eapply invariant_weaken.
  apply invariant_simulates with (sys2 := twoadd_asys) (R := twoadd_R).

  (* Boring simulation proof begins here. *)
  constructor; simplify.

  invert H.
  exists {| Shared := true; Private := (ReadIt, true) |}; propositional.
  constructor; propositional.
  apply even_R_0.
  apply even_R_0.
  constructor.
  equality.
  simplify.
  propositional.

  invert H0.
  invert H1.

  invert H.
  exists {| Shared := gb; Private := (Add3, gb) |}; propositional.
  constructor; propositional.
  constructor.

  invert H.
  exists {| Shared := gb; Private := (Add7, negb lb) |}; propositional.
  constructor; propositional.
  apply even_R_add2.
  apply even_R_add1.
  assumption.
  constructor.

  invert H.
  exists {| Shared := gb; Private := (WriteIt, negb lb) |}; propositional.
  constructor; propositional.
  repeat apply even_R_add2.
  apply even_R_add1.
  assumption.
  constructor.

  invert H.
  exists {| Shared := lb; Private := (ReadIt, lb) |}; propositional.
  constructor; propositional.
  constructor.

  invert H.
  exists {| Shared := true; Private := (pc0, lb) |}; propositional.
  constructor; propositional.
  apply even_R_forward.
  assumption.
  constructor.

  (* Now find an invariant automatically. *)
  model_check_infer.

  (* Now prove that the invariant implies the correctness condition. *)
  invert 1.
  invert H0.
  simplify.
  propositional.

  invert H0.
  apply even_R_backward.
  assumption.

  invert H1.
  apply even_R_backward.
  assumption.

  invert H0.
  apply even_R_backward.
  assumption.

  invert H1.
  apply even_R_backward.
  assumption.
Qed.

(* Step 2: lift that result to the two-thread system, with no new model
 * checking. *)
Theorem twoadd2_ok :
  invariantFor (parallel twoadd_sys twoadd_sys) (twoadd_correct (private := _)).
Proof.
  eapply invariant_weaken.
  eapply invariant_simulates.
  apply withInterference_abstracts.
  apply withInterference_parallel.
  apply twoadd_ok.
  apply twoadd_ok.

  unfold twoadd_correct.
  invert 1.
  assumption.
Qed.

(* In fact, this modularity technique is so powerful that we now get correctness
 * for any number of threads, "for free"!  Here's a tactic definition, which we
 * won't explain, but which is able to derive correctness for any number of
 * threads, just by repeating use of [withInterference_parallel] and
 * [twoadd_ok]. *)
Ltac twoadd := eapply invariant_weaken; [ eapply invariant_simulates; [
                                          apply withInterference_abstracts
                                          | repeat (apply withInterference_parallel
                                                    || apply twoadd_ok) ]
                                        | unfold twoadd_correct; invert 1; assumption ].

(* For instance, let's verify the three-thread version. *)
Theorem twoadd3_ok :
  invariantFor (parallel twoadd_sys (parallel twoadd_sys twoadd_sys)) (twoadd_correct (private := _)).
Proof.
  twoadd.
Qed.

(* To save us time defining versions with many threads, here's a recursive
 * function, creating exponentially many threads with respect to its
 * parameter. *)
Fixpoint manyadds_state (n : nat) : Type :=
  match n with
  | O => twoadd_pc * nat
  | S n' => manyadds_state n' * manyadds_state n'
  end%type.

Fixpoint manyadds (n : nat) : trsys (threaded_state nat (manyadds_state n)) :=
  match n with
  | O => twoadd_sys
  | S n' => parallel (manyadds n') (manyadds n')
  end.

(* Here are some examples of the systems we produce. *)
Eval simpl in manyadds 0.
Eval simpl in manyadds 1.
Eval simpl in manyadds 2.
Eval simpl in manyadds 3.

Theorem twoadd4_ok :
  invariantFor (manyadds 4) (twoadd_correct (private := _)).
Proof.
  twoadd.
Qed.

Theorem twoadd6_ok :
  invariantFor (manyadds 6) (twoadd_correct (private := _)).
Proof.
  twoadd.
Qed.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Commutativity_A.

Coq < Goal forall p q:Prop, (p \/ q) <-> (q \/ p).
1 subgoal

  ============================
   forall p q : Prop, p \/ q <-> q \/ p

Unnamed_thm < intros.
1 subgoal

  p : Prop
  q : Prop
  ============================
   p \/ q <-> q \/ p

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
tauto.

Unnamed_thm is defined

Coq <

*)

Section Commutativity_A.
Goal forall p q:Prop, (p \/ q) <-> (q \/ p).
intros.
tauto.
Qed.


Require Import Bool List Arith Nat.
Import ListNotations.
Require Import Mmx.ast_instructions Mmx.binary Mmx.association_list.

Require Import Mmx.ast_instructions.
Require Import Mmx.binary.

(* (* functions to encode decode instructions *) *)
(* (* TODO :: Here this function can't be call for immediate *) *)
(*=operand_to_bin *)
Definition operand_to_bin (o : operande) : option (list bool) :=
  match o with
    | imm_o (imm k) => n_bit 8 k
    | reg_o (reg k) => n_bit 8 k
  end.
(*=End *)
(*=operand_to_bin_double *)
Definition operand_to_bin_double (o : operande) : option (list bool) :=
  (*=End *)
  match o with
  | imm_o (imm k) => n_bit 16 k
  | reg_o (reg k) => n_bit 16 k
  end.

(* -----------------------------------now for instr_operande_t_n ----------------------------------*)
(*=operand_to_bin_hypothesis_reg *)
Lemma operand_to_bin_hypothesis_reg : forall (l : list bool) (r : register),
    operand_to_bin (reg_o r) = Some l -> reg (bit_n l) = r.
(*=End *)
Proof.
  intros.
  unfold operand_to_bin in H.
  destruct r.
  Search (n_bit).
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

(*=operand_to_bin_hypothesis_imm *)
Lemma operand_to_bin_hypothesis_imm : forall (l : list bool) (i : imediate),
    operand_to_bin (imm_o i) = Some l -> imm (bit_n l) = i.
(*=End *)
Proof.
  intros.
  unfold operand_to_bin in H.
  destruct i.
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

Lemma operand_to_bin_double_hypothesis_reg : forall (l : list bool) (r : register),
    operand_to_bin_double (reg_o r) = Some l -> reg (bit_n l) = r.
Proof.
  intros.
  unfold operand_to_bin_double in H.
  destruct r.
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

Lemma operand_to_bin_double_hypothesis_imm : forall (l : list bool) (i : imediate),
    operand_to_bin_double (imm_o i) = Some l -> imm (bit_n l) = i.
Proof.
  intros.
  unfold operand_to_bin_double in H.
  destruct i.
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

(* -----------------------------------Other operand_to_bin lemma ----------------------------------*)
(*=operand_to_bin_size *)
Lemma operand_to_bin_size : forall (o : operande) (l : list bool),
    operand_to_bin o = Some l -> length l = 8.
(*=End *)
Proof.
  destruct o.
  -unfold operand_to_bin.
   intros l H.
   destruct i in H.
   apply size_n_bit in H.
   rewrite H.
   reflexivity.
   -unfold operand_to_bin.
    intros l H.
    destruct r in H.
    apply size_n_bit in H.
    rewrite H.
    reflexivity.
Qed.

Lemma operand_to_bin_double_size : forall (o : operande) (l : list bool),
    operand_to_bin_double o = Some l -> length l = 16.
Proof.
  destruct o.
  -unfold operand_to_bin.
   intros l H.
   destruct i in H.
   apply size_n_bit in H.
   rewrite H.
   reflexivity.
   -unfold operand_to_bin.
    intros l H.
    destruct r in H.
    apply size_n_bit in H.
    rewrite H.
    reflexivity.
Qed.

(* HERE i don't make any garantee about the result if the binary_instruction is to small but i will have some lemma to give it *)
(*=get_first_n_bit *)
Fixpoint get_first_n_bit  (bi : list bool) (size : nat) : (list bool*list bool) :=
  match size with
  | 0 => ([],bi)
  | S n => match bi with
           | h :: tl => match get_first_n_bit tl n with
                        | (l1,l2) => (h :: l1,l2)
                        end
           | [] => ([],[])
           end
  end.
(*=End *)
Definition testList := [true ; false ; true ; false ; false ; false ; true ; true ].
Definition testList' := [true ; false ; true].

Lemma get_first_n_bit_size_nil_n : forall (n : nat) (l : list bool), length l = n -> get_first_n_bit l n= (l,[]).
Proof.
  induction n.
  -intros.
   Search (length _ = 0).
   apply length_zero_iff_nil in H.
   rewrite H.
   reflexivity.
  -intros.
   unfold get_first_n_bit.
   destruct l.
   +reflexivity.
   +fold get_first_n_bit.
    assert (get_first_n_bit l n = (l,[])) by (apply IHn; auto).
    rewrite H0.
    reflexivity.
Qed.

Lemma get_first_n_bit_size_tl : forall  (n : nat) (l : list bool) (tl : list bool), length l = n -> get_first_n_bit (l ++ tl) n = (l,tl).
Proof.
  induction n.
  -intros.
   apply length_zero_iff_nil in H.
   rewrite H.
   simpl.
   destruct tl.
   +reflexivity.
   +reflexivity.
  -intros.
   unfold get_first_n_bit.
   destruct l.
   fold get_first_n_bit.
   +discriminate.
   +simpl.
    fold get_first_n_bit.
    assert (get_first_n_bit (l ++ tl) n = (l,tl)).
    {
      apply IHn.
      simpl in H.
      inversion H.
      reflexivity.
    }
    rewrite H0.
    reflexivity.
Qed.

Lemma get_first_n_bit_size_4 : forall (l1 l2 l3 l4 : list bool),
    length l1 = 8 -> get_first_n_bit (l1 ++ l2 ++ l3 ++ l4) 8 = (l1,l2 ++ l3 ++ l4).
Proof.
  intros.
  specialize (get_first_n_bit_size_tl 8 l1 (l2 ++ l3 ++ l4)).
  intros.
  auto.
Qed.

Lemma get_first_n_bit_size_3 : forall (n : nat) (l1 l2 l3 : list bool),
    length l1 = n -> get_first_n_bit (l1 ++ l2 ++ l3) n = (l1,l2 ++ l3).
Proof.
  intros.
  specialize (get_first_n_bit_size_tl n l1 (l2 ++ l3)).
  intros.
  auto.
Qed.

(* Lemma get_first_n_bit_size : forall (bi : list bool) (size : nat), n < (length bi) -> get_first_n_bit bi n = ( *)

(*=monade *)
Definition M A := option A.

Definition ret {A} (a : A) : M A := Some a.

Definition bind {A B} (ma : M A)(k : A -> M B): M B :=
  match ma with
  | Some a => k a
  | None => None
  end.
(*=End *)
Check bind.

Lemma ret_rewrite : forall (A : Type) (a : A), ret a = Some a.
Proof. intros. unfold ret. reflexivity. Qed.

Lemma bind_rewrite : forall (A B : Type) (ma : M A) (k : A -> M B) (res : B), bind ma k = Some res -> exists (a : A), k a = Some res /\ Some a = ma.
  intros.
  remember ma.
  destruct m.
  -exists a.
   split.
   +rewrite <- H.
    reflexivity.
   +reflexivity.
  -simpl in H.
   discriminate.
Qed.

(* TODO :: to delete but can't find this theorem so proof of it *)
Lemma commut_equal : forall (A : Type) (a b : A), a = b -> b = a.
Proof.
  intros. rewrite H. reflexivity. Qed.

(*=notation *)
Notation "'let!' x ':=' ma 'in' k" := (bind ma (fun x => k)) (at level 30).
(*=End *)

(* TODO :: here i know that i can always get a binary_instruction but some function don't allow me to  *)
(* return a binary_instruction without encapsulate it into an option type *)

(* theese are the encode functions for the different type of instruction *)
(*=encode_t_n *)
Definition encode_t_n (i : instruction_tern_n) : option binary_instruction :=
  let! k := lookup (tag_t_n (i.(instr_opcode_t_n))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_n)) in
  let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_n)) in
  let! o3 := operand_to_bin (reg_o i.(instr_operande3_t_n)) in
  ret (code ++ o1 ++ o2 ++ o3).
(*=End *)
Definition encode_t_i (i : instruction_tern_i) : option binary_instruction :=
  let! k := lookup (tag_t_i (i.(instr_opcode_t_i))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_i)) in
  let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_i)) in
  let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i)) in
  ret (code ++ o1 ++ o2 ++ o3).
Definition encode_t_i2 (i : instruction_tern_i2) : option binary_instruction :=
  let! k := lookup (tag_t_i2 (i.(instr_opcode_t_i2))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_i2)) in
  let! o2 := operand_to_bin (imm_o i.(instr_operande2_t_i2)) in
  let! o3 := operand_to_bin (reg_o i.(instr_operande3_t_i2)) in
  ret (code ++ o1 ++ o2 ++ o3).
Definition encode_t_i3 (i : instruction_tern_i3) : option binary_instruction :=
  let! k := lookup (tag_t_i3 (i.(instr_opcode_t_i3))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (imm_o i.(instr_operande1_t_i3)) in
  let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_i3)) in
  let! o3 := operand_to_bin (reg_o i.(instr_operande3_t_i3)) in
  ret (code ++ o1 ++ o2 ++ o3).

Definition encode_t_i4 (i : instruction_tern_i4) : option binary_instruction :=
  let! k := lookup (tag_t_i4 (i.(instr_opcode_t_i4))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_i4)) in
  let! o2 := operand_to_bin (imm_o i.(instr_operande2_t_i4)) in
  let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i4)) in
  ret (code ++ o1 ++ o2 ++ o3).

Definition encode_t_i5 (i : instruction_tern_i5) : option binary_instruction :=
  let! k := lookup (tag_t_i5 (i.(instr_opcode_t_i5))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (imm_o i.(instr_operande1_t_i5)) in
  let! o2 := operand_to_bin (imm_o i.(instr_operande2_t_i5)) in
  let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i5)) in
  ret (code ++ o1 ++ o2 ++ o3).

Definition encode_t_i6 (i : instruction_tern_i6) : option binary_instruction :=
  let! k := lookup (tag_t_i6 (i.(instr_opcode_t_i6))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (imm_o i.(instr_operande1_t_i6)) in
  let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_i6)) in
  let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i6)) in
  ret (code ++ o1 ++ o2 ++ o3).

Definition encode_d_n (i : instruction_duo_n) : option binary_instruction :=
  let! k := lookup (tag_d_n (i.(instr_opcode_d_n))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_d_n)) in
  let! o2 := operand_to_bin_double (reg_o i.(instr_operande2_d_n)) in
  ret (code ++ o1 ++ o2).

Definition encode_d_i (i : instruction_duo_i) : option binary_instruction :=
  let! k := lookup (tag_d_i (i.(instr_opcode_d_i))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_d_i)) in
  let! o2 := operand_to_bin_double (imm_o i.(instr_operande2_d_i)) in
  ret (code ++ o1 ++ o2).

Definition encode_d_i2 (i : instruction_duo_i2) : option binary_instruction :=
  let! k := lookup (tag_d_i2 (i.(instr_opcode_d_i2))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (imm_o i.(instr_operande1_d_i2)) in
  let! o2 := operand_to_bin_double (reg_o i.(instr_operande2_d_i2)) in
  ret (code ++ o1 ++ o2).

Definition encode_d_i3 (i : instruction_duo_i3) : option binary_instruction :=
  let! k := lookup (tag_d_i3 (i.(instr_opcode_d_i3))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (imm_o i.(instr_operande1_d_i3)) in
  let! o2 := operand_to_bin_double (imm_o i.(instr_operande2_d_i3)) in
  ret (code ++ o1 ++ o2).

Definition encode_u (i : instruction_uno) : option binary_instruction :=
  let! k := lookup (tag_u (i.(instr_opcode_s))) encdec in
  let! code := n_bit 8 k in
  match (i.(instr_operande)) with
  | imm im => let! o := n_bit 24 im in
              ret (code ++ o)
  end.

(* now the general encode function which take a general instruction *)

(*=encode *)
Definition encode (i : instruction) : option binary_instruction :=
  match i with
  | instr_t_n t => encode_t_n t
  | instr_t_i t => encode_t_i t
  | instr_t_i2 t => encode_t_i2 t
  | instr_t_i3 t => encode_t_i3 t
  | instr_t_i4 t => encode_t_i4 t
  | instr_t_i5 t => encode_t_i5 t
  | instr_t_i6 t => encode_t_i6 t
  | instr_d_n t => encode_d_n t
  | instr_d_i t => encode_d_i t
  | instr_d_n2 t => encode_d_i2 t
  | instr_d_n3 t => encode_d_i3 t
  | instr_u t => encode_u t
  end.
(*=End *)

(* this is the decode function (with this one we only need one general function) *)
(*=decode *)
Definition decode (bi : binary_instruction) : option instruction :=
  if length bi =? 32
  then
  match get_first_n_bit bi 8 with
  | (li,next) => let! t := lookdown (bit_n li) encdec in
                 match t with
                 | tag_u u =>
                   match get_first_n_bit next 24 with
                   | (op,[]) =>
                     ret (instr_u (mk_instr_uno u (imm (bit_n op))))
                   | _ => None
                   end
(*=End *)
                          | tag_t_n tn =>
                            match get_first_n_bit next 8 with
                            | (op1,next) =>match get_first_n_bit next 8 with
                                           | (op2,next) => match get_first_n_bit next 8 with
                                                           | (op3,[]) =>
                                                             ret (instr_t_n (mk_instr_t_n tn
                                                                                (reg (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (reg (bit_n op3))))
                                                           | _ => None
                                                           end
                                           end
                            end
                            | tag_t_i ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i (mk_instr_t_i ti
                                                                                (reg (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_t_i2 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                               | (op2,next) => match get_first_n_bit next 8 with
                                                               | (op3,[]) =>
                                                                 ret (instr_t_i2 (mk_instr_t_i2 ti
                                                                                (reg (bit_n op1))
                                                                                (imm (bit_n op2))
                                                                                (reg (bit_n op3))))
                                                               | _ => None
                                                               end
                                             end
                              end
                            | tag_t_i3 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i3 (mk_instr_t_i3 ti
                                                                                (imm (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (reg (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_t_i4 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i4 (mk_instr_t_i4 ti
                                                                                (reg (bit_n op1))
                                                                                (imm (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_t_i5 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i5 (mk_instr_t_i5 ti
                                                                                (imm (bit_n op1))
                                                                                (imm (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_t_i6 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i6 (mk_instr_t_i6 ti
                                                                                (imm (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_d_i di =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_i (mk_instr_d_i di
                                                                            (reg (bit_n op1))
                                                                            (imm (bit_n op2))))
                                             | _ => None
                                             end
                              end
                            | tag_d_i2 di =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_n2 (mk_instr_d_i2 di
                                                                              (imm (bit_n op1))
                                                                              (reg (bit_n op2))))
                                             | _ => None
                                             end
                              end
                            | tag_d_i3 di =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_n3 (mk_instr_d_i3 di
                                                                              (imm (bit_n op1))
                                                                              (imm (bit_n op2))))
                                             | _ => None
                                             end
                              end
                            | tag_d_n dn =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_n (mk_instr_d_n dn
                                                                            (reg (bit_n op1))
                                                                            (reg (bit_n op2))))
                                             | _ => None
                                             end
                              end
                          end
  end
  else None.

(* little test (this is the end of the file) *)

(* flux d'instruction il faut faire une fonction qui decode le debut de la liste et retourne la suite de la liste *)
Print fold_right.

(* flux d'instruction il faut faire une fonction qui decode le debut de la liste et retourne la suite de la liste *)
Print fold_right.
(*=cut_32 *)
Fixpoint cut32_n (n : nat) (l : list bool) : (list (list bool)) :=
  match n with
  | 0 => []
  | S n' => (firstn 32 l) :: (cut32_n n' (skipn 32 l))
  end.

Definition cut32 (l : list bool) : option (list (list bool)) :=
  let n := length l in
  if n mod 32 =? 0 then Some (cut32_n (n / 32) l) else None.
(*=End *)

(* i make the option choice because it's easyer for the proof *)
(*=concat_listes_32 *)
Fixpoint concat_listes_32 (l : list (list bool)) : option (list bool) :=
  match l with
  | [] => Some []
  | h :: tl => let! res := concat_listes_32 tl in
               if length h =? 32 then Some (h ++ res)
               else None
end.
(*=End *)

Definition test_liste := [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true].
Compute length test_liste.
Definition test_liste2 := [false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false].
Compute length test_liste2.

Fixpoint check_length_32 (l : list (list bool)) : bool :=
  match l with
  | [] => true
  | l' :: tl => (length l' =? 32) && check_length_32 tl
  end.

(* other way to define encode_flux*)
(*=traverse *)
Fixpoint traverse {A} (l : list (option A)) : option (list A) :=
  match l with
  | [] => Some []
  | (Some e) :: tl => match traverse tl with
                      | Some l => Some (e :: l)
                      | None => None
                      end
  | None :: _ => None
  end.
(*=End *)
(* encode_flux definitions *)
(*=encode_flux *)
Definition encode_flux_opt
   (li : list instruction) : list (option binary_instruction) :=
  map encode li.
Definition encode_flux
   (li : list instruction) : option (list binary_instruction) :=
  traverse (encode_flux_opt li).

Definition encode_flux_b (li : list instruction) : option (list bool) :=
  match encode_flux li with
  | None => None
  | Some res => concat_listes_32 res
  end.
(*=End *)

(*=decode_flux *)
Definition decode_flux_opt (lbi : list binary_instruction) : list (option instruction) :=
  map decode lbi.
Definition decode_flux_decoup (lbi : list binary_instruction) : option (list instruction) :=
  traverse (decode_flux_opt lbi).
Definition decode_flux (lb : list bool) : option (list instruction) :=
  let! lbi := cut32 lb in
  decode_flux_decoup lbi.
(*=End *)

(* Some little tests about encode and decode_flux *)

Definition my_instr := instr_t_n (mk_instr_t_n AND (reg 10) (reg 11) (reg 12)).
Definition my_instr2 := instr_t_n (mk_instr_t_n ADD (reg 1) (reg 2) (reg 3)).
Definition my_instr_liste := [my_instr;my_instr;my_instr;my_instr2].

Compute traverse (encode_flux_opt my_instr_liste).

Definition my_instr_list_encoded_decoded' := match encode_flux my_instr_liste with
                                      | Some lol => decode_flux_decoup lol
                                      | None => None
                                            end.
Compute my_instr_list_encoded_decoded'.

Definition my_instr_list_encoded_decoded := match encode_flux_b my_instr_liste with
                                      | Some lol => decode_flux lol
                                      | None => None
                                             end.
Compute my_instr_list_encoded_decoded.
(* it seem's to work *)


Require Export SystemFR.Judgments.
Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.EquivalentStar.
Require Export SystemFR.TermListReducible.
Require Export SystemFR.SubstitutionErase.

Lemma annotated_equivalent_refl:
   forall Θ Γ t,
     is_erased_term t ->
     wf t 0 ->
     subset (fv t) (support Γ) ->
    [[ Θ; Γ ⊨ t ≡ t ]].
Proof.
  unfold open_equivalent; repeat step;
    eauto using equivalent_refl with erased wf fv.

  apply equivalent_refl; eauto with erased wf fv.
  apply fv_nils2; repeat step || t_subset_erase || t_termlist;
    side_conditions;
    try solve [ rewrite_any; auto ].
Qed.

Lemma annotated_equivalent_trans:
  forall Θ Γ t1 t2 t3,
    [[ Θ; Γ ⊨ t1 ≡ t2 ]] ->
    [[ Θ; Γ ⊨ t2 ≡ t3 ]] ->
    [[ Θ; Γ ⊨ t1 ≡ t3 ]].
Proof.
  unfold open_equivalent; steps;
    eauto using equivalent_trans.
Qed.

Lemma annotated_equivalent_sym:
  forall Θ Γ t1 t2,
    [[ Θ; Γ ⊨ t1 ≡ t2 ]] ->
    [[ Θ; Γ ⊨ t2 ≡ t1 ]].
Proof.
  unfold open_equivalent; steps;
    eauto using equivalent_sym.
Qed.


(** the Set version of IWT *)
Section IWTS.

Variable A:Set.

Variable I:Set.

(* each member of B denotes one recursive occurrence in the constructor.
Only the cardinality matters *)
Variable B: A -> Set.

(* the index for the conclusion *)
Variable AI: A -> I.

(* the index for each recursive occurrence in B *)
Variable BI: forall a, B a -> I.

Inductive IWT : I ->Set :=
iwt : forall (a:A), (forall (b:B a), IWT (BI a b)) -> IWT (AI a).

Definition getA (i: I) (t : IWT i) : A :=
match t with
iwt a  _ => a
end.

End IWTS.
Check iwt.

(* Parametricity Recursive IWT. *)

Inductive IWT_R (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Set) (I₁ I₂ : Set) (I_R : I₁ -> I₂ -> Set)
(B₁ : A₁ -> Set) (B₂ : A₂ -> Set)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Set)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
  : forall (H : I₁) (H0 : I₂),
    I_R H H0 -> IWT A₁ I₁ B₁ AI₁ BI₁ H -> IWT A₂ I₂ B₂ AI₂ BI₂ H0 -> Prop :=
    IWT_R_iwt_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂)
                    (H : forall b : B₁ a₁, IWT A₁ I₁ B₁ AI₁ BI₁ (BI₁ a₁ b))
                    (H0 : forall b : B₂ a₂, IWT A₂ I₂ B₂ AI₂ BI₂ (BI₂ a₂ b)),
                  (forall (b₁ : B₁ a₁) (b₂ : B₂ a₂) (b_R : B_R a₁ a₂ a_R b₁ b₂),
                   IWT_R A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
                     (BI₁ a₁ b₁) (BI₂ a₂ b₂) (BI_R a₁ a₂ a_R b₁ b₂ b_R)
                     (H b₁) (H0 b₂)) ->
                  IWT_R A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
                    (AI₁ a₁) (AI₂ a₂) (AI_R a₁ a₂ a_R) (iwt A₁ I₁ B₁ AI₁ BI₁ a₁ H)
                    (iwt A₂ I₂ B₂ AI₂ BI₂ a₂ H0).

Definition IWT_RC :=
      fix
       ReflParam_matchR_IWT_RR0 (A A₂ : Set) (A_R : A -> A₂ -> Prop)
                                (I I₂ : Set) (I_R : I -> I₂ -> Prop)
                                (B : A -> Set) (B₂ : A₂ -> Set)
                                (B_R : forall (a1 : A) (a2 : A₂),
                                       A_R a1 a2 -> B a1 -> B₂ a2 -> Prop)
                                (AI : A -> I) (AI₂ : A₂ -> I₂)
                                (AI_R : forall (a1 : A) (a2 : A₂),
                                        A_R a1 a2 -> I_R (AI a1) (AI₂ a2))
                                (BI : forall a : A, B a -> I)
                                (BI₂ : forall a₂ : A₂, B₂ a₂ -> I₂)
                                (BI_R : forall (a1 : A) (a2 : A₂)
                                          (p : A_R a1 a2) (a3 : B a1)
                                          (a4 : B₂ a2),
                                        B_R a1 a2 p a3 a4 -> I_R (BI a1 a3) (BI₂ a2 a4))
                                (H : I) (H0 : I₂) (H1 : I_R H H0)
                                (H2 : IWT A I B AI BI H) (H3 : IWT A₂ I₂ B₂ AI₂ BI₂ H0)
                                {struct H2} : Prop :=
          let reT i1 i2 := forall (ir : I_R i1 i2), Prop in
         (match H2 as iwt1 in IWT _ _ _ _ _ i1 return reT i1 H0
         with
         | iwt _ _ _ _ _ a x =>
             match H3 as iwt2 in IWT _ _ _ _ _ i2 return reT (AI a) i2
             with
             | iwt _ _ _ _ _ a₂ x0 =>
              fun ir =>
                 {a_R : A_R a a₂ &
                 {_
                 : forall (a1 : B a) (a2 : B₂ a₂) (p : B_R a a₂ a_R a1 a2),
                   ReflParam_matchR_IWT_RR0 A A₂ A_R I I₂ I_R B B₂ B_R AI AI₂ AI_R BI BI₂
                     BI_R (BI a a1) (BI₂ a₂ a2) (BI_R a a₂ a_R a1 a2 p)
                     (x a1) (x0 a2) & (ir=(AI_R a a₂ a_R))}}
             end
          end) H1.

Section ToFrom.

Variables (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (I₁ I₂ : Set) (I_R : I₁ -> I₂ -> Prop)
(B₁ : A₁ -> Set) (B₂ : A₂ -> Set)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Prop)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
(i1 : I₁) (i2 : I₂) (ir : I_R i1 i2)
(i1wt : IWT A₁ I₁ B₁ AI₁ BI₁ i1) (i2wt : IWT A₂ I₂ B₂ AI₂ BI₂ i2).

Definition toNew
  (p: IWT_R _ _ A_R _ _ I_R _ _ B_R _ _ AI_R _ _ BI_R _ _ ir i1wt i2wt):
  IWT_RC  _ _ A_R _ _ I_R _ _ B_R _ _ AI_R _ _ BI_R _ _ ir i1wt i2wt.
Proof using.
  induction p.
  simpl. eexists. eexists. apply H2. reflexivity.
Defined.

Definition fromNew
  (p: IWT_RC _ _ A_R _ _ I_R _ _ B_R _ _ AI_R _ _ BI_R _ _ ir i1wt i2wt):
  IWT_R  _ _ A_R _ _ I_R _ _ B_R _ _ AI_R _ _ BI_R _ _ ir i1wt i2wt.
Proof using.
 rename i1wt into i1wtt. (* section vars don't go away even after destructing *)
 rename i2wt into i2wtt.
 revert p.
 revert i2wtt.
 revert ir.
 revert i2.
 induction i1wtt as [a1 f Hind].
 intros ? ? ?. destruct i2wtt. simpl in *.
 intros p. destruct p as [ar pp].
 destruct pp as [pp pp2].
 subst.
 apply IWT_R_iwt_R.
 Fail exact pp.
 intros.
 apply Hind.
 apply pp.
Defined.

End ToFrom.

Section Iso.

Require Import FunctionalExtensionality.

(* NEEDS functional extensionality. the constructor stores a function from Bs to
IWTs. while proving id, two functions need to be equal. *)
Lemma toNew_fromNew_id
(A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (I₁ I₂ : Set) (I_R : I₁ -> I₂ -> Prop)
(B₁ : A₁ -> Set) (B₂ : A₂ -> Set)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Prop)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
(i1 : I₁) (i2 : I₂) (ir : I_R i1 i2)
(i1wt : IWT A₁ I₁ B₁ AI₁ BI₁ i1) (i2wt : IWT A₂ I₂ B₂ AI₂ BI₂ i2)
: forall (p: IWT_RC _ _ A_R _ _ I_R _ _ B_R _ _ AI_R _ _ BI_R _ _ ir i1wt i2wt),
  toNew _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
  (fromNew _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ p) = p.
Proof using.
 revert i2wt. (* during the induction, i2wt also changes. so we need that to be general *)
 revert ir.
 revert i2.
 induction i1wt.
 simpl.
 intros ? ? ?. destruct i2wt. simpl in *.
 intros p. destruct p as [ar pp].
 destruct pp as [pp pp2].
 subst. simpl.
 progress f_equal.
 progress f_equal.
 Fail progress f_equal.
 Fail apply H.
 apply FunctionalExtensionality.functional_extensionality_dep.
 intros.
 apply FunctionalExtensionality.functional_extensionality_dep.
 intros.
 apply FunctionalExtensionality.functional_extensionality_dep.
 intros ?.
 apply H.
Qed.

Scheme IWT_Rfull := Induction for IWT_R Sort Prop.

Lemma fromNew_toNew_id
(A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (I₁ I₂ : Set) (I_R : I₁ -> I₂ -> Prop)
(B₁ : A₁ -> Set) (B₂ : A₂ -> Set)
(B_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> B₁ H -> B₂ H0 -> Prop)
(AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
(AI_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (AI₁ H) (AI₂ H0))
(BI₁ : forall a : A₁, B₁ a -> I₁) (BI₂ : forall a : A₂, B₂ a -> I₂)
(BI_R : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁) (H0 : B₂ a₂),
        B_R a₁ a₂ a_R H H0 -> I_R (BI₁ a₁ H) (BI₂ a₂ H0))
(i1 : I₁) (i2 : I₂) (ir : I_R i1 i2)
(i1wt : IWT A₁ I₁ B₁ AI₁ BI₁ i1) (i2wt : IWT A₂ I₂ B₂ AI₂ BI₂ i2)
: forall (p: IWT_R _ _ A_R _ _ I_R _ _ B_R _ _ AI_R _ _ BI_R _ _ ir i1wt i2wt),
  fromNew _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
  (toNew _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ p) = p.
Proof using.
 intros p.
 induction p using IWT_Rfull.
 simpl. unfold eq_ind_r,  eq_ind, eq_rect. simpl.
 f_equal.
 apply FunctionalExtensionality.functional_extensionality_dep.
 intros.
 apply FunctionalExtensionality.functional_extensionality_dep.
 intros.
 apply FunctionalExtensionality.functional_extensionality_dep.
 intros. eauto.
Qed.

End Iso.

Print Assumptions fromNew.
(*
Closed under the global context
*)
Print Assumptions toNew.
(*
Closed under the global context
*)

(*
Definition iwt_RC
(A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop)
                                (I₁ I₂ : Set) (I_R : I₁ -> I₂ -> Prop)
                                (B₁ : A₁ -> Set) (B₂ : A₂ -> Set)
                                (B_R : forall (a1 : A₁) (a2 : A₂),
                                       A_R a1 a2 -> B₁ a1 -> B₂ a2 -> Prop)
                                (AI₁ : A₁ -> I₁) (AI₂ : A₂ -> I₂)
                                (AI_R : forall (a1 : A₁) (a2 : A₂),
                                        A_R a1 a2 -> I_R (AI₁ a1) (AI₂ a2))
                                (BI₁ : forall a : A₁, B₁ a -> I₁)
                                (BI₂ : forall a₂ : A₂, B₂ a₂ -> I₂)
                                (BI_R : forall (a1 : A₁) (a2 : A₂)
                                          (p : A_R a1 a2) (a3 : B₁ a1)
                                          (a4 : B₂ a2),
                                        B_R a1 a2 p a3 a4 -> I_R (BI₁ a1 a3) (BI₂ a2 a4))
                                        : forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂)
                    (H : forall b : B₁ a₁, IWT A₁ I₁ B₁ AI₁ BI₁ (BI₁ a₁ b))
                    (H0 : forall b : B₂ a₂, IWT A₂ I₂ B₂ AI₂ BI₂ (BI₂ a₂ b)),
                  (forall (b₁ : B₁ a₁) (b₂ : B₂ a₂) (b_R : B_R a₁ a₂ a_R b₁ b₂),
                   IWT_RC A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
                     (BI₁ a₁ b₁) (BI₂ a₂ b₂) (BI_R a₁ a₂ a_R b₁ b₂ b_R)
                     (H b₁) (H0 b₂)) ->
                  IWT_RC A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
                    (AI₁ a₁) (AI₂ a₂) (AI_R a₁ a₂ a_R) (iwt A₁ I₁ B₁ AI₁ BI₁ a₁ H)
                    (iwt A₂ I₂ B₂ AI₂ BI₂ a₂ H0).
Proof using.
  intros. simpl.
  exists a_R.
  exists H1.
  exact eq_refl.
Defined.
*)


Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.
Require Import Ring.

Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Field.
Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Util.Decidable. (* Crypto.Util.Notations. *)

From Circom Require Import Circom Default Util DSL Tuple ListUtil LibTactics Simplify.
From Circom Require Import Repr ReprZ.
From Circom.CircomLib Require Import Bitify Comparators.
From Circom.BigInt.Definition Require Import BigSub.
(* Circuit:
* https://github.com/yi-sun/circom-pairing/blob/master/circuits/bigint.circom
*)

Module BigSub.

Module B := Bitify.
Module D := DSL.
Module Cmp := Comparators.
Module RZU := ReprZUnsigned.
Module RZ := RZU.RZ.
Module R := Repr.

Local Open Scope list_scope.
Local Open Scope Z_scope.
Local Open Scope F_scope.
Local Open Scope circom_scope.
Local Open Scope tuple_scope.

Local Coercion Z.of_nat: nat >-> Z.
Local Coercion N.of_nat: nat >-> N.

Lemma F_to_Z_nonneg: forall (x: F), (0 <= ^x).
Proof. intros. apply F.to_Z_range. lia. Qed.

Ltac solve_to_Z := repeat (autorewrite with F_to_Z; simplify; try (simpl; lia)).
Ltac solve_to_Z' H := autorewrite with F_to_Z in H; simplify' H; try (simpl in H; lia).

Local Notation "a ?=? b" := ((a?) = (b?)) (at level 70).

Module ModSubThree.
Section ModSubThree.
Context {n: nat}.

Import Cmp R.

(*
// a - b - c
// assume a - b - c + 2**n >= 0
template ModSubThree(n) {
    assert(n + 2 <= 253);
    signal input a;
    signal input b;
    signal input c;
    assert(a - b - c + (1 << n) >= 0);
    signal output out;
    signal output borrow;
    signal b_plus_c;
    b_plus_c <== b + c;
    component lt = LessThan(n + 1);
    lt.in[0] <== a;
    lt.in[1] <== b_plus_c;
    borrow <== lt.out;
    out <== borrow * (1 << n) + a - b_plus_c;
}
*)

Local Notation "2" := (1 + 1: F).

Definition cons (a b c out borrow: F) :=
  exists (lt: @LessThan.t (S n)),
    let b_plus_c := b + c in
    lt.(LessThan._in) [0] = a /\
    lt.(LessThan._in) [1] = b_plus_c /\
    borrow = lt.(LessThan.out) /\
    out = borrow * 2^n + a - b_plus_c.

Record t : Type := {
  a: F; b: F; c: F;
  out: F; borrow: F;
  _cons: cons a b c out borrow;
}.

Theorem soundness: forall w,
  (* pre-conditions *)
  n + 2 <= C.k ->
  (* a and b are n-bits, i.e., <= 2^n-1 *)
  w.(a) | (n) ->
  w.(b) | (n) ->
  binary w.(c) ->
  (* post-conditions *)
  w.(out) = (w.(a)+w.(borrow) * 2^n) - w.(b) - w.(c) /\
  w.(out) | (n) /\
  binary w.(borrow) /\
  w.(borrow) = 1 ?=? w.(a) <q (w.(b)+w.(c)).
Proof.
  unwrap_C. intros w Hnk Ha Hb Hc.
  assert (Hnk_pow': (0 <= 4 * 2^n <= 2^C.k)). {
    replace 4 with (2^2)%Z by lia.
    rewrite <- Zpower_exp; try lia.
    split. lia.
    apply Zpow_facts.Zpower_le_monotone; lia.
  }
  destruct w as [a b c out borrow _cons].
  unfold cons in *. destruct _cons as [lt [H_in0 [H_in1 [H_borrow H_out]]]].
  cbn [ModSubThree.a ModSubThree.b ModSubThree.c ModSubThree.borrow ModSubThree.out] in *.

  apply in_range_binary in Hc.
  pose proof (F_to_Z_nonneg a).
  pose proof (F_to_Z_nonneg b).
  pose proof (F_to_Z_nonneg c).

  assert (lt_range_1: LessThan._in lt [0] <=z (2 ^ S n -1)). {
    rewrite H_in0. rewrite Ha. replace (2 ^ (S n))%Z with (2 ^ (n + 1))%Z.
    rewrite Zpower_exp;lia. lia.
  }
  assert (lt_range_2: LessThan._in lt [1] <=z (2 ^ S n -1)). {
    rewrite H_in1.
    replace (S n) with (n+1)%nat by lia.
    solve_to_Z.
  }
  destruct (LessThan.soundness lt) as [H_lt_b H_lt]; try lia.
  symmetry in H_borrow.
  rewrite H_in0, H_in1, H_out, H_borrow in *. clear H_in0 H_in1 H_out H_borrow.
  assert (0 <= ^ b  + ^ c  <= 2^n). {
    pose proof (F_to_Z_nonneg b). pose proof (F_to_Z_nonneg c). lia.
  }
  repeat split; intros; auto; destruct H_lt_b; subst borrow; split_dec; try fqsatz; try lia;
  autorewrite with F_to_Z in H_lt; simplify; try (simpl; lia);
  solve_to_Z.
Qed.

(* for default values. never used *)
Definition wgen : t. skip. Defined.

#[global] Instance ModSubThree_default : Default (ModSubThree.t) := { default := wgen }.

End ModSubThree.
End ModSubThree.

Module M := ModSubThree.

Section S.
Context {n k: nat}.

(* /*
Inputs:
    - BigInts a, b
    - Assume a >= b
Output:
    - BigInt out = a - b
    - underflow = how much is borrowed at the highest digit of subtraction, only nonzero if a < b
*/
template BigSub(n, k) {
    assert(n <= 252);
    signal input a[k];
    signal input b[k];
    signal output out[k];
    signal output underflow;

    component unit0 = ModSub(n);
    unit0.a <== a[0];
    unit0.b <== b[0];
    out[0] <== unit0.out;

    component unit[k - 1];
    for (var i = 1; i < k; i++) {
        unit[i - 1] = ModSubThree(n);
        unit[i - 1].a <== a[i];
        unit[i - 1].b <== b[i];
        if (i == 1) {
            unit[i - 1].c <== unit0.borrow;
        } else {
            unit[i - 1].c <== unit[i - 2].borrow;
        }
        out[i] <== unit[i - 1].out;
    }
    underflow <== unit[k - 2].borrow;
} *)

(* interpret a tuple of weights as representing a little-endian base-2^n number *)
Local Notation "[| xs |]" := (RZ.as_le n xs).
Local Notation "[\ xs \]" := (RZ.as_be n xs).

Definition cons (a b: tuple F k) (out: tuple F k) (underflow: F) :=
  exists (unit: tuple (@M.t n) k),
  D.iter (fun i _cons =>
    _cons /\
    unit [i].(M.a) = a [i] /\
    unit [i].(M.b) = b [i] /\
    (if (dec (i = 0%nat)) then
    unit [i].(M.c) = 0
    else
    unit [i].(M.c) = unit [i-1].(M.borrow)) /\
    out [i] = unit [i].(M.out)
    ) k True /\
  underflow = unit [k-1].(M.borrow).

Record t := {
  a: tuple F k;
  b: tuple F k;
  out: tuple F k;
  underflow: F;
  _cons: cons a b out underflow
}.

Ltac split_as_le xs i :=
  erewrite RZ.as_le_split_last' with (ws:=xs[:S i]) (i:=i);
  rewrite_length;
  try rewrite firstn_firstn; simplify;
  try rewrite firstn_nth by lia.

Lemma nth_0 {T} `{Default T}: forall (x: T), (x :: nil) ! 0 = x.
Proof.
  intro x.
  erewrite <- fold_nth with (d:=x);eauto.
Qed.

#[local]Hint Extern 10 (Forall _ (firstn _ _)) => apply Forall_firstn : core.
#[local]Hint Extern 10 => match goal with
  [ |- context[length _] ] => rewrite_length end : core.
#[local]Hint Extern 10 (Forall _ (skipn _ _)) => apply Forall_skipn : core.
#[local]Hint Extern 10 (Forall _ (rev _)) => apply Forall_rev : core.
#[local]Hint Extern 10 (Forall _ (_ :: _)) => constructor : core.
#[local]Hint Extern 2 (binary ?a) => left; fqsatz : core.
#[local]Hint Extern 2 (binary ?a) => right; fqsatz : core.
#[local]Hint Extern 10 (_ < _) => lia : core.
#[local]Hint Extern 10 (_ <= _) => lia : core.
#[local]Hint Extern 10 (_ > _) => lia : core.
#[local]Hint Extern 10 (_ >= _) => lia : core.
#[local]Hint Extern 10 (S _ = S _) => f_equal : core.

Ltac unfold_default_all :=
  unfold_default; repeat match goal with [ H:_ |- _] => progress unfold_default' H end.

Ltac fold_default_all :=
  fold_default; repeat match goal with [ H: _ |- _] => progress fold_default' H end.

Ltac simplify_all :=
  repeat match goal with [ H: _ |- _] => progress simplify' H end.

Ltac split_dec_f :=
  repeat match goal with
  | [H: context[dec (@eq F ?a ?b)] |- _ ] => destruct (dec (a=b))
  | [ |- context[dec (@eq F ?a ?b)] ] => destruct (dec (a=b))
  end.

Lemma F0_eq_0: ((0:F) <> (0:F) -> False). Proof. unwrap_C. intros. fqsatz. Qed.
Lemma F1_eq_1: ((1:F) <> (1:F) -> False). Proof. unwrap_C. intros. fqsatz. Qed.
Lemma F0_neq_1: (0:F) <> (1:F). Proof. unwrap_C. fqsatz. Qed.
Lemma F1_neq_0: (1:F) <> (0:F). Proof. unwrap_C. fqsatz. Qed.
(* light-weight fqsatz for 0/1 (in)equalities *)
Ltac solve_0_1 := (exfalso; solve [
      (apply F0_eq_0; auto) |
      (apply F1_eq_1; auto) |
      (apply F0_neq_1; auto) |
      (apply F1_neq_0; auto)]).

Lemma F_neq_to_Z_iff: forall x y,
  x <> y <-> ^x <> ^y.
Proof.
  split; intros; intro H'; apply F.eq_to_Z_iff in H'; auto.
Qed.

Theorem soundness: forall (w: t),
  (* pre-condition *)
  0 < n ->
  0 < k ->
  n + 2 <= C.k ->
  'w.(a) |: (n) ->
  'w.(b) |: (n) ->
  (* post-condition *)
  ([|' w.(out) |] = [|' w.(a) |] - [|' w.(b) |] + ^ w.(underflow)  * 2^(n*k))%Z /\
  'w.(out) |: (n) /\
  binary w.(underflow) /\
  (w.(underflow) = 1 ?=? ([|' w.(a) |] < [|' w.(b) |])).
Proof.
  unwrap_C.
  intros.
  assert (Hnk_pow': (0 <= 4 * 2^n <= 2^C.k)). {
    replace 4 with (2^2)%Z by lia.
    rewrite <- Zpower_exp; try lia.
    split. lia.
    apply Zpow_facts.Zpower_le_monotone; lia.
  }
  destruct w as [a b out underflow _cons].
  intros. cbn [S.out S.a S.b S.underflow] in *.
  unfold cons in _cons. destruct _cons as [unit prog].
  lift_to_list.
  rem_iter.
  pose proof (length_to_list a) as Hlen_a.
  pose proof (length_to_list b) as Hlen_b.
  pose proof (length_to_list out) as Hlen_out.
  pose proof (length_to_list unit) as Hlen_unit.

  destruct prog as [p_iter out_borrow].
  pose (Inv := fun (i: nat) (_cons: Prop) => _cons ->
    (* borrow bits are binary *)
    (forall (j: nat), j < i -> binary ('unit ! j).(M.borrow)) /\
    (forall (j: nat), j < i -> (('unit ! j).(M.borrow) = 1 ?=? ([|'a [:S j]|] < [|'b[:S j]|]))) /\
    (* out are in range *)
    'out [:i] |: (n) /\
    (* sub is ok for prefix *)
    [| 'out [:i] |]
      = ([| 'a [:i] |] + 2^(n*i)%nat * (if dec (i = 0)%nat then 0 else ^('unit ! (i-1)).(M.borrow)) -  [| 'b [:i] |])%Z).
  assert (HInv: Inv k (D.iter f k True)).
  apply D.iter_inv; unfold Inv; clear Inv.
  - intuit; try lia.
    + simpl. constructor.
    + simpl. simplify.
  - intros i _cons IH H_bound Hf.
    subst f. destruct Hf as [Hcons [Hai [Hbi [Hci Houti] ] ] ].
    lift_to_list.
    pose proof (M.soundness ('unit ! i )) as M0.
    assert (Hci': M.c ('unit!i) = if dec (i=0)%nat then 0 else M.borrow ('unit!(i-1)))
      by (destruct (dec (i=0)%nat); auto).
    symmetry in Houti.
    rewrite Hai, Hbi, Hci', Houti in *. clear Hai Hbi Hci Hci' Houti.
    destruct IH as [IH_bin [IH_borrow [IH_rng IH_eq]]]. auto.
    destruct M0 as [M_eq [M_rng [M_bin M_borrow]]].
    lia.
    unfold_default; apply Forall_nth; auto; lia.
    unfold_default; apply Forall_nth; auto; lia.
    destruct (dec (i=0%nat)); auto.
    destruct (dec (S i = 0%nat)). discriminate.
    split_as_le ('out) i. split_as_le ('a) i. split_as_le ('b) i.
    assert (0 <= ^'a!i <= 2^n-1)%Z. split. apply F_to_Z_nonneg. unfold_default. apply Forall_nth. auto. lia.
    assert (0 <= ^'b!i <= 2^n-1)%Z. split. apply F_to_Z_nonneg. unfold_default. apply Forall_nth. auto. lia.
    repeat split_and.
    + (* borrow *)
      intros.
      destruct (dec (j < i)). specialize (IH_bin j). intuit.
      assert (Hij: j=i) by lia. subst j. auto.
    + intros. destruct (dec (j < i)). specialize (IH_borrow j). auto.
      assert (j=i)%nat by lia. subst j.
      destruct (dec (i=0)%nat).
      (* i = 0 *)
      assert (i=0)%nat by lia. subst i.
      split_dec; auto;
      match goal with
      | [ H: context[firstn 1 _] |- _] =>
        exfalso;
        repeat erewrite firstn_1 in H by lia;
        fold_default' H;
        simpl in H;
        unfold RZ.ToZ.to_Z in H;
        simplify' H
      end;
      simplify_all.
      (* i > 0 *)
      assert (IH_pre: (i - 1)%nat < i) by lia.
      specialize (IH_borrow _ IH_pre).
      specialize (IH_bin _ IH_pre).
      replace (S(i-1))%nat with i in * by lia.

      remember (M.borrow (' unit ! (i)) ) as ci.
      remember (M.borrow (' unit ! (i - 1)) ) as ci'.
      destruct IH_bin as [Hci'|Hci'];
      destruct M_bin as [Hci|Hci]; rewrite Hci, Hci' in *;
      split_dec_f; try solve_0_1;
      split_dec; auto; exfalso;
      match goal with
      | [ H: context[firstn (S i) ?xs_] |- _ ] =>
        repeat erewrite firstn_S in H by lia;
        repeat rewrite RZ.le__rev_be, rev_unit in H;
        rewrite <- RZU.big_lt_dec in H; simpl; auto;
        simpl in H;
        split_dec; auto;
        fold_default_all;
        rewrite ?RZU.big_lt_dec with (n:=n%nat) in H; try auto;
        try do 2 rewrite <- ?RZ.le__rev_be in H; auto;
        try lia
      end;
      repeat match goal with
      | [ H: context[ 'b!i + _ ] |- _] => autorewrite with F_to_Z in H; try lia; solve_to_Z
      | [ H: 'a!i = 'b!i |- _ ] => apply F.eq_to_Z_iff in H
      | [ H: 'a!i <> 'b!i |- _ ] => apply F_neq_to_Z_iff in H
      end;
      try lia.
    + (* out[:i] |: (n) *)
      eapply Forall_firstn_S. rewrite_length. reflexivity.
      rewrite firstn_firstn. simplify. auto.
      rewrite firstn_nth by lia.
      fold_default.
    + clear n0.
      unfold RZ.ToZ.to_Z in *.
      destruct (dec (i=0%nat)).
      * (* case i = 0 *)
        rewrite e in *. simplify. clear IH_eq IH_bin IH_rng.
        repeat erewrite firstn_1; try lia.
        repeat (fold_default; rewrite nth_0).
        (* range proof *)
        assert (^'out!0 = (2^n * ^ M.borrow ('unit!0)  + ^'a!0) - ^'b!0)%Z. {
          apply f_equal with (f:=F.to_Z) in M_eq;
          destruct M_bin as [M_bin|M_bin]; rewrite M_bin in *; clear M_bin;
          simplify' M_eq; simplify;
          simplify' M_borrow; split_dec; try lia; try solve_0_1;
          solve_to_Z' M_eq; solve_to_Z.
          (* FIXME *)
          solve_to_Z' M_eq.
        }
        unfold RZ.ToZ.to_Z.
        destruct (dec (1=0)%nat). discriminate.
        nia.
      * (* i > 0 *)
        simplify.
        default_apply ltac:(repeat rewrite firstn_nth; try lia).
        (* range proof *)
        remember (M.borrow ('unit!i)) as ci.
        remember (M.borrow ('unit!(i-1))) as ci'.
        (* range proof *)
        assert (^'out!i = ^'a!i + 2^n * ^ ci - ^'b!i - ^ ci')%Z. {
          assert (ci'_bin': 0 <= ^ci' <= 1). {
            assert (ci'_bin: binary ci'). subst. apply IH_bin. lia.
            destruct ci'_bin as [H'|H']; rewrite H'; solve_to_Z.
          }
          apply f_equal with (f:=F.to_Z) in M_eq;
          destruct M_bin as [M_bin|M_bin]; rewrite M_bin in *; clear M_bin;
          simplify' M_eq; simplify;
          simplify' M_borrow;
          split_dec; try lia; try solve_0_1;
          match goal with
          | [ H: context[ 'b!i + _ ] |- _] => autorewrite with F_to_Z in H; try lia; solve_to_Z
          end;
          solve_to_Z' M_eq; solve_to_Z.
        }
        unfold RZ.ToZ.to_Z.
        destruct (dec (S i = 0)%nat). discriminate.
        nia.
  - unfold Inv in HInv.
    replace ('a) with ('a[:k]) by (applys_eq firstn_all; f_equal; lia).
    replace ('b) with ('b[:k]) by (applys_eq firstn_all; f_equal; lia).
    firstn_all.
    destruct (dec (k=0)%nat). lia.
    assert (H_out_inrange: ' out |: (n)) by intuit.
    intuit; specialize (H6 (k-1)%nat).
    * rewrite H10, out_borrow; auto. nia.
    * rewrite out_borrow. auto.
    * replace (S (k - 1)) with k in * by lia.
      rewrite out_borrow.
      firstn_all.
      split_dec; auto.
Unshelve. all:exact F.zero.
Qed.

Lemma soundness_ite: forall (w: t),
  (* pre-conditions *)
  0 < n ->
  0 < k ->
  n + 2 <= C.k ->
  'w.(a) |: (n) ->
  'w.(b) |: (n) ->
  (* post-conditions *)
  binary w.(underflow) /\
  'w.(out) |: (n) /\
  if dec ([|'w.(a)|] >= [|'w.(b)|]) then
    w.(underflow) = 0 /\
    ([|' w.(out) |] = [|' w.(a) |] - [|' w.(b) |])%Z
  else
    w.(underflow) = 1 /\
    ([|' w.(out) |] = 2^(n*k) * ^w.(underflow)  + [|' w.(a) |] - [|' w.(b) |])%Z
  .
Proof.
  intros.
  pose proof (soundness w).
  intuit.
  split_dec; intuit; try lia.
  destruct H6; intuit.
  destruct H6; intuit.
  rewrite H6 in H4.
  simplify' H4.
Qed.

End S.

End BigSub.


Require Import Ynot.
Require Import Ascii.
Require Import Stream.
Require Import Charset Parsec ParsecCombinators.
Require Import Arith.
Require Import String List.

Module Expressions.
  Import Combinators.
  Import ParsecNotation.

  (* A grammar for expressions that computes the result of evaluating the expression:
     expr := number | expr + expr | expr - expr *)
  Definition expr :=
    grec (fun V expr =>
              ws _ ^ number _ ^ ws _   @ (fun t => fst (snd t))
           ||| !!!!expr ^ #"+" ^ !!!!expr     @ (fun t => fst t + (snd (snd t)))
           ||| !!!!expr ^ #"-" ^ !!!!expr     @ (fun t => fst t - (snd (snd t))))%grammar.

  (* A parser for expressions *)
  Definition expr_p : parser_t expr.
    refine (gfix (fun (expr_p:parser_t expr) =>
                ws_p ^ number_p ^ ws_p @ (fun t => fst (snd t))
            ||| expr_p ^ #"+" ^ expr_p @ (fun t => fst t + (snd (snd t)))
            ||| expr_p ^ #"-" ^ expr_p @ (fun t => fst t - (snd (snd t))))%parser).
    repeat (unfold number, digits, digit, ws, gsatisfy ; gtac).
  Qed.

  Definition prefix :=
    grec (fun V expr =>
              ws _ ^ number _ ^ ws _      @ (fun t => fst (snd t))
           ||| #"+" ^ !!!!expr ^ !!!!expr @ (fun t => fst (snd t) + (snd (snd t)))
           ||| #"-" ^ !!!!expr ^ !!!!expr @ (fun t => fst (snd t) - (snd (snd t))))%grammar.

  (* A parser for expressions *)
  Definition prefix_p : parser_t prefix.
    refine (gfix (fun (expr_p:parser_t prefix) =>
               ws_p ^ number_p ^ ws_p  @ (fun t => fst (snd t))
            ||| #"+" ^ expr_p ^ expr_p @ (fun t => fst (snd t) + (snd (snd t)))
            ||| #"-" ^ expr_p ^ expr_p @ (fun t => fst (snd t) - (snd (snd t))))%parser).
    repeat (unfold number, digits, digit, ws, gsatisfy ; gtac).
  Qed.
End Expressions.


Require Import PPS.SOS.ABExp.
Require Import PPS.SOS.SOS.

Set Implicit Arguments.

Import SOS_Notation.

Section Example1.

  Definition P1 : S_ BExp AExp := 0 ::= ANum 1.

  Definition P2 : S_ BExp AExp :=
    If AVar 0 :<: ANum 42
       Then 0 ::= ANum 42 :+: AVar 0
       Else SSkip BExp AExp.

  Lemma isTerminatingP1 :
    terminating_computation aevalF bevalF P1 nil.
  Proof.
    unfold terminating_computation.
    exists 0.
    simpl.
    reflexivity.
  Qed.

  Lemma isNotTerminatingP2 :
    ~ terminating_computation aevalF bevalF P2 nil.
  Proof.
    unfold terminating_computation.
    intro H.
    destruct H.
    destruct x; simpl in H.
    - inversion H.
    - inversion H.
  Qed.

  Definition C2 : SOS_Context nat := cons (0, 31) nil.

  Lemma isTerminatingP2 :
    terminating_computation aevalF bevalF P2 C2.
  Proof.
    unfold terminating_computation.
    exists 1.
    simpl.
    reflexivity.
  Qed.

End Example1.
Section Example2.

  Definition P3 : S_ BExp AExp := 0 ::= ANum 42 :+: AVar 0.
  Definition C3 : SOS_Context nat := cons (0,73) nil.

  Notation "<| S , o |> --> <| S' , o' |>" := (stepR aevalR bevalR S o S' o').

  Definition Prop1 := <| P2, C2 |> -->
                      <| P3, C2 |>.
  Definition Prop2 := <| P3, C2 |> -->
                      <| SSkip BExp AExp, C3 |>.

  Example e : Prop1 /\ Prop2.
  Proof.
    split; unfold Prop1, Prop2.
    - unfold P2.
      apply StIfT.
      apply EvLess with (v1 := 31) (v2 := 42).
      * apply EvVar. reflexivity.
      * apply EvNum.
      * simpl. reflexivity.
    - unfold P3.
      apply StAss with (val := 73).
      apply EvPlus with (v1 := 42) (v2 := 31).
      * apply EvNum.
      * apply EvVar. unfold C2. reflexivity.
      * reflexivity.
  Qed.

End Example2.