(** * Extensible effects *)

(** Interface for extensible effects.

    This file contains the Subevent, Over, and Trigger typeclasses, which is a
    practical solution for handling sums of events for extensible effects.
    - [Subevent]: an isomorphism between event signatures
    - [Trigger]: operation for a minimal impure computation
    - [Over]: lifting of handlers over sums of events

    We characterize isomorphisms between _sums of events_, where we use
    typeclass resolution to infer the correct type-injections for the [over] and
    [trigger] combinators.

    Typeclass resolution is used for the automatic injection of handlers over large
    sums of events. *)

(* begin hide *)
From Coq Require Import
     Setoid Morphisms.

From ITree Require Import
     Basics.Basics
     Basics.CategoryOps
     Basics.CategoryTheory
     Basics.CategoryFacts
     Basics.Function
     Basics.FunctionFacts
     Core.ITreeDefinition
     Indexed.Sum
     Indexed.Function
     Indexed.FunctionFacts
     EqmR.EqmRMonadT.

From ExtLib Require Import
     Monad.

Import MonadNotation.
Import CatNotations.
Open Scope cat_scope.
Import ITree.Basics.Basics.Monads.

Set Implicit Arguments.
(* end hide *)

(** ** Subevents

  Subevents provide an isomorphism between event signatures. Instances of
  subevents can be used for automatically inferring whether or not an event
  signature is part of a large sum of events.

  The operator for sums is associative and commutative (which is formulated
  in Section [Subevent_Instances]). *)
Section Subevent.

  Class Subevent {A B C : Type -> Type} : Type := {
    split_E : B ~> A +' C ;
    merge_E : (A +' C) ~> B
  }.

  Class Subevent_wf {A B C} (sub: @Subevent A B C): Prop :=
    sub_iso :> Iso _ split_E merge_E.

  Arguments Subevent : clear implicits.
  Arguments split_E {_ _ _ _} [_].
  Arguments merge_E {_ _ _ _} [_].

  (** Injection and case analysis for events *)
  Definition inj1 {A B C} `{Subevent A B C} : A ~> B :=  inl_ >>> merge_E.
  Definition inj2 {A B C} `{Subevent A B C} : C ~> B :=  inr_ >>> merge_E.
  Definition case  {A B C} `{Subevent A B C} : B ~> (A +' C) := split_E.

End Subevent.

Arguments Subevent : clear implicits.
Arguments case {_ _ _ _} [_].
Arguments inj1 {_ _ _ _} [_].
Arguments inj2 {_ _ _ _} [_].

Notation "A +? C -< B" := (Subevent A B C)
                            (at level 89, left associativity) : type_scope.

(** ** Triggerable Monads

    A _trigger_ is defined as the "minimal" impure computation performing an
    uninterpreted event.

    For the case of ITrees, it corresponds to the [trigger] combinator, i.e.
    [trigger e := Vis e (fun x => x)]. We generalize this notion for any monad
    that can perform a minimal impure computation. *)
Section Trigger.

  (** The [Trigger M E] typeclass contains an operation that given
     an event [e] builds the "smallest" monadic value that executes [e]. *)
  Class Trigger (E: Type -> Type) (M: Type -> Type) := trigger: E ~> M.

End Trigger.

Arguments trigger {E M Trigger} [T].
Notation vis e k := (Vis (inj1 e) k).

(** *** Instances of Triggerable monads  *)
Section Trigger_Instances.

  (** The minimal [itree] that performs [e] is [Vis e (fun x => Ret x)], already
      defined as [ITree.trigger] *)
  #[global] Instance Trigger_ITree {E F G} `{E +? F -< G}: Trigger E (itree G) :=
    fun _ e => ITree.trigger (inj1 e).

  (** We allow to look for the inclusion by commuting the two arguments.
      By doing it only at this level it's a cheap way to explore both options
      while avoiding looping resolutions *)
  #[global] Instance Trigger_ITree_base {E} : Trigger E (itree E) :=
    fun _ e => ITree.trigger e.

  (** Monad transformers with ITrees as a base monad are triggerable. *)
  #[global] Instance Trigger_MonadT {E F G} `{E +? F -< G}
            {T : (Type -> Type) -> Type -> Type} {T_MonadT: MonadT T} : Trigger E (T (itree G)) :=
    (fun X e => lift (trigger e)).

  (** The [PropT] transformer returns the propositional singleton of the
    underlying trigger. However, we might want this singleton to be up to some equivalence *)
  #[global] Instance Trigger_Prop {E} {M} `{Monad M} `{Trigger E M} :
    Trigger E (fun X => M X -> Prop) :=
    (fun T e m => m = (trigger e)).

End Trigger_Instances.

(** ** Over: injection for handlers over sums of events

   Generic lifting of an handler over a super-set of events. The function relies
   on the constraint [A +? C -< B] to know how to case analyse on a [B] event. *)
Definition over {A B C M : Type -> Type} {S:A +? C -< B} {T:Trigger C M} (f : A ~> M) : B ~> M  :=
  fun t b =>  match case b with
           | inl1 a => f _ a
           | inr1 c => trigger c
           end.

Arguments over {_ _ _ _ _ _} _ [_] _.

(** A few auxiliary lemmas for injection. *)
Lemma case_inj1: forall {A B C: Type -> Type} `{Sub: A +? C -< B} {SubWF: Subevent_wf Sub} {T} (e: A T),
    case (inj1 e) = inl_ _ e.
Proof.
  intros.
  pose proof (iso_epi IFun T (inl_ _ e)).
  auto.
Qed.

Lemma case_inj2: forall {A B C: Type -> Type} `{Sub: A +? C -< B} {SubWF: Subevent_wf Sub} {T} (e: C T),
    case (inj2 e) = inr_ _ e.
Proof.
  intros.
  pose proof (iso_epi IFun T (inr_ _ e)).
  auto.
Qed.

Lemma over_inj1: forall {A B C M: Type -> Type}
                   {Sub: A +? C -< B} {SubWF: Subevent_wf Sub} {Trig: Trigger C M}
                   (h: A ~> M)
                   {T} (e: A T),
    over h (inj1 e) = h _ e.
Proof.
  intros.
  unfold over; rewrite case_inj1; reflexivity.
Qed.

Lemma over_inj2: forall {A B C M: Type -> Type}
                   {Sub: A +? C -< B} {SubWF: Subevent_wf Sub} {Trig: Trigger C M}
                   (h: A ~> M)
                   {T} (e: C T),
    over h (inj2 e) = trigger e.
Proof.
  intros.
  unfold over; rewrite case_inj2; reflexivity.
Qed.

(** ** Instances for Automatic Injection

    We characterize the algebraic properties of the abstract sum operation [+?]
    for automatically injecting the handlers over a sum of events.

    The rules are as follows:
    [void1] is the unital operator, and the [+?] operation is associative and
    coummutative.

    Each of the instances come with a proof of isomorphism, thus guaranteeing
    soundness of inference. *)
Section Subevent_Instances.

    Class CUnit : Type := CUnitC {}.
    Global Instance cUnit: CUnit := CUnitC.

    (** *** Event level instances *)
    (* The subeffect relationship is reflexive: [A -<  A] *)
    #[local] Instance Subevent_refl `{CUnit} {A : Type -> Type} : A +? void1 -< A :=
      {| split_E := inl_: IFun _ _
         ; merge_E := unit_r: IFun _ _
      |}.

    #[global] Instance Subevent_void `{CUnit} {A : Type -> Type} : void1 +? A -< A :=
      {| split_E := inr_: IFun _ _
         ; merge_E := unit_l: IFun _ _
      |}.

    (* Extends the domain to the left: [A -< B -> C +' A -< C +' B] *)
    #[local] Instance Subevent_Sum_In `{CUnit} {A B C D: Type -> Type} `{A +? D -< B} : (C +' A) +? D -< C +' B :=
      {|
        split_E := case_ (inl_ >>> inl_) (split_E >>> bimap inr_ (id_ _));
        merge_E := assoc_r >>> bimap (id_ _) merge_E
      |}.

    #[local] Instance Subevent_Sum_Out `{CUnit} {A B C D: Type -> Type}
             `{A +? D -< B} : A +? C +' D -< C +' B :=
      {|
        split_E := case_ (inl_ >>> inr_) (split_E >>> bimap (id_ _) inr_)
        ; merge_E := case_ (inl_ >>> merge_E >>> inr_) (bimap (id_ _) (inr_ >>> merge_E))
      |}.

    #[local] Instance Subevent_Base `{CUnit} {A B}: A +? B -< A +' B :=
      {|
        split_E := id_ _;
        merge_E := id_ _
      |}.

    #[local] Instance Subevent_to_complement `{CUnit} {A B C E} `{A +' B +? C -< E}: A +? B +' C -< E :=
      {|
        split_E := split_E >>> assoc_r;
        merge_E := assoc_l >>> merge_E
      |}.

    (** Associativity of subevents *)
    #[local] Instance Subevent_Assoc1 `{CUnit} {A B C D E: Type -> Type} `{Subevent (A +' (B +' C)) D E} : Subevent ((A +' B) +' C) D E :=
      {| split_E := split_E >>> case_ (assoc_l >>> inl_) inr_
         ; merge_E := bimap assoc_r (id_ _) >>> merge_E
      |}.

    #[local] Instance Subevent_Assoc2 `{CUnit} {A B C D E: Type -> Type}
      `{A +? E -< (B +' (C +' D))}: A +? E -< ((B +' C) +' D) :=
        {| split_E := assoc_r >>> split_E
           ; merge_E := merge_E >>> assoc_l
        |}.

    #[local] Instance Subevent_Assoc3 `{CUnit} {A B C D E: Type -> Type}
       `{A +? (B +' (C +' D)) -< E} : A +? ((B +' C) +' D) -< E :=
      {| split_E := split_E >>> (bimap (id_ _) assoc_l)
          ; merge_E := (bimap (id_ _) assoc_r) >>> merge_E
      |}.

    (** Other instances that are useful for efficient resolution. *)
    #[local] Instance Subevent_forget_order `{CUnit}
             {E C1 C2 A B}
             {Sub1: A +? C1 -< E}
             {Sub2: B +? C2 -< C1}:
      Subevent B E (A +' C2) :=
      {| split_E := split_E >>> case_
                            (inl_ >>> inr_)
                            (split_E >>> case_
                                     inl_
                                     (inr_ >>> inr_))
         ; merge_E := case_
                        (inl_ >>> merge_E >>> inr_ >>> merge_E)
                        (case_
                           (inl_ >>> merge_E)
                           (inr_ >>> merge_E >>> inr_ >>> merge_E))
      |}.

    #[local] Instance Subevent_forget_order_wf
             `{CUnit}
             {E C1 C2 A B}
             {Sub1: A +? C1 -< E}
             {Sub2: B +? C2 -< C1}
             {Sub1WF: Subevent_wf Sub1}
             {Sub2WF: Subevent_wf Sub2}
      : Subevent_wf (@Subevent_forget_order _ _ _ _ _ _ Sub1 Sub2).
    Proof.
      split.
      - cbn.
        unfold SemiIso.
        rewrite cat_assoc, cat_case.
        rewrite cat_assoc, case_inr, case_inl.
        rewrite cat_assoc, cat_case.
        rewrite cat_assoc, case_inl.
        rewrite (cat_assoc inr_ inr_), 2 case_inr.
        (* Can we avoid this mess? *)
        unfold cat, Cat_IFun, case_, Case_sum1, case_sum1, inl_, Inl_sum1, inr_, Inr_sum1, id_, Id_IFun.
        intros ? e.
        generalize (iso_mono _ (Iso := sub_iso) _ e); intros ISO1.
        unfold cat, Cat_IFun, case_, Case_sum1, case_sum1, inl_, Inl_sum1, inr_, Inr_sum1, id_, Id_IFun in *.
        destruct (split_E T e) eqn:EQ.
        + auto.
        + generalize (iso_mono _ (Iso := sub_iso) _ c); intros ISO2.
          unfold cat, Cat_IFun, case_, Case_sum1, case_sum1, inl_, Inl_sum1, inr_, Inr_sum1, id_, Id_IFun in *.
          destruct (split_E T c) eqn:EQ'.
          * rewrite <- EQ' in *; rewrite ISO2.
            auto.
          * rewrite <- EQ' in *; rewrite ISO2.
            auto.
      - cbn.
        unfold SemiIso.
        repeat rewrite cat_case.
        repeat rewrite cat_assoc.
        generalize (@sub_iso _ _ _ _ Sub1WF); intros [_ epi1].
        generalize (@sub_iso _ _ _ _ Sub2WF); intros [_ epi2].
        unfold SemiIso in *.
        rewrite <- (cat_assoc merge_E split_E).
        rewrite epi1, cat_id_l, case_inr, case_inl.
        rewrite <- (cat_assoc merge_E split_E).
        rewrite epi2, cat_id_l, case_inr, case_inl.
        intros ? [|[|]]; cbn; reflexivity.
    Qed.

    (** Commutativity of subevents *)
    #[local] Instance Subevent_commute
             `{CUnit}
             {A B C}
             {Sub: A +? B -< C}:
      B +? A -< C :=
      {| split_E := split_E >>> swap
         ; merge_E := swap >>> merge_E |}.

   (** *** Well-formedness of the instances

      Each subevent instance defines an isomorphism. *)
    #[local] Instance Subevent_refl_wf {A : Type -> Type} : @Subevent_wf A _ _ Subevent_refl.
    Proof.
      constructor.
      - cbv; reflexivity.
      - cbv; intros ? [? | []]; reflexivity.
    Qed.

    #[local] Instance Subevent_void_wf {A : Type -> Type} : @Subevent_wf _ A _ Subevent_void.
    Proof.
      constructor.
      - cbv; reflexivity.
      - cbv. intros ? [[] | ?]; reflexivity.
    Qed.

    #[global] Instance Subevent_Base_wf {A B: Type -> Type} : Subevent_wf (@Subevent_Base _ A B).
    Proof.
      constructor; split; cbv; reflexivity.
    Qed.

    #[local] Instance Subevent_to_complement_wf {A B C D: Type -> Type}
             {Sub: (A +' B) +? C -< D}
             {SubWf: Subevent_wf Sub}
      : Subevent_wf (@Subevent_to_complement _ _ _ _ _ Sub).
    Proof.
      constructor.
      - cbn.
        apply SemiIso_Cat.
        apply SubWf.
        apply AssocRMono_Coproduct.
      - cbn.
        apply SemiIso_Cat.
        apply AssocLMono_Coproduct.
        apply SubWf.
    Qed.

    #[local] Instance Subevent_Assoc1_wf {A B C D E: Type -> Type}
             {Sub: (A +' B +' C) +? E -< D}
             {SubWf: Subevent_wf Sub}
      : Subevent_wf (@Subevent_Assoc1 _ A B C D E Sub).
    Proof.
      constructor.
      - cbn.
        apply SemiIso_Cat.
        apply SubWf.
        unfold SemiIso.
        rewrite cat_case.
        rewrite cat_assoc, inl_bimap.
        rewrite <- cat_assoc, assoc_l_mono, cat_id_l.
        rewrite inr_bimap, cat_id_l.
        rewrite <- case_eta.
        reflexivity.
      - cbn. apply SemiIso_Cat.
        2 : apply SubWf.
        unfold SemiIso.
        rewrite bimap_case.
        rewrite cat_id_l.
        rewrite <- cat_assoc, assoc_r_mono.
        rewrite cat_id_l.
        rewrite <- case_eta.
        reflexivity.
    Qed.

    #[local] Instance Subevent_Assoc2_wf {A B C D E: Type -> Type}
             {Sub: A +? E -< (B +' (C +' D))}
             {SubWf: Subevent_wf Sub}
      : Subevent_wf (@Subevent_Assoc2 _ A B C D E Sub).
    Proof.
      constructor.
      - cbn.
        apply SemiIso_Cat, SubWf.
        unfold SemiIso.
        rewrite assoc_r_mono; reflexivity.
      - cbn.
        apply SemiIso_Cat.
        apply SubWf.
        unfold SemiIso.
        rewrite assoc_l_mono; reflexivity.
    Qed.

    #[local] Instance Subevent_Assoc3_wf {A B C D E: Type -> Type}
             {Sub: A +? (B +' (C +' D)) -< E}
             {SubWf: Subevent_wf Sub}
      : Subevent_wf (@Subevent_Assoc3 _ A B C D E Sub).
    Proof.
      constructor.
      - cbn.
        apply SemiIso_Cat. apply SubWf.
        apply SemiIso_Bimap.
        apply SemiIso_Id.
        apply AssocLMono_Coproduct.
      - cbn.
        apply SemiIso_Cat.
        apply SemiIso_Bimap.
        apply SemiIso_Id.
        apply AssocRMono_Coproduct.
        apply SubWf.
    Qed.

    #[local] Instance Subevent_Sum_In_wf {A B C D: Type -> Type}
             {Sub: A +? D -< B}
             {SubWf: Subevent_wf Sub}
      : Subevent_wf (@Subevent_Sum_In _ A B C D Sub).
    Proof.
      constructor.
      - cbn.
        unfold SemiIso.
        rewrite cat_case.
        rewrite <- cat_assoc, (cat_assoc inl_ inl_), inl_assoc_r.
        do 2 rewrite inl_bimap, cat_id_l.
        rewrite <- inr_assoc_l.
        rewrite ! cat_assoc, <- (cat_assoc _ assoc_r _), assoc_l_mono, cat_id_l.
        rewrite inr_bimap, <- cat_assoc.
        rewrite semi_iso; [| apply SubWf].
        rewrite cat_id_l, case_eta.
        reflexivity.
      - cbn.
        unfold SemiIso.
        rewrite cat_assoc, bimap_case, cat_id_l.
        rewrite <- cat_assoc.
        rewrite (@semi_iso _ _ _ _ _ _ _ merge_E split_E); [| apply SubWf].
        rewrite cat_id_l.
        unfold assoc_r, AssocR_Coproduct.
        rewrite cat_case.
        rewrite cat_assoc, case_inr.
        rewrite cat_case.
        rewrite cat_assoc, case_inr, case_inl.
        rewrite inr_bimap, inl_bimap, cat_id_l.
        rewrite <- case_eta', <- case_eta.
        reflexivity.
    Qed.

    #[local] Instance Subevent_Sum_Out_wf {A B C D: Type -> Type}
             {Sub: A +? D -< B}
             {SubWf: Subevent_wf Sub}
      : Subevent_wf (@Subevent_Sum_Out _ A B C D Sub).
    Proof.
      constructor.
      - cbn.
        unfold SemiIso.
        rewrite cat_case.
        rewrite cat_assoc, inr_case, inl_bimap, cat_id_l.
        rewrite cat_assoc, bimap_case, cat_id_l.
        rewrite inr_bimap.
        rewrite 2 cat_assoc, <- cat_case, <- case_eta, cat_id_l.
        rewrite <- cat_assoc, semi_iso; [| apply SubWf].
        rewrite cat_id_l, <- case_eta.
        reflexivity.
      - cbn.
        unfold SemiIso.
        rewrite cat_case.
        rewrite 2 cat_assoc, inr_case.
        rewrite <- (cat_assoc _ split_E _), semi_iso; [| apply SubWf].
        rewrite cat_id_l, inl_bimap, cat_id_l.
        rewrite bimap_case, cat_id_l.
        rewrite <- cat_assoc, (cat_assoc _ merge_E _), semi_iso; [| apply SubWf].
        rewrite cat_id_r, inr_bimap, <- case_eta', <- case_eta.
        reflexivity.
    Qed.

End Subevent_Instances.

(** ** Automatic solver for associating subevents *)
#[global] Existing Instance Subevent_refl          | 0.
#[global] Existing Instance Subevent_void          | 0.
#[global] Existing Instance Subevent_Base          | 0.
#[global] Existing Instance Subevent_Sum_In        | 2.
#[global] Existing Instance Subevent_Sum_Out       | 3.
#[global] Existing Instance Trigger_ITree          | 1.
#[global] Existing Instance Trigger_MonadT         | 1.
#[global] Existing Instance Trigger_Prop           | 1.
#[global] Existing Instances Trigger_ITree Trigger_ITree_base Trigger_MonadT Trigger_Prop.

#[global]
Hint Extern 10 (Subevent ?A ?B ?C) =>
match goal with
| h: _ +? ?E -< ?C |- _ =>
  match goal with
  | h': ?A +? _ -< ?E |- _ =>
    apply (@Subevent_forget_order _ _ _ _ _ _ h h')
  end
end: typeclass_instances.
#[global]
Hint Extern 10 (Subevent ?A ?B ?C) =>
match goal with
| h: ?B +? ?A -< ?C |- _ =>
  exact (@Subevent_commute _ _ _ _ h)
end: typeclass_instances.


Theorem pp : Prop.
Proof.
  exact (4=1).
Qed.

Theorem ss : Set.
Proof.
  exact nat.
Qed.

Theorem tt : Type.
Proof.
  exact False.
Qed.


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

(*=encode_decode_t_n *)
Lemma encode_decode_t_n : forall (i : instruction_tern_n)
                                 (bi : binary_instruction),
    encode_t_n i = Some bi -> decode bi = Some (instr_t_n i).
(*=End *)
Proof.
  (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2 ++ x3) 8 = (x0,x1 ++ x2 ++ x3)) by (apply get_first_n_bit_size_4; auto).
  rewrite H7.
  apply commut_equal in H0.
  Check lookup_lookdown.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H8.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_t_n (instr_opcode_t_n i))) f = f (tag_t_n (instr_opcode_t_n i))) by reflexivity.
  rewrite H9.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2 ++ x3) 8 = (x1,x2 ++ x3)) by (apply get_first_n_bit_size_3; auto).
  rewrite H11.
  assert (length x2 = 8) by (apply commut_equal in H3; apply operand_to_bin_size in H3; auto).
  assert (get_first_n_bit  (x2 ++ x3) 8 = (x2,x3))by (apply commut_equal in H4; apply get_first_n_bit_size_tl; auto).
  rewrite H13.
  assert (length x3 = 8) by (apply commut_equal in H4; apply operand_to_bin_size in H4; auto).
  assert (get_first_n_bit  (x3) 8 = (x3,[])) by (apply get_first_n_bit_size_nil_n; auto).
  rewrite H15.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  apply operand_to_bin_hypothesis_reg in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_hypothesis_reg in H3.
  rewrite H3.
  apply commut_equal in H4.
  apply operand_to_bin_hypothesis_reg in H4.
  rewrite H4.
  assert ({|
       instr_opcode_t_n := instr_opcode_t_n i;
       instr_operande1_t_n := instr_operande1_t_n i;
       instr_operande2_t_n := instr_operande2_t_n i;
       instr_operande3_t_n := instr_operande3_t_n i |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H16.
  repeat rewrite app_length.
  rewrite H5.
  rewrite H10.
  rewrite H12.
  rewrite H14.
  simpl.
  reflexivity.
Qed.

Lemma encode_decode_t_i : forall (i : instruction_tern_i) (bi : binary_instruction),
    encode_t_i i = Some bi -> decode bi = Some (instr_t_i i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2 ++ x3) 8 = (x0,x1 ++ x2 ++ x3)) by (apply get_first_n_bit_size_4; auto).
  rewrite H7.
  apply commut_equal in H0.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H8.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_t_i (instr_opcode_t_i i))) f = f (tag_t_i (instr_opcode_t_i i))) by reflexivity.
  rewrite H9.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2 ++ x3) 8 = (x1,x2 ++ x3)) by (apply get_first_n_bit_size_3; auto).
  rewrite H11.
  assert (length x2 = 8) by (apply commut_equal in H3; apply operand_to_bin_size in H3; auto).
  assert (get_first_n_bit  (x2 ++ x3) 8 = (x2,x3))by (apply commut_equal in H4; apply get_first_n_bit_size_tl; auto).
  rewrite H13.
  assert (length x3 = 8) by (apply commut_equal in H4; apply operand_to_bin_size in H4; auto).
  assert (get_first_n_bit  (x3) 8 = (x3,[])) by (apply get_first_n_bit_size_nil_n; auto).
  rewrite H15.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  apply operand_to_bin_hypothesis_reg in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_hypothesis_reg in H3.
  rewrite H3.
  apply commut_equal in H4.
  apply operand_to_bin_hypothesis_imm in H4.
  rewrite H4.
  assert ({|
       instr_opcode_t_i := instr_opcode_t_i i;
       instr_operande1_t_i := instr_operande1_t_i i;
       instr_operande2_t_i := instr_operande2_t_i i;
       instr_operande3_t_i := instr_operande3_t_i i |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H16.
  repeat rewrite app_length.
  rewrite H5.
  rewrite H10.
  rewrite H12.
  rewrite H14.
  simpl.
  reflexivity.
Qed.

Lemma encode_decode_t_i2 : forall (i : instruction_tern_i2) (bi : binary_instruction),
    encode_t_i2 i = Some bi -> decode bi = Some (instr_t_i2 i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2 ++ x3) 8 = (x0,x1 ++ x2 ++ x3)) by (apply get_first_n_bit_size_4; auto).
  rewrite H7.
  apply commut_equal in H0.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H8.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_t_i2 (instr_opcode_t_i2 i))) f = f (tag_t_i2 (instr_opcode_t_i2 i))) by reflexivity.
  rewrite H9.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2 ++ x3) 8 = (x1,x2 ++ x3)) by (apply get_first_n_bit_size_3; auto).
  rewrite H11.
  assert (length x2 = 8) by (apply commut_equal in H3; apply operand_to_bin_size in H3; auto).
  assert (get_first_n_bit  (x2 ++ x3) 8 = (x2,x3))by (apply commut_equal in H4; apply get_first_n_bit_size_tl; auto).
  rewrite H13.
  assert (length x3 = 8) by (apply commut_equal in H4; apply operand_to_bin_size in H4; auto).
  assert (get_first_n_bit  (x3) 8 = (x3,[])) by (apply get_first_n_bit_size_nil_n; auto).
  rewrite H15.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  Check operand_to_bin_hypothesis_reg.
  apply operand_to_bin_hypothesis_reg in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_hypothesis_imm in H3.
  rewrite H3.
  apply commut_equal in H4.
  apply operand_to_bin_hypothesis_reg in H4.
  rewrite H4.
  assert ({|
       instr_opcode_t_i2 := instr_opcode_t_i2 i;
       instr_operande1_t_i2 := instr_operande1_t_i2 i;
       instr_operande2_t_i2 := instr_operande2_t_i2 i;
       instr_operande3_t_i2 := instr_operande3_t_i2 i |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H16.
  repeat rewrite app_length.
  rewrite H5.
  rewrite H10.
  rewrite H12.
  rewrite H14.
  simpl.
  reflexivity.
Qed.

Lemma encode_decode_t_i3 : forall (i : instruction_tern_i3) (bi : binary_instruction),
    encode_t_i3 i = Some bi -> decode bi = Some (instr_t_i3 i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2 ++ x3) 8 = (x0,x1 ++ x2 ++ x3)) by (apply get_first_n_bit_size_4; auto).
  rewrite H7.
  apply commut_equal in H0.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H8.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_t_i3 (instr_opcode_t_i3 i))) f = f (tag_t_i3 (instr_opcode_t_i3 i))) by reflexivity.
  rewrite H9.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2 ++ x3) 8 = (x1,x2 ++ x3)) by (apply get_first_n_bit_size_3; auto).
  rewrite H11.
  assert (length x2 = 8) by (apply commut_equal in H3; apply operand_to_bin_size in H3; auto).
  assert (get_first_n_bit  (x2 ++ x3) 8 = (x2,x3))by (apply commut_equal in H4; apply get_first_n_bit_size_tl; auto).
  rewrite H13.
  assert (length x3 = 8) by (apply commut_equal in H4; apply operand_to_bin_size in H4; auto).
  assert (get_first_n_bit  (x3) 8 = (x3,[])) by (apply get_first_n_bit_size_nil_n; auto).
  rewrite H15.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  Check operand_to_bin_hypothesis_reg.
  apply operand_to_bin_hypothesis_imm in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_hypothesis_reg in H3.
  rewrite H3.
  apply commut_equal in H4.
  apply operand_to_bin_hypothesis_reg in H4.
  rewrite H4.
  assert ({|
       instr_opcode_t_i3 := instr_opcode_t_i3 i;
       instr_operande1_t_i3 := instr_operande1_t_i3 i;
       instr_operande2_t_i3 := instr_operande2_t_i3 i;
       instr_operande3_t_i3 := instr_operande3_t_i3 i |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H16.
  repeat rewrite app_length.
  rewrite H5.
  rewrite H10.
  rewrite H12.
  rewrite H14.
  simpl.
  reflexivity.
Qed.

Lemma encode_decode_t_i4 : forall (i : instruction_tern_i4) (bi : binary_instruction),
    encode_t_i4 i = Some bi -> decode bi = Some (instr_t_i4 i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2 ++ x3) 8 = (x0,x1 ++ x2 ++ x3)) by (apply get_first_n_bit_size_4; auto).
  rewrite H7.
  apply commut_equal in H0.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H8.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_t_i4 (instr_opcode_t_i4 i))) f = f (tag_t_i4 (instr_opcode_t_i4 i))) by reflexivity.
  rewrite H9.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2 ++ x3) 8 = (x1,x2 ++ x3)) by (apply get_first_n_bit_size_3; auto).
  rewrite H11.
  assert (length x2 = 8) by (apply commut_equal in H3; apply operand_to_bin_size in H3; auto).
  assert (get_first_n_bit  (x2 ++ x3) 8 = (x2,x3))by (apply commut_equal in H4; apply get_first_n_bit_size_tl; auto).
  rewrite H13.
  assert (length x3 = 8) by (apply commut_equal in H4; apply operand_to_bin_size in H4; auto).
  assert (get_first_n_bit  (x3) 8 = (x3,[])) by (apply get_first_n_bit_size_nil_n; auto).
  rewrite H15.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  Check operand_to_bin_hypothesis_reg.
  apply operand_to_bin_hypothesis_reg in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_hypothesis_imm in H3.
  rewrite H3.
  apply commut_equal in H4.
  apply operand_to_bin_hypothesis_imm in H4.
  rewrite H4.
  assert ({|
       instr_opcode_t_i4 := instr_opcode_t_i4 i;
       instr_operande1_t_i4 := instr_operande1_t_i4 i;
       instr_operande2_t_i4 := instr_operande2_t_i4 i;
       instr_operande3_t_i4 := instr_operande3_t_i4 i |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H16.
  repeat rewrite app_length.
  rewrite H5.
  rewrite H10.
  rewrite H12.
  rewrite H14.
  simpl.
  reflexivity.
Qed.

Lemma encode_decode_t_i5 : forall (i : instruction_tern_i5) (bi : binary_instruction),
    encode_t_i5 i = Some bi -> decode bi = Some (instr_t_i5 i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2 ++ x3) 8 = (x0,x1 ++ x2 ++ x3)) by (apply get_first_n_bit_size_4; auto).
  rewrite H7.
  apply commut_equal in H0.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H8.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_t_i5 (instr_opcode_t_i5 i))) f = f (tag_t_i5 (instr_opcode_t_i5 i))) by reflexivity.
  rewrite H9.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2 ++ x3) 8 = (x1,x2 ++ x3)) by (apply get_first_n_bit_size_3; auto).
  rewrite H11.
  assert (length x2 = 8) by (apply commut_equal in H3; apply operand_to_bin_size in H3; auto).
  assert (get_first_n_bit  (x2 ++ x3) 8 = (x2,x3))by (apply commut_equal in H4; apply get_first_n_bit_size_tl; auto).
  rewrite H13.
  assert (length x3 = 8) by (apply commut_equal in H4; apply operand_to_bin_size in H4; auto).
  assert (get_first_n_bit  (x3) 8 = (x3,[])) by (apply get_first_n_bit_size_nil_n; auto).
  rewrite H15.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  Check operand_to_bin_hypothesis_reg.
  apply operand_to_bin_hypothesis_imm in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_hypothesis_imm in H3.
  rewrite H3.
  apply commut_equal in H4.
  apply operand_to_bin_hypothesis_imm in H4.
  rewrite H4.
  assert ({|
       instr_opcode_t_i5 := instr_opcode_t_i5 i;
       instr_operande1_t_i5 := instr_operande1_t_i5 i;
       instr_operande2_t_i5 := instr_operande2_t_i5 i;
       instr_operande3_t_i5 := instr_operande3_t_i5 i |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H16.
  repeat rewrite app_length.
  rewrite H5.
  rewrite H10.
  rewrite H12.
  rewrite H14.
  simpl.
  reflexivity.
Qed.

Lemma encode_decode_t_i6 : forall (i : instruction_tern_i6) (bi : binary_instruction),
    encode_t_i6 i = Some bi -> decode bi = Some (instr_t_i6 i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2 ++ x3) 8 = (x0,x1 ++ x2 ++ x3)) by (apply get_first_n_bit_size_4; auto).
  rewrite H7.
  apply commut_equal in H0.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H8.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_t_i6 (instr_opcode_t_i6 i))) f = f (tag_t_i6 (instr_opcode_t_i6 i))) by reflexivity.
  rewrite H9.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2 ++ x3) 8 = (x1,x2 ++ x3)) by (apply get_first_n_bit_size_3; auto).
  rewrite H11.
  assert (length x2 = 8) by (apply commut_equal in H3; apply operand_to_bin_size in H3; auto).
  assert (get_first_n_bit  (x2 ++ x3) 8 = (x2,x3))by (apply commut_equal in H4; apply get_first_n_bit_size_tl; auto).
  rewrite H13.
  assert (length x3 = 8) by (apply commut_equal in H4; apply operand_to_bin_size in H4; auto).
  assert (get_first_n_bit  (x3) 8 = (x3,[])) by (apply get_first_n_bit_size_nil_n; auto).
  rewrite H15.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  Check operand_to_bin_hypothesis_reg.
  apply operand_to_bin_hypothesis_imm in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_hypothesis_reg in H3.
  rewrite H3.
  apply commut_equal in H4.
  apply operand_to_bin_hypothesis_imm in H4.
  rewrite H4.
  assert ({|
       instr_opcode_t_i6 := instr_opcode_t_i6 i;
       instr_operande1_t_i6 := instr_operande1_t_i6 i;
       instr_operande2_t_i6 := instr_operande2_t_i6 i;
       instr_operande3_t_i6 := instr_operande3_t_i6 i |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H16.
  repeat rewrite app_length.
  rewrite H5.
  rewrite H10.
  rewrite H12.
  rewrite H14.
  simpl.
  reflexivity.
Qed.

Lemma encode_decode_d_n : forall (i : instruction_duo_n) (bi : binary_instruction),
    encode_d_n i = Some bi -> decode bi = Some (instr_d_n i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2) 8 = (x0,x1 ++ x2)) by (apply get_first_n_bit_size_3; auto).
  rewrite H6.
  apply commut_equal in H0.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H7.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_d_n (instr_opcode_d_n i))) f = f (tag_d_n (instr_opcode_d_n i))) by reflexivity.
  rewrite H8.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2) 8 = (x1,x2)) by (apply get_first_n_bit_size_tl; auto).
  rewrite H10.
  assert (length x2 = 16) by (apply commut_equal in H3; apply operand_to_bin_double_size in H3; auto).
  assert (get_first_n_bit x2 16 = (x2,[]))by (apply commut_equal in H4; apply get_first_n_bit_size_nil_n; auto).
  rewrite H12.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  apply operand_to_bin_hypothesis_reg in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_double_hypothesis_reg in H3.
  rewrite H3.
  assert ({|
       instr_opcode_d_n := instr_opcode_d_n i;
       instr_operande1_d_n := instr_operande1_d_n i;
       instr_operande2_d_n := instr_operande2_d_n i; |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H13.
  repeat rewrite app_length.
  rewrite H4.
  rewrite H9.
  rewrite H11.
  simpl.
  reflexivity.
Qed.

Lemma encode_decode_d_i : forall (i : instruction_duo_i) (bi : binary_instruction),
    encode_d_i i = Some bi -> decode bi = Some (instr_d_i i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2) 8 = (x0,x1 ++ x2)) by (apply get_first_n_bit_size_3; auto).
  rewrite H6.
  apply commut_equal in H0.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H7.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_d_i (instr_opcode_d_i i))) f = f (tag_d_i (instr_opcode_d_i i))) by reflexivity.
  rewrite H8.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2) 8 = (x1,x2)) by (apply get_first_n_bit_size_tl; auto).
  rewrite H10.
  assert (length x2 = 16) by (apply commut_equal in H3; apply operand_to_bin_double_size in H3; auto).
  assert (get_first_n_bit x2 16 = (x2,[]))by (apply commut_equal in H4; apply get_first_n_bit_size_nil_n; auto).
  rewrite H12.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  apply operand_to_bin_hypothesis_reg in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_double_hypothesis_imm in H3.
  rewrite H3.
  assert ({|
       instr_opcode_d_i := instr_opcode_d_i i;
       instr_operande1_d_i := instr_operande1_d_i i;
       instr_operande2_d_i := instr_operande2_d_i i; |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H13.
  repeat rewrite app_length.
  rewrite H4.
  rewrite H9.
  rewrite H11.
  reflexivity.
Qed.

Lemma encode_decode_d_i2 : forall (i : instruction_duo_i2) (bi : binary_instruction),
    encode_d_i2 i = Some bi -> decode bi = Some (instr_d_n2 i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2) 8 = (x0,x1 ++ x2)) by (apply get_first_n_bit_size_3; auto).
  rewrite H6.
  apply commut_equal in H0.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H7.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_d_i2 (instr_opcode_d_i2 i))) f = f (tag_d_i2 (instr_opcode_d_i2 i))) by reflexivity.
  rewrite H8.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2) 8 = (x1,x2)) by (apply get_first_n_bit_size_tl; auto).
  rewrite H10.
  assert (length x2 = 16) by (apply commut_equal in H3; apply operand_to_bin_double_size in H3; auto).
  assert (get_first_n_bit x2 16 = (x2,[]))by (apply commut_equal in H4; apply get_first_n_bit_size_nil_n; auto).
  rewrite H12.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  apply operand_to_bin_hypothesis_imm in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_double_hypothesis_reg in H3.
  rewrite H3.
  assert ({|
       instr_opcode_d_i2 := instr_opcode_d_i2 i;
       instr_operande1_d_i2 := instr_operande1_d_i2 i;
       instr_operande2_d_i2 := instr_operande2_d_i2 i; |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H13.
  repeat rewrite app_length.
  rewrite H4.
  rewrite H9.
  rewrite H11.
  reflexivity.
Qed.

Lemma encode_decode_d_i3 : forall (i : instruction_duo_i3) (bi : binary_instruction),
    encode_d_i3 i = Some bi -> decode bi = Some (instr_d_n3 i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  unfold decode.
  rewrite ret_rewrite in H.
  inversion H.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  assert (get_first_n_bit (x0 ++ x1 ++ x2) 8 = (x0,x1 ++ x2)) by (apply get_first_n_bit_size_3; auto).
  rewrite H6.
  apply commut_equal in H0.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H7.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_d_i3 (instr_opcode_d_i3 i))) f = f (tag_d_i3 (instr_opcode_d_i3 i))) by reflexivity.
  rewrite H8.
  assert (length x1 = 8) by (apply commut_equal in H2; apply operand_to_bin_size in H2; auto).
  assert (get_first_n_bit  (x1 ++ x2) 8 = (x1,x2)) by (apply get_first_n_bit_size_tl; auto).
  rewrite H10.
  assert (length x2 = 16) by (apply commut_equal in H3; apply operand_to_bin_double_size in H3; auto).
  assert (get_first_n_bit x2 16 = (x2,[]))by (apply commut_equal in H4; apply get_first_n_bit_size_nil_n; auto).
  rewrite H12.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  apply operand_to_bin_hypothesis_imm in H2.
  rewrite H2.
  apply commut_equal in H3.
  apply operand_to_bin_double_hypothesis_imm in H3.
  rewrite H3.
  assert ({|
       instr_opcode_d_i3 := instr_opcode_d_i3 i;
       instr_operande1_d_i3 := instr_operande1_d_i3 i;
       instr_operande2_d_i3 := instr_operande2_d_i3 i; |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  rewrite H13.
  repeat rewrite app_length.
  rewrite H4.
  rewrite H9.
  rewrite H11.
  reflexivity.
Qed.

Lemma encode_decode_u : forall (i : instruction_uno) (bi : binary_instruction),
    encode_u i = Some bi -> decode bi = Some (instr_u i).
Proof.
    (* first part trying to get lot of information from encode_t_n *)
  intros.
  unfold encode_t_n in H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  destruct (instr_operande i) eqn:Hi.
  apply bind_rewrite in H.
  destruct H.
  destruct H.
  rewrite ret_rewrite in H.
  inversion H.
  unfold decode.
  (* now going to go further into decode *)
  assert (length x0 = 8) by (apply commut_equal in H1; apply size_n_bit in H1; auto).
  Search get_first_n_bit.
  assert (get_first_n_bit (x0 ++ x1) 8 = (x0,x1)) by (apply get_first_n_bit_size_tl; auto).
  rewrite H5.
  apply commut_equal in H0.
  apply lookup_lookdown in H0.
  apply commut_equal in H1.
  assert (bit_n x0 = x) by (apply n_bit_n in H1; exact H1).
  rewrite H6.
  rewrite H0.
  assert (forall (f : tag -> (option instruction)), bind (Some (tag_u (instr_opcode_s i))) f = f (tag_u (instr_opcode_s i))) by reflexivity.
  rewrite H7.
  assert (length x1 = 24).
  { apply commut_equal in H2. Search n_bit. apply size_n_bit in H2. auto. }
  Search (length (_ ++ _)).
  rewrite app_length.
  rewrite H8.
  rewrite H3.
  simpl.
    assert (get_first_n_bit  x1 24 = (x1,[])).
  { Search get_first_n_bit. apply get_first_n_bit_size_nil_n in H8. auto. }
  rewrite H9.
  rewrite ret_rewrite.
  apply commut_equal in H2.
  assert ({|
       instr_opcode_s := instr_opcode_s i;
       instr_operande := instr_operande i; |} = i).
  {
    simpl. destruct i.
    compute. reflexivity.
  }
  Search (n_bit).
  apply n_bit_n in H2.
  rewrite H2.
  rewrite <- Hi.
  rewrite H10.
  reflexivity.
Qed.

(*=encode_decode *)
Lemma encode_decode : forall (i : instruction) (bi : binary_instruction),
    encode i = Some bi -> decode bi = Some i.
(*=End *)
Proof.
  destruct i.
  -apply encode_decode_t_n.
  -apply encode_decode_t_i.
  -apply encode_decode_t_i2.
  -apply encode_decode_t_i3.
  -apply encode_decode_t_i4.
  -apply encode_decode_t_i5.
  -apply encode_decode_t_i6.
  -apply encode_decode_d_n.
  -apply encode_decode_d_i.
  -apply encode_decode_d_i2.
  -apply encode_decode_d_i3.
  -apply encode_decode_u.
Qed.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.NISTP256.AMD128.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From exercises Require Export sem_typed sem_operators.

(** * Compatibility lemmas *)
(** We prove that the logical relations, i.e., the semantic typing judgment,
that we have defined is compatible with typing rules. That is, the logical
relations is a congruence with respect to the typing rules.

These compatibility lemmas are what one gets when the syntactic typing judgment
is replaced semantic typing judgment in syntactic typing rules. For instance
([sem_typed_pair]):

<<
   Γ ⊢ e1 : τ1        Γ ⊢ e2 : τ2
  --------------------------------
       Γ ⊢ (e1, e2) : τ1 × τ2
>>

becomes:

<<
  (Γ ⊨ e1 : A1) -∗ (Γ ⊨ e2 : A2) -∗ Γ ⊨ (e1, e2) : A1 * A2
>>
*)

Section compatibility.
  Context `{!heapG Σ}.
  Implicit Types A B : sem_ty Σ.
  Implicit Types C : sem_ty Σ → sem_ty Σ.

  (** * Compatibility rules for expression typing *)
  (** * Variables *)
  Lemma Var_sem_typed Γ (x : string) A : Γ !! x = Some A → ⊢ Γ ⊨ x : A.
  Proof.
    iIntros (HΓx vs) "!> #HΓ /=".
    iDestruct (env_sem_typed_lookup with "HΓ") as (v ->) "HA"; first done.
    by iApply wp_value.
  Qed.

  Lemma Val_sem_typed Γ v A : ⊨ᵥ v : A -∗ Γ ⊨ v : A.
  Proof.
    iIntros "#Hv" (vs) "!> #HΓ /=".
    iApply wp_value. iApply "Hv".
  Qed.

  (** * Products and sums *)
  Lemma Pair_sem_typed Γ e1 e2 A1 A2 :
    Γ ⊨ e1 : A1 -∗ Γ ⊨ e2 : A2 -∗ Γ ⊨ (e1,e2) : A1 * A2.
  Proof.
    iIntros "#H1 #H2" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H2 [//])"); iIntros (w2) "#HA2".
    wp_apply (wp_wand with "(H1 [//])"); iIntros (w1) "#HA1".
    wp_pures. iExists w1, w2. auto.
  Qed.
  Lemma Fst_sem_typed Γ e A1 A2 : Γ ⊨ e : A1 * A2 -∗ Γ ⊨ Fst e : A1.
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (w).
    iDestruct 1 as (w1 w2 ->) "[??]". by wp_pures.
  Qed.
  Lemma Snd_sem_typed Γ e A1 A2 : Γ ⊨ e : A1 * A2 -∗ Γ ⊨ Snd e : A2.
  Proof.
    (* exercise *)
  Admitted.

  Lemma InjL_sem_typed Γ e A1 A2 : Γ ⊨ e : A1 -∗ Γ ⊨ InjL e : A1 + A2.
  Proof.
    (* exercise *)
  Admitted.
  Lemma InjR_sem_typed Γ e A1 A2 : Γ ⊨ e : A2 -∗ Γ ⊨ InjR e : A1 + A2.
  Proof.
    (* exercise *)
  Admitted.
  Lemma Case_sem_typed Γ e e1 e2 A1 A2 B :
    Γ ⊨ e : A1 + A2 -∗ Γ ⊨ e1 : (A1 → B) -∗ Γ ⊨ e2 : (A2 → B) -∗
    Γ ⊨ Case e e1 e2 : B.
  Proof.
    (* exercise *)
  Admitted.

  (** * Functions *)
  Lemma Rec_sem_typed Γ f x e A1 A2 :
    binder_insert f (A1 → A2)%sem_ty (binder_insert x A1 Γ) ⊨ e : A2 -∗
    Γ ⊨ (rec: f x := e) : (A1 → A2).
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=". wp_pures. iModIntro. iLöb as "IH".
    iIntros "!>" (v) "#HA1". wp_pures. set (r := RecV f x _).
    rewrite -subst_map_binder_insert_2. iApply "H".
    iApply (env_sem_typed_insert with "IH"). by iApply env_sem_typed_insert.
  Qed.

  Lemma App_sem_typed Γ e1 e2 A1 A2 :
    Γ ⊨ e1 : (A1 → A2) -∗ Γ ⊨ e2 : A1 -∗ Γ ⊨ e1 e2 : A2.
  Proof.
    iIntros "#H1 #H2" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H2 [//])"); iIntros (w) "#HA1".
    wp_apply (wp_wand with "(H1 [//])"); iIntros (v) "#HA". by iApply "HA".
  Qed.

  (** * Polymorphic functions and existentials *)
  Lemma TLam_sem_typed Γ e C : (∀ A, Γ ⊨ e : C A) -∗ Γ ⊨ (Λ: e) : ∀ A, C A.
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=". wp_pures.
    iIntros "!> !>" (A) "/=". wp_pures. by iApply ("H" $! A).
  Qed.
  Lemma TApp_sem_typed Γ e C A : (Γ ⊨ e : ∀ A, C A) -∗ Γ ⊨ e <_> : C A.
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (w) "#HB". by iApply ("HB" $! A).
  Qed.

  Lemma Pack_sem_typed Γ e C A : Γ ⊨ e : C A -∗ Γ ⊨ (pack: e) : ∃ A, C A.
  Proof.
    (* exercise *)
  Admitted.
  Lemma Unpack_sem_typed Γ x e1 e2 C B :
    (Γ ⊨ e1 : ∃ A, C A) -∗ (∀ A, binder_insert x (C A) Γ ⊨ e2 : B) -∗
    Γ ⊨ (unpack: x := e1 in e2) : B.
  Proof.
    (* exercise *)
  Admitted.

  (** ** Heap operations *)
  Lemma Alloc_sem_typed Γ e A : Γ ⊨ e : A -∗ Γ ⊨ ref e : ref A.
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_bind (subst_map _ e). iApply (wp_wand with "(H [//])"); iIntros (w) "HA".
    iApply wp_fupd. wp_alloc l as "Hl".
    iMod (inv_alloc (tyN .@ l) _ (∃ v, l ↦ v ∗ A v)%I with "[Hl HA]") as "#?".
    { iExists w. iFrame. }
    iModIntro. iExists l; auto.
  Qed.
  Lemma Load_sem_typed Γ e A : Γ ⊨ e : ref A -∗ Γ ⊨ ! e : A.
  Proof.
    iIntros "#H" (vs) "!> #HΓ /=".
    wp_bind (subst_map _ e). iApply (wp_wand with "(H [//])"); iIntros (w).
    iDestruct 1 as (l ->) "#?".
    iInv (tyN.@l) as (v) "[>Hl HA]". wp_load. eauto 10.
  Qed.
  Lemma Store_sem_typed Γ e1 e2 A :
    Γ ⊨ e1 : ref A -∗ Γ ⊨ e2 : A -∗ Γ ⊨ (e1 <- e2) : ().
  Proof.
    (* exercise *)
  Admitted.
  Lemma FAA_sem_typed Γ e1 e2 :
    Γ ⊨ e1 : ref sem_ty_int -∗ Γ ⊨ e2 : sem_ty_int -∗ Γ ⊨ FAA e1 e2 : sem_ty_int.
  Proof.
    (* exercise *)
  Admitted.
  Lemma CmpXchg_sem_typed Γ A e1 e2 e3 :
    SemTyUnboxed A →
    Γ ⊨ e1 : ref A -∗ Γ ⊨ e2 : A -∗ Γ ⊨ e3 : A -∗
    Γ ⊨ CmpXchg e1 e2 e3 : A * sem_ty_bool.
  Proof.
    (* exercise *)
  Admitted.

  (** ** Recursive types *)
  (** Hint: A crucial ingredient for these proofs is the lemma [sem_ty_unfold]. *)
  Lemma Fold_sem_typed Γ e C `{!NonExpansive C} :
    Γ ⊨ e : C (μ A, C A)%sem_ty -∗ Γ ⊨ (fold: e) : μ A, C A.
  Proof.
    (* exercise *)
  Admitted.
  Lemma Unfold_sem_typed Γ e C `{!NonExpansive C} :
    Γ ⊨ e : (μ A, C A) -∗ Γ ⊨ (unfold: e) : C (μ A, C A)%sem_ty.
  Proof.
    (* exercise *)
  Admitted.

  (** ** Operators *)
  Lemma UnOp_sem_typed Γ e op A B :
    SemTyUnOp op A B → Γ ⊨ e : A -∗ Γ ⊨ UnOp op e : B.
  Proof.
    intros ?. iIntros "#H" (vs) "!> #HΓ /=".
    wp_apply (wp_wand with "(H [//])"); iIntros (v) "#HA".
    iDestruct (sem_ty_un_op with "HA") as (w ?) "#HB". by wp_unop.
  Qed.
  Lemma BinOp_sem_typed Γ e1 e2 op A1 A2 B :
    SemTyBinOp op A1 A2 B → Γ ⊨ e1 : A1 -∗ Γ ⊨ e2 : A2 -∗ Γ ⊨ BinOp op e1 e2 : B.
  Proof.
    (* exercise *)
  Admitted.

  Lemma If_sem_typed Γ e e1 e2 B :
    Γ ⊨ e : sem_ty_bool -∗ Γ ⊨ e1 : B -∗ Γ ⊨ e2 : B -∗
    Γ ⊨ (if: e then e1 else e2) : B.
  Proof.
    (* exercise *)
  Admitted.

  (** ** Fork *)
  Lemma Fork_sem_typed Γ e : Γ ⊨ e : () -∗ Γ ⊨ Fork e : ().
  Proof.
    (* exercise *)
  Admitted.

  (** * Compatibility rules for value typing *)
  (** ** Base types *)
  Lemma UnitV_sem_typed : ⊢ ⊨ᵥ #() : ().
  Proof. by iPureIntro. Qed.
  Lemma BoolV_sem_typed (b : bool) : ⊢ ⊨ᵥ #b : sem_ty_bool.
  Proof. by iExists b. Qed.
  Lemma IntV_sem_typed (n : Z) : ⊢ ⊨ᵥ #n : sem_ty_int.
  Proof.
    (* exercise *)
  Admitted.

  (** ** Products and sums *)
  Lemma PairV_sem_typed v1 v2 τ1 τ2 :
    ⊨ᵥ v1 : τ1 -∗ ⊨ᵥ v2 : τ2 -∗
    ⊨ᵥ PairV v1 v2 : (τ1 * τ2).
  Proof. iIntros "#H1 #H2". iExists v1, v2. auto. Qed.
  Lemma InjLV_sem_typed v τ1 τ2 :
    ⊨ᵥ v : τ1 -∗
    ⊨ᵥ InjLV v : (τ1 + τ2).
  Proof. iIntros "H". iLeft. auto. Qed.
  Lemma InjRV_sem_typed v τ1 τ2 :
    ⊨ᵥ v : τ2 -∗
    ⊨ᵥ InjRV v : (τ1 + τ2).
  Proof. iIntros "H". iRight. auto. Qed.

  (** ** Functions *)
  Lemma RecV_sem_typed f x e A B :
    binder_insert f (A → B)%sem_ty (binder_insert x A ∅) ⊨ e : B -∗
    ⊨ᵥ RecV f x e : (A → B).
  Proof.
    iIntros "#H". iLöb as "IH".
    iIntros "!>" (v) "#HA1". wp_pures. set (r := RecV f x _).
    rewrite -subst_map_binder_insert_2_empty. iApply "H".
    iApply (env_sem_typed_insert with "IH").
    iApply (env_sem_typed_insert with "[$]"). iApply env_sem_typed_empty.
  Qed.

  Lemma TLamV_sem_typed e C : (∀ A, ∅ ⊨ e : C A) -∗ ⊨ᵥ (Λ: e) : ∀ A, C A.
  Proof.
    iIntros "#H !>" (A) "/=". wp_pures.
    rewrite -{2}(subst_map_empty e). iApply ("H" $! A).
    by iApply env_sem_typed_empty.
  Qed.
End compatibility.


Require Export Iron.Language.SystemF2Effect.Type.Relation.KindT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.LowerTT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.SubstTT.Base.

Lemma lowerTT_substTT
 :  forall ix t1 t1' t2
 ,  lowerTT ix    t1 = Some t1'
 -> substTT ix t2 t1 = t1'.
Proof.
 intros. gen ix t2 t1'.
 induction t1; intros;
  try (solve [snorm; espread; nope]).
Qed.
Hint Resolve lowerTT_substTT.
Hint Rewrite lowerTT_substTT : global.

(* What a horrow show *)
Lemma lowerTT_substTT_liftTT
 :  forall t1 t1' d d' t2
 ,  lowerTT d t1 = Some t1'
 -> lowerTT d (substTT (1 + d + d') (liftTT 1 d t2) t1)
       = Some (substTT (d + d')      t2              t1').
Proof.
 intros. gen d d' t2 t1'.
 induction t1; intros;
  try (solve [snorm]).

 Case "TVar".
  repeat (simpl in *; norm1); try nope; try omega.

 Case "TForall".
  snorm. repeat f_equal.

   (* Goal 10 *)
   lets D: IHt1 (S d) d' (liftTT 1 0 t2) t0.
   symmetry in HeqH1. rip. clear IHt1. clear HeqH1.
   rrwrite (S (S d + d') = S (S (d + d'))) in D.
   norm. rewrite D in HeqH0. snorm.

   (* Goal 8 *)
   lets D: IHt1 (S d) d' (liftTT 1 0 t2) t.
   symmetry in HeqH1. rip. clear IHt1. clear HeqH1.
   rrwrite (S (S d + d') = S (S (d + d'))) in D.
   norm. rewrite D in HeqH0. nope.

 Case "TApp".
  snorm; nope.
   repeat (espread; burn); burn.
   erewrite IHt1_1 in *; eauto.
   erewrite IHt1_2 in *; eauto. nope.
   erewrite IHt1_1 in *; eauto. nope.

 Case "TSum".
  snorm; nope.
   repeat (espread; burn); burn.
   erewrite IHt1_1 in *; eauto.
   erewrite IHt1_2 in *; eauto. nope.
   erewrite IHt1_1 in *; eauto. nope.

 Case "TCon1".
  snorm; nope.
   repeat (espread; burn).
   erewrite IHt1 in *; eauto. nope.

 Case "TCon2".
  snorm; nope.
   repeat (espread; burn); burn.
   erewrite IHt1_1 in *; eauto.
   erewrite IHt1_2 in *; eauto. nope.
   erewrite IHt1_1 in *; eauto. nope.
Qed.

(* If we can lower a particular index then the term does not use it,
   so we can delete the corresponding slot from the enviornment. *)
Lemma lower_type_type_ix
 :  forall ix ke sp t1 k1 t2
 ,  lowerTT ix t1 = Some t2
 -> KindT ke sp t1 k1
 -> KindT (delete ix ke) sp t2 k1.
Proof.
 intros. gen ix ke sp k1 t2.
 induction t1; intros; simpl;
  try (solve [inverts_kind; snorm; eauto; nope]).

 - Case "TVar".
   inverts_kind. snorm.
    SCase "n > ix".
     eapply KiVar.
     rewrite <- H4.
     destruct n.
      simpl. burn.
      simpl. norm.

 - Case "TForall".
   inverts_kind. snorm.
    eapply KiForall.
    rewrite delete_rewind.
    eauto.

 - Case "TCon2".
   inverts_kind. snorm.
   eapply KiCon2; eauto.
    destruct tc; destruct t; eauto.
Qed.

Lemma lower_type_type
 :  forall t1 t2 ke sp k1 k2
 ,  lowerTT 0 t1 = Some t2
 -> KindT (ke :> k1) sp t1 k2
 -> KindT ke         sp t2 k2.
Proof.
 intros.
 lets D: lower_type_type_ix H H0.
 simpl in D. auto.
Qed.


Require Import Coqlib.
Require Import Asm.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

(*TODO: Replace with newer version*)
Ltac prep_r :=
  T0 _destruct state_bits;
    NP0 app_new step_fwd_exec step_fwd; eauto;
  repeat break_and;
  P0 _clear step_through;
  P0 _clear step_fwd;
  P0 _clear current_fn;
  NP app_new mem_eq_match_metadata_r MemEq.mem_eq.

Ltac step_l :=
    NP1 app_new step_through_current_instr step_through;
    NP1 app_new step_through_current_fn step_through; [ | simpl; eauto ];
    (step_l_str || step_l_jmp);
    break_and; compute_skipz; P1 _simpl step_through; try break_and;
    NP1 app_new step_fwd_transf_block step_fwd.

Definition aiken_5_example :=
  Psetcc Cond_g EAX :: Pdec EAX :: Pand_rr EBX EAX :: nil.

Section AIKEN_5.

  Variable concrete : code.

  Variable r1 : ireg.
  Variable r2 : ireg.
  Variable END : label.
  Hypothesis r1_r2_neq: r1 <> r2.

  Definition aiken_5_defs : rewrite_defs :=
    {|
      fnd :=
        (* setg %al  *)
        (* movzbl %al, %eax  *) (*move byte to long zero exteneded*)
        (* dec %eax *)
        (* and %eax, %esi *)
        Psetcc Cond_g r1 ::
               Pdec r1 ::
               Pand_rr r2 r1 ::
               nil
      ; rpl :=
          (* mov $0, EAX *)
          (* cmovg %eax, %esi *)
          Pmov_ri r1 zero ::
                  Pcmov Cond_g r2 r1 ::
                  Pnop ::
                  nil
      ; lv_in := PC :: IR r2 :: flags
      ; lv_out := PC :: IR r2 :: nil
      ; clobbered := IR r1 :: nil
    |}.

  Lemma aiken_5_selr :
    StepEquiv.step_through_equiv_live (fnd aiken_5_defs) (rpl aiken_5_defs) (lv_in aiken_5_defs) (lv_out aiken_5_defs).
  Proof.
    prep_l.
    do 3 step_l.
    prep_r.
    P0 _clear current_instr.
    step_r.
    prep_exec_instr.
    unfold exec_instr_bits.
    simpl.
    repeat break_match; eauto.
    repeat break_exists.
    step_r.
    step_r.
    assert (x6 = md').
    specialize (H21 x3).
    simpl_and_clear.
    subst x6.
    finish_r.
    P0 _clear step_through;
      P0 _clear at_code;
      P0 _clear at_code_end;
      P0 _clear not_after_label_in_code;
      P0 _clear st_rs;
      inv_state;
      P0 bump val_eq;
      P0 bump exec_instr_bits.
    (* 2: eq_mem_tac. *)
    intros.
    unfold exec_instr_bits in *.
    remember (eval_testcond Cond_g rsl) as cond_l.
    remember (eval_testcond Cond_g (nextinstr rsr # r1 <- (Vint zero))) as cond_r.
    specialize (H30 x3).
    repeat gentle_inv_next.
    subst a1 a0.
    subst m1 m0 m.
    clear_taut.
    unfold flags in *.
    simpl_ls_pred.
    exploit (UseBasic.eval_testcond_match rsl (nextinstr rsr # r1 <- (Vint zero)) Cond_g); eauto.
    intros.
    destruct cond_l; try destruct b0;
    try (break_or'; try congruence; [ ]).
    - subst cond_r.
      rewrite <- H42 in H30.
      clear H42.
      collapse_match_hyp.
      P1 _inversion Nxt.
      P0 _clear Nxt.
      split.
      intros.
      2: eq_mem_tac.
      repeat break_or_reg.
      + preg_simpl.
        repeat find_rewrite_goal.
        simpl.
        f_equal.
      + subst.
        simpl.
        preg_simpl.
        simpl.
        replace (Int.sub Int.one Int.one) with (Int.zero) by ring.
        unfold Val.and.
        break_match; simpl; intros; try congruence.
        f_equal.
        rewrite Int.and_zero.
        auto.
    - subst cond_r.
      rewrite <- H42 in H30.
      clear H42.
      collapse_match_hyp.
      P1 _inversion Nxt.
      P0 _clear Nxt.
      split.
      2: eq_mem_tac.
      intros.
      repeat break_or_reg.
      + preg_simpl.
        repeat find_rewrite_goal.
        simpl.
        f_equal.
      + subst.
        simpl.
        preg_simpl.
        simpl.
        replace (Int.sub Int.zero Int.one) with (Int.mone).
        2: unfold Int.mone; ring.
        simpl.
        unfold Val.and.
        break_match; simpl; intros; try congruence.
        P0 _simpl val_eq.
        rewrite <- H0.
        f_equal.
        apply Int.and_mone.
        P0 _simpl val_eq.
        tauto.
    - split.
      2: eq_mem_tac.
      intros.
      repeat break_or_reg.
      + preg_simpl.
        repeat find_rewrite_goal.
        simpl.
        repeat break_match_hyp.
        * inv_next.
          preg_simpl.
          repeat find_rewrite_goal.
          simpl. auto.
        * inv_next.
          preg_simpl.
          repeat find_rewrite_goal.
          simpl. auto.
        * inv_next.
          preg_simpl.
          repeat find_rewrite_goal.
          simpl. auto.
      + preg_simpl.
        repeat break_match_hyp; inv_next.
        * subst.
          preg_simpl.
          simpl.
          unfold Val.and.
          break_match; simpl; intros; congruence.
        * subst.
          preg_simpl.
          simpl.
          unfold Val.and.
          break_match; simpl; intros; try congruence.
          P0 _simpl val_eq.
          inv_false.
        * subst.
          preg_simpl.
          simpl.
          unfold Val.and.
          break_match; simpl; intros; try congruence.
  Qed.

  Definition aiken_5_proofs : rewrite_proofs :=
    {|
      defs := aiken_5_defs
      ; selr := aiken_5_selr
    |}.

  Definition peep_aiken_5 :
    concrete = fnd aiken_5_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite aiken_5_defs aiken_5_proofs.
  Qed.

End AIKEN_5.

Definition aiken_5_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_aiken_5 p.
  unfold aiken_5_defs in p.
  simpl in p.
  specialize (p c).
  do 3 (destruct c; [exact None | ]).
  destruct c; [ | exact None].

  set_instr_eq i 0%nat aiken_5_example.
  set_instr_eq i0 1%nat aiken_5_example.
  set_instr_eq i1 2%nat aiken_5_example.

  set_ireg_eq rd rd0.
  set_ireg_eq r1 rd0.

  set_testcond_eq c Cond_g.

  set_ireg_neq rd0 rd1.

  specialize (p rd0 rd1 n eq_refl). exact (Some p).
Defined.

Definition aiken_5 (c : code) : list StepEquiv.rewrite :=
  collect (map aiken_5_rewrite (ParamSplit.matched_pat aiken_5_example c)).


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

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Require Import common.lhs_sel_low_reduce.lhs_sel_low_reduce.
Require Import common.lhs_sel_upp_reduce.lhs_sel_upp_reduce.
Require Import common.lhs_sel_equ_reduce.lhs_sel_equ_reduce.
Require Import common.lhs_sel_nom_reduce.lhs_sel_nom_reduce.
Require Import common.lhs_all_reduce.lhs_all_reduce.
Require Import common.lhs_rfn_top_reduce.lhs_rfn_top_reduce.
Require Import common.lhs_rfn_sel_reduce.lhs_rfn_sel_reduce.
Require Import common.lhs_sha_top_reduce.lhs_sha_top_reduce.
Require Import common.lhs_sha_sel_reduce.lhs_sha_sel_reduce.
Require Import common.lhs_upp_reduce.lhs_upp_reduce.
Require Import common.lhs_low_reduce.lhs_low_reduce.
Require Import common.lhs_equ_reduce.lhs_equ_reduce.
Require Import common.lhs_nom_reduce.lhs_nom_reduce.
Require Import common.lhs_nil_reduce.lhs_nil_reduce.
Require Import common.lhs_con_reduce.lhs_con_reduce.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_lhs_sel_upp_reduce :
  forall T1 x1 L1 T1', T1 = t_sel_upp x1 L1 T1' ->
                  forall T2, subtype T1' T2 = true ->
                        (T2 <> t_nil) ->
                        (forall T2' Ts2, T2 <> t_con T2' Ts2) ->
                        (forall L2 T2', T2 <> t_upp L2 T2') ->
                        (forall L2 T2', T2 <> t_low L2 T2') ->
                        (forall L2 T2', T2 <> t_equ L2 T2') ->
                        (forall L2 t2 T2', T2 <> t_nom L2 t2 T2') ->
                        subtype T1 T2 = true.
Proof.
  intros.

  subst T1.
  rewrite subtype_sel_upp_reduce with (x1:=x1)(L1:=L1)(T1':=T1');
    [|auto].

  destruct T2; simpl; auto.

  rewrite H0, orb_true_r; auto.

  rewrite H0, orb_true_r; auto.

  rewrite H0, orb_true_r; auto.

  rewrite H0, orb_true_r; auto.

  contradiction (H3 l T2); auto.
  contradiction (H4 l T2); auto.
  contradiction (H5 l T2); auto.
  contradiction (H6 l t T2); auto.
  contradiction (H2 T2_1 T2_2); auto.
Qed.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Cartesian.
Require Export Category.Structure.Initial.
Require Export Category.Construction.Opposite.

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

Notation "'Cocartesian' C" := (@Cartesian (C^op))
(at level 9) : category_theory_scope.
Notation "@Cocartesian C" := (@Cartesian (C^op))
(at level 9) : category_theory_scope.

Section Cocartesian_.

Context `{O : @Cocartesian C}.

Definition Coprod : C -> C -> C := @product_obj _ O.

Infix "+" := Coprod (at level 50, left associativity) : object_scope.

Definition merge {x y z : C} (f : y ~> x) (g : z ~> x) : y + z ~{C}~> x :=
@fork _ O _ _ _ f g.

Infix "▽" := merge (at level 26) : morphism_scope.

Global Program Instance merge_respects {x y z} :
Proper (equiv ==> equiv ==> equiv) (@merge x y z).
Next Obligation. apply (@fork_respects _ O). Qed.

Definition inl {x y : C} : x ~{C}~> x + y := @exl _ O _ _.
Definition inr {x y : C} : y ~{C}~> x + y := @exr _ O _ _.

Definition left  {x y z : C} (f : x ~> y) : x + z ~{C}~> y + z :=
(inl ∘ f) ▽ inr.

Definition right  {x y z : C} (f : x ~> y) : z + x ~{C}~> z + y :=
inl ▽ (inr ∘ f).

Definition cover  {x y z w : C} (f : x ~> y) (g : z ~> w) :
x + z ~{C}~> y + w :=
(inl ∘ f) ▽ (inr ∘ g).

Global Program Instance parametric_morphism_left {a b c : C} :
Proper (equiv ==> equiv) (@left a b c).
Next Obligation. apply (@parametric_morphism_first _ O). Qed.

Global Program Instance parametric_morphism_right {a b c : C} :
Proper (equiv ==> equiv) (@right a b c).
Next Obligation. apply (@parametric_morphism_second _ O). Qed.

Global Program Instance parametric_morphism_cover {a b c d : C} :
Proper (equiv ==> equiv ==> equiv) (@cover a b c d).
Next Obligation.
proper.
unfold cover.
rewrites.
reflexivity.
Qed.

Definition paws {x y : C} : x + y ~{C}~> y + x := @swap _ O _ _.

Lemma inl_merge {x z w : C} (f : z ~> x) (g : w ~> x) :
f ▽ g ∘ inl ≈ f.
Proof. hammer_hook "Cocartesian" "Cocartesian.inl_merge". apply (@exl_fork _ O). Qed.

Hint Rewrite @inl_merge : categories.

Lemma inr_merge {x z w : C} (f : z ~> x) (g : w ~> x) :
f ▽ g ∘ inr ≈ g.
Proof. hammer_hook "Cocartesian" "Cocartesian.inr_merge". apply (@exr_fork _ O). Qed.

Hint Rewrite @inr_merge : categories.

Corollary merge_inl_inr {x y : C} :
inl ▽ inr ≈ @id C (x + y).
Proof. hammer_hook "Cocartesian" "Cocartesian.merge_inl_inr". apply (@fork_exl_exr _ O). Qed.

Hint Rewrite @merge_inl_inr : categories.

Corollary merge_inv {x y z : C} (f h : y ~> x) (g i : z ~> x) :
f ▽ g ≈ h ▽ i ↔ (f ≈ h) * (g ≈ i).
Proof. hammer_hook "Cocartesian" "Cocartesian.merge_inv". apply (@fork_inv _ O). Qed.

Corollary merge_comp {x y z w : C} (f : y ~> z) (h : w ~> z) (g : z ~> x) :
(g ∘ f) ▽ (g ∘ h) ≈ g ∘ f ▽ h.
Proof. hammer_hook "Cocartesian" "Cocartesian.merge_comp". apply (@fork_comp _ O). Qed.

Ltac unmerge :=
unfold paws, cover, left, right; simpl;
repeat (rewrite <- !merge_comp; cat;
rewrite <- !comp_assoc; cat).

Local Obligation Tactic := cat_simpl; unmerge.

Theorem left_id {x y : C} :
left (id[x]) ≈ id[x + y].
Proof. hammer_hook "Cocartesian" "Cocartesian.left_id". unfold left; cat. Qed.

Hint Rewrite @left_id : categories.

Theorem left_comp {x y z w : C} (f : y ~> z) (g : x ~> y) :
left (z:=w) (f ∘ g) ≈ left f ∘ left g.
Proof. hammer_hook "Cocartesian" "Cocartesian.left_comp". apply (@first_comp _ O). Qed.

Theorem left_fork {x y z w : C} (f : y ~> x) (g : z ~> x) (h : w ~> y) :
f ▽ g ∘ left h ≈ (f ∘ h) ▽ g.
Proof. hammer_hook "Cocartesian" "Cocartesian.left_fork". apply (@first_fork _ O). Qed.

Theorem right_id {x y : C} :
right (id[y]) ≈ id[x + y].
Proof. hammer_hook "Cocartesian" "Cocartesian.right_id". unfold right; cat. Qed.

Hint Rewrite @right_id : categories.

Theorem right_comp {x y z w : C} (f : y ~> z) (g : x ~> y) :
right (z:=w) (f ∘ g) ≈ right f ∘ right g.
Proof. hammer_hook "Cocartesian" "Cocartesian.right_comp". apply (@second_comp _ O). Qed.

Theorem right_fork {x y z w : C} (f : y ~> x) (g : z ~> x) (h : w ~> z) :
f ▽ g ∘ right h ≈ f ▽ (g ∘ h).
Proof. hammer_hook "Cocartesian" "Cocartesian.right_fork". apply (@second_fork _ O). Qed.

Corollary inl_left {x y z : C} (f : x ~> y) :
left f ∘ @inl x z ≈ inl ∘ f.
Proof. hammer_hook "Cocartesian" "Cocartesian.inl_left". apply (@exl_first _ O). Qed.

Hint Rewrite @inl_left : categories.

Corollary inr_left {x y z : C} (f : x ~> y) :
left f ∘ @inr x z ≈ inr.
Proof. hammer_hook "Cocartesian" "Cocartesian.inr_left". apply (@exr_first _ O). Qed.

Hint Rewrite @inr_left : categories.

Corollary inl_right {x y z : C} (f : x ~> y) :
right f ∘ @inl z x ≈ inl.
Proof. hammer_hook "Cocartesian" "Cocartesian.inl_right". apply (@exl_second _ O). Qed.

Hint Rewrite @inl_right : categories.

Corollary inr_right {x y z : C} (f : x ~> y) :
right f ∘ @inr z x ≈ inr ∘ f.
Proof. hammer_hook "Cocartesian" "Cocartesian.inr_right". apply (@exr_second _ O). Qed.

Hint Rewrite @inr_right : categories.

Theorem paws_left {x y z : C} (f : x ~> y) :
paws ∘ left (z:=z) f ≈ right f ∘ paws.
Proof. hammer_hook "Cocartesian" "Cocartesian.paws_left". symmetry; apply (@swap_second _ O y x z f). Qed.

Theorem paws_right {x y z : C} (f : x ~> y) :
paws ∘ right f ≈ left (z:=z) f ∘ paws.
Proof. hammer_hook "Cocartesian" "Cocartesian.paws_right". symmetry; apply (@swap_first _ O y x z f). Qed.

Theorem left_right {x y z w : C} (f : x ~> y) (g : z ~> w) :
left f ∘ right g ≈ right g ∘ left f.
Proof. hammer_hook "Cocartesian" "Cocartesian.left_right". symmetry; apply (@first_second _ O). Qed.

Theorem paws_fork {x y z : C} (f : y ~> x) (g : z ~> x) :
f ▽ g ∘ paws ≈ g ▽ f.
Proof. hammer_hook "Cocartesian" "Cocartesian.paws_fork". apply (@swap_fork _ O). Qed.

Definition paws_invol {x y : C} :
paws ∘ paws ≈ @id C (x + y).
Proof. hammer_hook "Cocartesian" "Cocartesian.paws_invol". unfold paws; apply (@swap_invol _ O). Qed.

Hint Rewrite @paws_invol : categories.

Theorem cover_id {x y : C} :
cover (id[x]) (id[y]) ≈ id[x + y].
Proof. hammer_hook "Cocartesian" "Cocartesian.cover_id". now unmerge; cat. Qed.

Hint Rewrite @cover_id : categories.

Theorem cover_comp {x y z w v u : C}
(f : y ~> z) (h : x ~> y) (g : v ~> u) (i : w ~> v) :
cover f g ∘ cover h i ≈ cover (f ∘ h) (g ∘ i).
Proof. hammer_hook "Cocartesian" "Cocartesian.cover_comp".
unmerge.
rewrite !comp_assoc.
rewrite <- merge_comp.
unfold cover.
rewrite !comp_assoc.
rewrite inl_merge.
rewrite inr_merge.
reflexivity.
Qed.

Theorem cover_left {x y z v u : C}
(f : y ~> z) (h : x ~> y) (g : v ~> u) :
cover f g ∘ left h ≈ cover (f ∘ h) g.
Proof. hammer_hook "Cocartesian" "Cocartesian.cover_left".
unmerge.
rewrite <- merge_comp.
rewrite inr_merge.
rewrite comp_assoc.
rewrite inl_merge.
rewrite comp_assoc.
reflexivity.
Qed.

Theorem left_cover {x y z v u : C}
(f : y ~> z) (h : x ~> y) (g : v ~> u) :
left f ∘ cover h g ≈ cover (f ∘ h) g.
Proof. hammer_hook "Cocartesian" "Cocartesian.left_cover".
unmerge.
rewrite <- merge_comp.
rewrite !comp_assoc.
rewrite inl_merge.
rewrite inr_merge.
reflexivity.
Qed.

Theorem cover_right {x y z v u : C}
(f : y ~> z) (h : x ~> y) (g : v ~> u) :
cover g f ∘ right h ≈ cover g (f ∘ h).
Proof. hammer_hook "Cocartesian" "Cocartesian.cover_right".
unmerge.
rewrite <- merge_comp.
rewrite !comp_assoc.
rewrite inl_merge.
rewrite inr_merge.
reflexivity.
Qed.

Theorem right_cover {x y z v u : C}
(f : y ~> z) (h : x ~> y) (g : v ~> u) :
right f ∘ cover g h ≈ cover g (f ∘ h).
Proof. hammer_hook "Cocartesian" "Cocartesian.right_cover".
unmerge.
rewrite <- merge_comp.
rewrite !comp_assoc.
rewrite inl_merge.
rewrite inr_merge.
reflexivity.
Qed.

Theorem cover_inl {x y z w : C} (f : x ~> y) (g : z ~> w):
cover f g ∘ inl ≈ inl ∘ f.
Proof. hammer_hook "Cocartesian" "Cocartesian.cover_inl". unmerge; cat. Qed.

Theorem cover_inr {x y z w : C} (f : x ~> y) (g : z ~> w):
cover f g ∘ inr ≈ inr ∘ g.
Proof. hammer_hook "Cocartesian" "Cocartesian.cover_inr". unmerge; cat. Qed.

Global Program Instance coprod_respects_iso :
Proper (Isomorphism ==> Isomorphism ==> Isomorphism) Coprod.
Next Obligation.
proper.
construct.
- exact (cover (to X) (to X0)).
- exact (cover (from X) (from X0)).
- now rewrite cover_comp, !iso_to_from, cover_id.
- now rewrite cover_comp, !iso_from_to, cover_id.
Defined.

Context `{I : @Initial C}.

Global Program Instance coprod_zero_l {x : C} :
0 + x ≅ x := {
to   := zero ▽ id;
from := inr
}.
Next Obligation. apply (@prod_one_l _ _ I). Qed.

Hint Rewrite @coprod_zero_l : isos.

Global Program Instance coprod_zero_r {x : C} :
x + 0 ≅ x := {
to   := id ▽ zero;
from := inl
}.
Next Obligation. apply (@prod_one_r _ _ I). Qed.

Hint Rewrite @coprod_zero_r : isos.

Global Program Instance coprod_comm  {x y : C} :
x + y ≅ y + x := {
to   := paws;
from := paws
}.

Global Program Instance coprod_assoc  {x y z : C} :
(x + y) + z ≅ x + (y + z) := {
to   := (inl ▽ (inr ∘ inl)) ▽ (inr ∘ inr);
from := (inl ∘ inl) ▽ ((inl ∘ inr) ▽ inr)
}.
Next Obligation. apply (@prod_assoc _ O). Qed.
Next Obligation. apply (@prod_assoc _ O). Qed.

End Cocartesian_.

Infix "+" := Coprod (at level 50, left associativity) : object_scope.
Infix "▽" := merge (at level 26) : morphism_scope.

Hint Rewrite @inl_merge : categories.
Hint Rewrite @inr_merge : categories.
Hint Rewrite @merge_inl_inr : categories.
Hint Rewrite @coprod_zero_r : isos.
Hint Rewrite @coprod_zero_l : isos.

Ltac unmerge :=
unfold paws, cover, left, right; simpl;
repeat (rewrite <- !merge_comp; cat;
rewrite <- !comp_assoc; cat).


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect eqtype.
Require Import List Max ZArith EqNat.
Require Import bipl seplog.
Require Import expr_b_dp.
Import seplog_Z_m.
Import seplog_Z_m.assert_m.expr_m.
Import seplog_Z_m.assert_m.
Require Import frag_list_triple frag_list_entail.

Local Open Scope heap_scope.
Local Open Scope seplog_expr_scope.
Local Open Scope seplog_cmd_scope.
Local Open Scope frag_list_scope.
Local Close Scope Z_scope.

(** initialize some field of an array of data-structure*)

Definition ptr : var.v := 1.
Definition startl : var.v := 2.
Definition size: var.v := 3.
Definition idx: var.v := 4.
Definition init_val: var.v := 5.

Fixpoint init_body (n: nat) {struct n} : @while.cmd cmd0 expr_b :=
  match n with
    0 => skip
    | S n' =>
      (var_e ptr \+ var_e idx) *<- var_e init_val;
       ptr <- var_e ptr \+ var_e size;
       init_body n'
   end.

Definition init (n: nat) : @while.cmd cmd0 expr_b :=
    ptr <- var_e startl;
    init_body n.

Fixpoint init_precond_sigma (n: nat) {struct n} : Sigma :=
  match n with
    0 => frag_list_entail.emp
    | S n' => star
        (cell (var_e startl \+ var_e idx \+ var_e size \* cst_e (Z_of_nat n')))
	(init_precond_sigma n')
end.

Definition init_precond (n: nat) : assrt :=
  (var_e startl \> cst_e 0%Z, init_precond_sigma n).

Fixpoint init_postcond_sigma (n: nat) {struct n}: Sigma :=
  match n with
    0 => frag_list_entail.emp
    | S n' => star
	(singl (var_e startl \+ var_e idx \+ var_e size \* cst_e (Z_of_nat n')) (var_e init_val))
	(init_postcond_sigma n')
end.

Definition init_postcond (n: nat) : assrt :=
  (var_e startl \> cst_e 0%Z, init_postcond_sigma n).

Lemma init_verif_bigtoe_12 : forall n, n = 12 ->
  {{{ init_precond n }}} init n {{{ init_postcond n }}}.
Proof.
intros; subst n.
rewrite /init; simpl init_body.
rewrite /init_precond; simpl init_precond_sigma.
rewrite /init_postcond; simpl init_postcond_sigma.
rewrite /ptr /startl /size /idx /init_val.
eapply tritra_use.
simpl; intuition.
Tritra.
Qed.


From Undecidability Require TM.TM TM.Util.TM_facts.
From Undecidability Require Import TM.SBTM TM.Util.SBTM_facts.
Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.FinTypes.

Require Import PeanoNat Lia.

#[local] Unset Implicit Arguments.
#[local] Unset Strict Implicit.

Require Import List ssreflect ssrbool ssrfun.
Import ListNotations SBTMNotations.

Set Default Goal Selector "!".

Module SBTM_facts.

  (* remove redundante false symbol *)
  Definition truncate (l : list bool) : list bool :=
    match l with
    | [false] => []
    | [a; false] => if a then [a] else []
    | _ => l
    end.

  Definition truncate_tape (t : tape) : tape :=
    match t with
    | (ls, a, rs) => (truncate ls, a, truncate rs)
    end.

  Lemma almost_eq_truncate l : almost_eq (truncate l) l.
  Proof.
    have ? := almost_eq_refl.
    have ? := almost_eq_false 0 0.
    have ? := almost_eq_false 0 1.
    have ? := almost_eq_false 0 2.
    move: l => [|[] [|[] [|??]]] /=; by do ? constructor.
  Qed.

  Lemma almost_eq_tape_truncate_tape t : almost_eq_tape (truncate_tape t) t.
  Proof.
    move: t => [[ls a] rs]. constructor; by apply: almost_eq_truncate.
  Qed.

  #[local] Opaque step.

  Lemma steps_truncate {M k q t} :
    steps M k (q, truncate_tape t) = None <-> (steps M k (q, t) = None).
  Proof.
    apply: almost_eq_tape_steps_None.
    apply: almost_eq_tape_truncate_tape.
  Qed.

End SBTM_facts.

(* translate between Fin and a listable type *)
Module ListFin.
  Fixpoint decode {X : Type} (L : list X) (i : Fin.t (length L)) : X :=
    (match L return Fin.t (length L) -> X with
    | [] => fun j => Fin.case0 (fun=> X) j
    | x :: L' => fun j => Fin.caseS' j (fun=> X) x (fun j' => decode L' j')
    end) i.

  Definition encode_sig
    {X : Type} (HX : forall (x y : X), {x = y} + {x <> y})
    {L : list X} (HL : forall x, In x L) (x : X) :
      {i : Fin.t (length L) | decode L i = x }.
  Proof.
    elim: L {HL} (HL x); first done.
    move=> y L IH /=. case: (HX y x).
    - move=> -> _. by exists Fin.F1.
    - move=> ??. have /IH [i Hi] : In x L by tauto.
      by exists (Fin.FS i).
  Qed.

  Definition encode
    {X : Type} (HX : forall (x y : X), {x = y} + {x <> y})
    {L : list X} (HL : forall x, In x L) (x : X) :
      Fin.t (length L) := sval (encode_sig HX HL x).

  Lemma decode_encode
    {X : Type} (HX : forall (x y : X), {x = y} + {x <> y})
    {L : list X} (HL : forall x, In x L)
    (x : X) : decode L (encode HX HL x) = x.
  Proof. exact: (svalP (encode_sig HX HL x)). Qed.
End ListFin.

Import SBTM_facts.

Section Construction.
  (* input TM *)
  Context (M : TM.TM (finType_CS bool) 1).

  (* symbols are "01", "11" *)
  Definition encode_symbol (a : finType_CS bool) : list bool := [a; true].

  (* blank is 00 *)
  Definition encode_tape (t : TM.tape (finType_CS bool)) : tape :=
    match t with
    | TM.niltape => ([], false, [])
    | TM.leftof a rs => ([], false, flat_map encode_symbol (a :: rs))
    | TM.rightof a ls => (false :: flat_map (fun a' => rev (encode_symbol a')) (a :: ls), false, [])
    | TM.midtape ls a rs => (a :: flat_map (fun a' => rev (encode_symbol a')) ls, true, flat_map encode_symbol rs)
    end.

  Inductive space : Type :=
  (* corresponds to q *)
  | space_base (q : TM.state M) : space
  (* reading symbol *)
  | space_read (q : TM.state M) : space
  (* stepping twice in direction d *)
  | space_move (q : TM.state M) (d : direction) (t : bool) : space
  (* test next symbol in direction d: on false return, on true q *)
  | space_test (q : TM.state M) (d : direction) (t : bool) : space
  (* write b then move in direction *)
  | space_write (q : TM.state M) (a : bool) (d : TM.move) : space.

  Lemma listable_space : {L : list space | forall x, In x L}.
  Proof.
    have : {L' | forall (d : direction) (t : bool) (m : TM.move), In (d, t, m) L'}.
    { exists (list_prod (list_prod [go_left; go_right] [true; false]) [TM.Lmove; TM.Rmove; TM.Nmove]).
      move=> [] [] [] /=; tauto. }
    move=> [L' HL'].
    exists (
      flat_map (fun '(q, (d, t, m)) =>
        [space_base q; space_read q; space_move q d t; space_test q d t; space_write q t m])
        (list_prod (elem (TM.state M)) L')).
    move=> [].
    - move=> q. apply /in_flat_map.
      exists (q, (go_left, true, TM.Lmove)) => /=. split; last tauto.
      apply /in_prod; by [apply: elem_spec|].
    - move=> q. apply /in_flat_map.
      exists (q, (go_left, true, TM.Lmove)) => /=. split; last tauto.
      apply /in_prod; by [apply: elem_spec|].
    - move=> q d t. apply /in_flat_map.
      exists (q, (d, t, TM.Lmove)) => /=. split; last tauto.
      apply /in_prod; by [apply: elem_spec|].
    - move=> q d t. apply /in_flat_map.
      exists (q, (d, t, TM.Lmove)) => /=. split; last tauto.
      apply /in_prod; by [apply: elem_spec|].
    - move=> q a m. apply /in_flat_map.
      exists (q, (go_left, a, m)) => /=. split; last tauto.
      apply /in_prod; by [apply: elem_spec|].
  Qed.

  Lemma eqdec_space : forall (x y : space), {x = y} + {x <> y}.
  Proof.
    have := @eqType_dec (TM.state M). move=> H.
    intros. do ? decide equality; by apply: H.
  Qed.

  #[local] Notation size := (length (sval listable_space)).

  Definition encode_space : space -> Fin.t size :=
    fun x => ListFin.encode eqdec_space (svalP listable_space) x.

  Definition decode_space : Fin.t size -> space :=
    fun x => ListFin.decode (sval listable_space) x.

  Lemma decode_encode_space (x : space) : decode_space (encode_space x) = x.
  Proof. by apply: ListFin.decode_encode. Qed.

  #[local] Notation "| a |" := (Vector.cons _ a 0 (Vector.nil _)).

  #[local] Notation encode_state q := (encode_space (space_base q)).

  Definition go_back (d : direction) :=
    match d with
    | go_left => go_right
    | go_right => go_left
    end.

  Definition M' : SBTM.
  Proof using M.
    refine (Build_SBTM size
      (construct_trans (fun '(q, a) => _))).
    (* in state q reading symbol a *)
    refine (
      match decode_space q with
      | space_base q_base => _
      | space_read q_read => _
      (* move d twice *)
      | space_move q' d true =>
          Some (encode_space (space_move q' d false), a, d)
      (* move d once *)
      | space_move q' d false =>
          Some (encode_state q', a, d)
      (* test d in distance 1 *)
      | space_test q' d true =>
          Some (encode_space (space_test q' d false), a, d)
      (* test *)
      | space_test q' d false =>
          match a with
          | true => Some (encode_space (space_move q' go_right false), a, go_left)
          | false => Some (encode_space (space_move q' (go_back d) false), a, go_back d)
          end
      (* write *)
      | space_write q' b TM.Lmove =>
          Some (encode_state q', b, go_left)
      | space_write q' b TM.Rmove =>
          Some (encode_space (space_move q' go_right true), b, go_right)
      | space_write q' b TM.Nmove =>
          Some (encode_state q', b, go_right)
      end).
    + (* case space_base *)
      refine (
        match TM.halt M q_base with
        (* halting condition *)
        | true => None
        | false =>
            match a with
            (* a = true, read actual symbol *)
            | true => Some (encode_space (space_read q_base), true, go_left)
            (* case a = false, no symbol *)
            | false =>
              match TM.trans M (q_base, | None |) with
              | (q_next, result) =>
                  match Vector.hd result with
                  (* case write b, move *)
                  | (Some b, m) => Some (encode_space (space_write q_next b m), true, go_left)
                  (* case no write *)
                  | (None, TM.Lmove) => Some (encode_space (space_test q_next go_left true), a, go_left)
                  | (None, TM.Rmove) => Some (encode_space (space_test q_next go_right true), a, go_right)
                  | (None, TM.Nmove) =>  Some (encode_space (space_move q_next go_right false), a, go_left)
                  end
              end
            end
        end).
    + (* case space_read *)
      refine (
        match TM.trans M (q_read, | Some a |) with
        | (q_next, result) =>
          match Vector.hd result with
          (* case write bL, Lmove *)
          | (Some bL, TM.Lmove) => Some (encode_state q_next, bL, go_left)
          (* case write bR, Rmove *)
          | (Some bR, TM.Rmove) => Some (encode_space (space_move q_next go_right true), bR, go_right)
          (* case write bN, Nmove *)
          | (Some bN, TM.Nmove) => Some (encode_state q_next, bN, go_right)
          (* case no write *)
          | (None, TM.Lmove) => Some (encode_state q_next, a, go_left)
          | (None, TM.Rmove) => Some (encode_space (space_move q_next go_right true), a, go_right)
          | (None, TM.Nmove) => Some (encode_state q_next, a, go_right)
          end
        end).
  Defined.

  #[local] Notation step := (step M').
  #[local] Notation steps := (steps M').
  #[local] Notation state := (state M').
  #[local] Notation config := (config M').

  #[local] Notation TM_step x := (@TM_facts.step _ _ M x).
  #[local] Notation TM_config := (@TM_facts.mconfig (finType_CS bool) (TM.state M) 1).

  Definition encode_config : TM_config -> config :=
    fun '(TM_facts.mk_mconfig q ctapes) =>
      (encode_state q, truncate_tape (encode_tape (Vector.hd ctapes))).

  (* simulation up to truncation *)
  Lemma simulation_step q t : TM.halt M q = false ->
    exists k,
      (omap (fun '(q', t') => (q', truncate_tape t')) (steps (S k) (encode_state q, encode_tape t))) =
        Some (encode_config (TM_step (TM_facts.mk_mconfig q (| t |)))).
  Proof.
    move=> Hq. case: t.
    - (* case niltape *)
      rewrite /TM_facts.step.
      move E: (TM.trans _) => [q' a']. move: E.
      rewrite (Vector.eta a') /TM_facts.current_chars /=.
      move: (Vector.hd a') => [ob m] /=.
      case: m ob.
      + (* case Lmove *)
        move=> [b|] /= E.
        * exists 1. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
        * exists 3. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
      + (* case Rmove *)
        move=> [b|] /= E.
        * exists 3. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
        * exists 3. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
      + (* case Nmove *)
        move=> [b|] /= E.
        * exists 1. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
        * exists 1. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
    - (* case leftof *)
      move=> a rs.
      rewrite /TM_facts.step.
      move E: (TM.trans _) => [q' a']. move: E.
      rewrite (Vector.eta a') /TM_facts.current_chars /=.
      move: (Vector.hd a') => [ob m] /=.
      case: m ob.
      + (* case Lmove *)
        move=> [b|] /= E.
        * exists 1. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
        * exists 3. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
      + (* case Rmove *)
        move=> [b|] /= E.
        * exists 3. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
        * exists 3. do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
          by case: a.
      + (* case Nmove *)
        move=> [b|] /= E.
        * exists 1. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
        * exists 1. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
    - (* case rightof *)
      move=> a ls.
      rewrite /TM_facts.step.
      move E: (TM.trans _) => [q' a']. move: E.
      rewrite (Vector.eta a') /TM_facts.current_chars /=.
      move: (Vector.hd a') => [ob m] /=.
      case: m ob.
      + (* case Lmove *)
        move=> [b|] /= E.
        * exists 1. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
        * exists 3. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
      + (* case Rmove *)
        move=> [b|] /= E.
        * exists 3. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
        * exists 3. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
      + (* case Nmove *)
        move=> [b|] /= E.
        * exists 1. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
        * exists 1. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
    - (* case midtape *)
      move=> ls a rs.
      rewrite /TM_facts.step.
      move E: (TM.trans _) => [q' a']. move: E.
      rewrite (Vector.eta a') /TM_facts.current_chars /=.
      move: (Vector.hd a') => [ob m] /=.
      case: m ob.
      + (* case Lmove *)
        move=> [b|] /= E.
        * exists 1. do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
          move: ls => [|l ls]; by do ? rewrite construct_trans_spec decode_encode_space.
        * exists 1. do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
          move: ls => [|l ls]; by do ? rewrite /= construct_trans_spec decode_encode_space.
      + (* case Rmove *)
        move=> [b|] /= E.
        * exists 3. do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
          move: rs => [|r rs]; by do ? rewrite /= construct_trans_spec decode_encode_space.
        * exists 3. do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
          move: rs => [|r rs]; by do ? rewrite /= construct_trans_spec decode_encode_space.
      + (* case Nmove *)
        move=> [b|] /= E.
        * exists 1. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
        * exists 1. by do ? rewrite /= /step /= construct_trans_spec decode_encode_space ?E ?Hq.
  Qed.

  Lemma simulation_halt q t : TM.halt M q = true ->
    step (encode_state q, t) = None.
  Proof.
    move: t => [[? ?] ?] /= Hq.
    by rewrite /= /step /= construct_trans_spec decode_encode_space ?Hq.
  Qed.

  Lemma simulation q t :
    (exists q' t', TM.eval M q t q' t') ->
    exists k, steps k ((encode_state q), (encode_tape (Vector.hd t))) = None.
  Proof.
    move=> [q'] [t'] /TM_facts.TM_eval_iff [n].
    elim: n q t.
    { move=> q t. rewrite /= /TM_facts.haltConf /=.
      case E: (TM.halt q) => [|]; last done.
      move: E => /simulation_halt H _.
      exists 1. by apply: H. }
    move=> n IH q t. rewrite /= /TM_facts.haltConf /=.
    case E: (TM.halt q) => [|].
    { move: E => /simulation_halt H _. exists 1. by apply: H. }
    rewrite (Vector.eta t).
    move: E => /simulation_step => /(_ (Vector.hd t)) [k1].
    move: (VectorDef.tl t). apply: Vector.case0.
    move: (TM_step _) => [q'' ts''] Hk1 /IH [k2 Hk2] /=.
    exists ((S k1) + k2). rewrite (steps_plus).
    move: (encode_state q, _) Hk1 Hk2 => x.
    move Hk1: (steps (S k1) x) => [[q''' t''']|] /=; last done.
    move=> [] <- Ht''' /(@steps_truncate M').
    rewrite -Ht'''. by move=> /steps_truncate.
  Qed.

  Lemma inverse_simulation q t k :
    steps k ((encode_state q), (encode_tape (Vector.hd t))) = None ->
    exists q' t', TM.eval M q t q' t'.
  Proof.
    elim: k q t; first done.
    move=> k IH q t.
    move Hq: (TM.halt q) => [|].
    { move=> _. exists q, t. by apply: TM.eval_halt. }
    move: (Hq) => /simulation_step => /(_ (Vector.hd t)).
    move=> [k1].
    move Hk1: (steps (S k1) _) => [[q' t']|]; last done.
    move=> [] Hq't'.
    move: Hk1 => /steps_sync H /H{H} /steps_truncate.
    move E: (TM_step _) Hq't' => [q'' t''].
    move=> [] -> -> /steps_truncate /IH.
    move=> [q'''] [t'''] /TM_facts.TM_eval_iff [n Hn].
    exists q''', t'''. apply /TM_facts.TM_eval_iff. exists (S n).
    rewrite /= /TM_facts.haltConf Hq -Hn -E (Vector.eta t) /=.
    move: (Vector.tl t). by apply: Vector.case0.
  Qed.

End Construction.

Require Import Undecidability.Synthetic.Definitions.
Require Import Undecidability.Synthetic.ReducibilityFacts.
Require Undecidability.TM.Reductions.Arbitrary_to_Binary.

Theorem reduction :
  TM.HaltTM 1 ⪯ SBTM_HALT.
Proof.
  apply: (reduces_transitive Arbitrary_to_Binary.reduction).
  exists (fun '(M, t) =>
    existT _ (M' M) (encode_config M (TM_facts.mk_mconfig (TM.start M) t))).
  move=> [M t]. split.
  - move=> /simulation [k Hk]. exists k.
    by move: Hk => /steps_truncate.
  - by move=> [k] /steps_truncate /inverse_simulation.
Qed.


Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.ExprI.

Set Implicit Arguments.
Set Strict Implicit.

Section parameterized.
  Context {typ expr : Set}.
  Context {RType_typ : RType typ}.
  Context {Expr_expr : Expr typ expr}.
  Variable T : Type.
  Context {Typ0_T : Typ0 _ T}.

  Definition exprD_typ0 (tus tvs : list typ) (goal : expr)
  : option (exprT tus tvs T) :=
    match exprD tus tvs (@typ0 _ _ _ _) goal
          return option (exprT tus tvs T)
    with
    | None => None
    | Some val =>
      Some match typ0_cast(F:=T) in _ = T return exprT tus tvs T with
           | eq_refl => val
           end
    end.

  Lemma exprD_typ0_conv
  : forall (tus tvs tus' tvs' : list typ) (pfu : tus' = tus) (pfv : tvs' = tvs),
      exprD_typ0 tus tvs =
      match pfu in _ = tu , pfv in _ = tv
            return expr -> option (exprT tu tv T)
      with
      | eq_refl , eq_refl => exprD_typ0 tus' tvs'
      end.
  Proof.
    destruct pfu; destruct pfv. reflexivity.
  Qed.

  Lemma exprD_typ0_weaken (ExprOk_expr : ExprOk _)
  : forall (tus tvs tus' tvs' : tenv typ) (l0 : expr)
           (lD : exprT tus tvs T),
      exprD_typ0 tus tvs l0 = Some lD ->
      exists
        lD' : exprT (tus ++ tus') (tvs ++ tvs') T,
        exprD_typ0 (tus ++ tus') (tvs ++ tvs') l0 = Some lD' /\
        (forall (us : hlist typD tus) (vs : hlist typD tvs)
                (us' : hlist typD tus') (vs' : hlist typD tvs'),
           lD us vs = lD' (hlist_app us us') (hlist_app vs vs')).
  Proof.
    unfold exprD_typ0.
    intros. forward. inv_all; subst.
    eapply exprD_weaken with (tus' := tus') (tvs' := tvs') in H; eauto.
    forward_reason. rewrite H.
    eexists; split; eauto. intros.
    autorewrite with eq_rw; simpl.
    rewrite <- H0.
    reflexivity.
  Qed.

  Definition exprD_typ0_weakenU (ExprOk_expr : ExprOk _)
  : forall (tus tvs tus' : tenv typ) (l0 : expr)
           (lD : hlist typD tus -> hlist typD tvs -> T),
      exprD_typ0 tus tvs l0 = Some lD ->
      exists
        lD' : hlist typD (tus ++ tus') -> hlist typD tvs -> T,
        exprD_typ0 (tus ++ tus') tvs l0 = Some lD' /\
        (forall (us : hlist typD tus) (us' : hlist typD tus')
                (vs : hlist typD tvs),
           lD us vs = lD' (hlist_app us us') vs).
  Proof.
    unfold exprD_typ0. intros.
    forwardy.
    inv_all; subst.
    apply exprD_weakenU with (tus' := tus') in H; eauto.
    forward_reason.
    rewrite H.
    eexists; split; eauto.
    intros.
    autorewrite with eq_rw; simpl.
    erewrite H0. reflexivity.
  Qed.

  Definition exprD_typ0_weakenV (ExprOk_expr : ExprOk _)
  : forall (tus tvs tvs' : tenv typ) (l0 : expr)
           (lD : hlist typD tus -> hlist typD tvs -> T),
      exprD_typ0 tus tvs l0 = Some lD ->
      exists
        lD' : hlist typD tus -> hlist typD (tvs ++ tvs') -> T,
        exprD_typ0 tus (tvs ++ tvs') l0 = Some lD' /\
        (forall (us : hlist typD tus) (vs : hlist typD tvs)
                (vs' : hlist typD tvs'),
           lD us vs = lD' us (hlist_app vs vs')).
  Proof.
    unfold exprD_typ0. intros.
    forwardy.
    inv_all; subst.
    apply exprD_weakenV with (tvs' := tvs') in H; eauto.
    forward_reason.
    rewrite H.
    eexists; split; eauto.
    intros.
    autorewrite with eq_rw.
    erewrite H0. reflexivity.
  Qed.

End parameterized.

Arguments exprD_typ0_weakenU {_ _ _ _ _ _ _ tus tvs} tus' {_ _} _ : rename.
Arguments exprD_typ0_weakenV {_ _ _ _ _ _ _ tus tvs} tvs' {_ _} _ : rename.
Arguments exprD_typ0_weaken {_ _ _ _ _ _ _ tus tvs} tus' tvs' {_ _} _ : rename.


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

Require Import ZArith.
From IntMap Require Import Map.
Require Import zcgraph.
Require Extraction.

Axiom int : Set.
Axiom i2p : int -> positive.
Axiom i2a : int -> ad.
Axiom i2z : int -> Z.

Extract Inductive option => option [ Some None ].

Extract Inlined Constant int => "int".

Extract Constant i2p =>
 "
  let rec i2p = function
    1 -> XH
  | n -> let n' = i2p (n/2) in if (n mod 2)=0 then XO n' else XI n'
  in i2p
".

Extract Constant i2a => " function
    0 -> N0
  | n -> Npos (i2p n)
".

Extract Constant i2z =>
   " function
    0 -> Z0
  | n -> if n < 0 then Zneg (i2p (-n)) else Zpos (i2p n)
".

Extraction "checker.ml" ZCG_prove i2p i2a i2z.