From VLSM.Lib Require Import Itauto.
From stdpp Require Import prelude.
From VLSM.Core Require Import VLSM VLSMProjections.VLSMEmbedding VLSMProjections.VLSMTotalProjection.

(** * VLSM Inclusion

  When both VLSMs have the same state and label types they also share the
  same [Trace] type, and sets of traces can be compared without conversion.
  Then VLSM <<X>> is _included_ in VLSM <<Y>> if every [valid_trace] available to <<X>>
  is also available to <<Y>>.
*)
Section sec_VLSM_inclusion.

Context
  {message : Type}
  {vtype : VLSMType message}
  .

Definition VLSM_incl_part
  (MX MY : VLSMMachine vtype)
  (X := mk_vlsm MX) (Y := mk_vlsm MY)
  :=
  forall t : Trace,
    valid_trace_prop X t -> valid_trace_prop Y t.

#[local] Notation VLSM_incl X Y := (VLSM_incl_part (machine X) (machine Y)).

Lemma VLSM_incl_refl
  (MX : VLSMMachine vtype)
  (X := mk_vlsm MX)
  : VLSM_incl X X.
Proof.
  by firstorder.
Qed.

Lemma VLSM_incl_trans
  (MX MY MZ : VLSMMachine vtype)
  (X := mk_vlsm MX) (Y := mk_vlsm MY) (Z := mk_vlsm MZ)
  : VLSM_incl X Y -> VLSM_incl Y Z -> VLSM_incl X Z.
Proof.
  by firstorder.
Qed.

Lemma VLSM_incl_finite_traces_characterization
  (MX MY : VLSMMachine vtype)
  (X := mk_vlsm MX) (Y := mk_vlsm MY)
  : VLSM_incl X Y <->
    forall (s : vstate X)
    (tr : list (vtransition_item X)),
    finite_valid_trace X s tr -> finite_valid_trace Y s tr.
Proof.
  split; intros Hincl.
  - by intros; apply (Hincl (Finite s tr)).
  - intros tr Htr.
    destruct tr as [is tr | is tr]; simpl in *.
    + by apply Hincl.
    + destruct Htr as [HtrX HisX].
      assert (His_tr : finite_valid_trace X is []).
      {
        split; [| done].
        by constructor; apply initial_state_is_valid.
      }
      apply Hincl in His_tr.
      destruct His_tr as [_ HisY].
      split; [| done].
      apply infinite_valid_trace_from_prefix_rev.
      intros.
      pose proof (infinite_valid_trace_from_prefix _ _ _ HtrX n) as HfinX.
      by apply Hincl.
Qed.

(**
  A [VLSM_incl]usion is equivalent to a [VLSM_embedding] in which both the
  label and state projection functions are identities.
*)
Lemma VLSM_incl_embedding_iff
  (MX MY : VLSMMachine vtype)
  (X := mk_vlsm MX) (Y := mk_vlsm MY)
  : VLSM_incl X Y <-> VLSM_embedding X Y id id.
Proof.
  assert (Hid : forall tr, tr = pre_VLSM_embedding_finite_trace_project _ _ id id tr).
  {
    induction tr; [done |].
    by destruct a; cbn; f_equal.
  }
  split.
  - constructor; intros.
    apply (proj1 (VLSM_incl_finite_traces_characterization (machine X) (machine Y)) H) in H0.
    replace (pre_VLSM_embedding_finite_trace_project _ _ _ _ trX) with trX; [done |].
    by apply Hid.
  - intro Hproject. apply VLSM_incl_finite_traces_characterization.
    intros. apply (VLSM_embedding_finite_valid_trace Hproject) in H.
    replace (VLSM_embedding_finite_trace_project Hproject _) with tr in H; [done |].
    by apply Hid.
Qed.

Definition VLSM_incl_is_embedding
  {MX MY : VLSMMachine vtype}
  (X := mk_vlsm MX) (Y := mk_vlsm MY)
  (Hincl : VLSM_incl X Y)
  : VLSM_embedding X Y id id
  := proj1 (VLSM_incl_embedding_iff MX MY) Hincl.

Lemma VLSM_incl_is_embedding_finite_trace_project
  {MX MY : VLSMMachine vtype}
  (X := mk_vlsm MX) (Y := mk_vlsm MY)
  (Hincl : VLSM_incl X Y)
  : forall tr,
    VLSM_embedding_finite_trace_project (VLSM_incl_is_embedding Hincl) tr = tr.
Proof.
  induction tr; [done |].
  simpl. f_equal; [| done].
  by destruct a.
Qed.

End sec_VLSM_inclusion.

Notation VLSM_incl X Y := (VLSM_incl_part (machine X) (machine Y)).

Section sec_VLSM_incl_preservation.

(** ** VLSM inclusion preservation *)

Context
  {message : Type}
  {T : VLSMType message}
  (MX MY : VLSMMachine T)
  (X := mk_vlsm MX)
  (Y := mk_vlsm MY)
  .

Definition weak_incl_valid_preservation : Prop :=
  weak_embedding_valid_preservation X Y id id.

Definition strong_incl_valid_preservation : Prop :=
  strong_embedding_valid_preservation X Y id id.

Definition weak_incl_transition_preservation : Prop :=
  weak_embedding_transition_preservation X Y id id.

Definition strong_incl_transition_preservation : Prop :=
  strong_embedding_transition_preservation X Y id id.

Definition strong_incl_initial_state_preservation : Prop :=
  strong_projection_initial_state_preservation X Y id.

Definition weak_incl_initial_message_preservation : Prop :=
  weak_embedding_initial_message_preservation X Y id.

Definition strong_incl_initial_message_preservation : Prop :=
  strong_embedding_initial_message_preservation X Y.

End sec_VLSM_incl_preservation.

Section sec_VLSM_incl_properties.

(** ** VLSM inclusion properties *)

Context
  {message : Type} [vtype : VLSMType message]
  [MX MY : VLSMMachine vtype]
  (Hincl : VLSM_incl_part MX MY)
  (X := mk_vlsm MX)
  (Y := mk_vlsm MY)
  .

(** VLSM inclusion specialized to finite trace. *)

Lemma VLSM_incl_finite_valid_trace
  (s : vstate X)
  (tr : list (vtransition_item X))
  (Htr : finite_valid_trace X s tr)
  : finite_valid_trace Y s tr.
Proof.
  apply (VLSM_embedding_finite_valid_trace (VLSM_incl_is_embedding Hincl))
    in Htr.
  by rewrite (VLSM_incl_is_embedding_finite_trace_project Hincl) in Htr.
Qed.

Lemma VLSM_incl_finite_valid_trace_init_to
  (s f : vstate X)
  (tr : list (vtransition_item X))
  (Htr : finite_valid_trace_init_to X s f tr)
  : finite_valid_trace_init_to Y s f tr.
Proof.
  apply (VLSM_embedding_finite_valid_trace_init_to (VLSM_incl_is_embedding Hincl))
    in Htr.
  by rewrite (VLSM_incl_is_embedding_finite_trace_project Hincl) in Htr.
Qed.

Lemma VLSM_incl_valid_state
  (s : vstate X)
  (Hs : valid_state_prop X s)
  : valid_state_prop Y s.
Proof.
  by apply (VLSM_embedding_valid_state (VLSM_incl_is_embedding Hincl)).
Qed.

Lemma VLSM_incl_initial_state
  (is : vstate X)
  : vinitial_state_prop X is -> vinitial_state_prop Y is.
Proof.
  by apply (VLSM_embedding_initial_state (VLSM_incl_is_embedding Hincl)).
Qed.

Lemma VLSM_incl_finite_valid_trace_from
  (s : vstate X)
  (tr : list (vtransition_item X))
  (Htr : finite_valid_trace_from X s tr)
  : finite_valid_trace_from Y s tr.
Proof.
  apply (VLSM_embedding_finite_valid_trace_from (VLSM_incl_is_embedding Hincl))
    in Htr.
  by rewrite (VLSM_incl_is_embedding_finite_trace_project Hincl) in Htr.
Qed.

Lemma VLSM_incl_finite_valid_trace_from_to
  (s f : vstate X)
  (tr : list (vtransition_item X))
  (Htr : finite_valid_trace_from_to X s f tr)
  : finite_valid_trace_from_to Y s f tr.
Proof.
  apply (VLSM_embedding_finite_valid_trace_from_to (VLSM_incl_is_embedding Hincl))
    in Htr.
  by rewrite (VLSM_incl_is_embedding_finite_trace_project Hincl) in Htr.
Qed.

Lemma VLSM_incl_in_futures
  (s1 s2 : vstate X)
  : in_futures X s1 s2 -> in_futures Y s1 s2.
Proof.
  by apply (VLSM_embedding_in_futures (VLSM_incl_is_embedding Hincl)).
Qed.

Lemma VLSM_incl_input_valid_transition
  : forall l s im s' om,
  input_valid_transition X l (s, im) (s', om) ->
  input_valid_transition Y l (s, im) (s', om).
Proof.
  by apply (VLSM_embedding_input_valid_transition (VLSM_incl_is_embedding Hincl)).
Qed.

Lemma VLSM_incl_input_valid
  : forall l s im,
  input_valid X l (s, im) ->
  input_valid Y l (s, im).
Proof.
  by apply (VLSM_embedding_input_valid (VLSM_incl_is_embedding Hincl)).
Qed.

(**
  [VLSM_incl] almost implies inclusion of the [valid_state_message_prop] sets.
  Some additional hypotheses are required because [VLSM_incl] only
  refers to traces, and [valid_initial_state_message] means that
  [valid_state_message_prop] includes some pairs that do not appear in any
  transition.
*)
Lemma VLSM_incl_valid_state_message
  (Hmessage : strong_incl_initial_message_preservation MX MY)
  : forall s om, valid_state_message_prop X s om -> valid_state_message_prop Y s om.
Proof.
  intros s om.
  by apply (VLSM_embedding_valid_state_message (VLSM_incl_is_embedding Hincl)).
Qed.

Lemma VLSM_incl_can_produce
  (s : state)
  (om : option message)
  : option_can_produce X s om -> option_can_produce Y s om.
Proof.
  by apply (VLSM_embedding_can_produce (VLSM_incl_is_embedding Hincl)).
Qed.

Lemma VLSM_incl_can_emit
  (m : message)
  : can_emit X m -> can_emit Y m.
Proof.
  by apply (VLSM_embedding_can_emit (VLSM_incl_is_embedding Hincl)).
Qed.

Definition VLSM_incl_valid_message
  (Hinitial_valid_message : strong_incl_initial_message_preservation MX MY)
  : forall (m : message),
    valid_message_prop X m -> valid_message_prop Y m.
Proof.
  intros m [s Hm].
  by exists s; revert Hm; apply VLSM_incl_valid_state_message.
Qed.

Lemma VLSM_incl_infinite_valid_trace_from
  s ls
  : infinite_valid_trace_from X s ls ->
    infinite_valid_trace_from Y s ls.
Proof.
  intros Hls.
  apply (VLSM_embedding_infinite_valid_trace_from (VLSM_incl_is_embedding Hincl)) in Hls.
  revert Hls.
  apply infinite_valid_trace_from_EqSt.
  apply Streams.ntheq_eqst.
  unfold VLSM_embedding_infinite_trace_project, pre_VLSM_embedding_infinite_trace_project.
  intro n. rewrite Streams.Str_nth_map.
  by destruct (Streams.Str_nth _ _).
Qed.

Lemma VLSM_incl_infinite_valid_trace
  s ls
  : infinite_valid_trace X s ls -> infinite_valid_trace Y s ls.
Proof.
  intros [Htr His]. split.
  - by apply VLSM_incl_infinite_valid_trace_from.
  - by apply VLSM_incl_initial_state.
Qed.

Lemma VLSM_incl_valid_trace
  : forall t, valid_trace_prop X t -> valid_trace_prop Y t.
Proof.
  intros [s tr | s tr]; simpl.
  - by apply VLSM_incl_finite_valid_trace.
  - by apply VLSM_incl_infinite_valid_trace.
Qed.

End sec_VLSM_incl_properties.

(** We instantiate the above for VLSM inclusions *)
Section sec_basic_VLSM_incl.

Context
  {message : Type}
  {T : VLSMType message}
  (MX MY : VLSMMachine T)
  (X := mk_vlsm MX)
  (Y := mk_vlsm MY)
  .

Lemma basic_VLSM_incl
  (Hinitial_state : strong_incl_initial_state_preservation MX MY)
  (Hinitial_valid_message : weak_incl_initial_message_preservation MX MY)
  (Hvalid : weak_incl_valid_preservation MX MY)
  (Htransition : weak_incl_transition_preservation MX MY)
  : VLSM_incl X Y.
Proof.
  by apply VLSM_incl_embedding_iff, basic_VLSM_embedding.
Qed.

Lemma basic_VLSM_strong_incl
  (Hinitial_state : strong_incl_initial_state_preservation MX MY)
  (Hinitial_valid_message : strong_incl_initial_message_preservation MX MY)
  (Hvalid : strong_incl_valid_preservation MX MY)
  (Htransition : strong_incl_transition_preservation MX MY)
  : VLSM_incl X Y.
Proof.
  by apply VLSM_incl_embedding_iff, basic_VLSM_strong_embedding.
Qed.

Lemma basic_VLSM_incl_preloaded
  (Hinitial_state : strong_incl_initial_state_preservation MX MY)
  (Hvalid : strong_incl_valid_preservation MX MY)
  (Htransition : strong_incl_transition_preservation MX MY)
  : VLSM_incl (pre_loaded_with_all_messages_vlsm X) (pre_loaded_with_all_messages_vlsm Y).
Proof.
  by apply VLSM_incl_embedding_iff, (basic_VLSM_embedding_preloaded X Y id id).
Qed.

Lemma basic_VLSM_incl_preloaded_with
  (P Q : message -> Prop)
  (PimpliesQ : forall m : message, P m -> Q m)
  (Hvalid : strong_incl_valid_preservation MX MY)
  (Htransition : strong_incl_transition_preservation  MX MY)
  (Hstate : strong_incl_initial_state_preservation MX MY)
  (Hmessage : strong_incl_initial_message_preservation MX MY)
  : VLSM_incl (pre_loaded_vlsm X P) (pre_loaded_vlsm Y Q).
Proof.
  by apply VLSM_incl_embedding_iff,
           (basic_VLSM_embedding_preloaded_with X Y _ _ PimpliesQ id id).
Qed.

End sec_basic_VLSM_incl.

Section sec_VLSM_incl_preloaded_properties.

Context
  {message : Type}
  (X : VLSM message)
  .

Lemma vlsm_incl_pre_loaded_with_all_messages_vlsm
  : VLSM_incl X (pre_loaded_with_all_messages_vlsm X).
Proof.
  apply VLSM_incl_finite_traces_characterization.
  intros. split; [| by apply H].
  apply preloaded_weaken_valid_trace_from.
  by destruct X; apply H.
Qed.

Lemma pre_loaded_vlsm_incl_relaxed
  (P Q : message -> Prop)
  (PimpliesQorValid : forall m : message, P m -> Q m \/ valid_message_prop (pre_loaded_vlsm X Q) m)
  : VLSM_incl (pre_loaded_vlsm X P) (pre_loaded_vlsm X Q).
Proof.
  apply basic_VLSM_incl; cycle 1; [| by cbv; itauto..].
  intros _ _ m _ _ [Him | Hp].
  - by apply initial_message_is_valid; left.
  - apply PimpliesQorValid in Hp as [Hq | Hvalid]; [| done].
    by apply initial_message_is_valid; right.
Qed.

Lemma pre_loaded_vlsm_incl
  (P Q : message -> Prop)
  (PimpliesQ : forall m : message, P m -> Q m)
  : VLSM_incl (pre_loaded_vlsm X P) (pre_loaded_vlsm X Q).
Proof.
  by apply pre_loaded_vlsm_incl_relaxed; itauto.
Qed.

Lemma pre_loaded_vlsm_idem_l
  (P : message -> Prop)
  : VLSM_incl (pre_loaded_vlsm (pre_loaded_vlsm X P) P) (pre_loaded_vlsm X P).
Proof.
  by apply basic_VLSM_strong_incl; cbv; itauto.
Qed.

Lemma pre_loaded_vlsm_idem_r
  (P : message -> Prop)
  : VLSM_incl (pre_loaded_vlsm X P) (pre_loaded_vlsm (pre_loaded_vlsm X P) P).
Proof.
  by apply basic_VLSM_incl_preloaded_with; cbv; itauto.
Qed.

Lemma pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True_l
  : VLSM_incl (pre_loaded_with_all_messages_vlsm X) (pre_loaded_vlsm X (fun m => True)).
Proof.
  by apply basic_VLSM_strong_incl; cbv; itauto.
Qed.

Lemma pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True_r
  : VLSM_incl (pre_loaded_vlsm X (fun m => True)) (pre_loaded_with_all_messages_vlsm X).
Proof.
  by apply basic_VLSM_strong_incl; cbv; itauto.
Qed.

Lemma pre_loaded_vlsm_incl_pre_loaded_with_all_messages
  (P : message -> Prop)
  : VLSM_incl (pre_loaded_vlsm X P) (pre_loaded_with_all_messages_vlsm X).
Proof.
  by apply basic_VLSM_strong_incl; cbv; itauto.
Qed.

Lemma vlsm_incl_pre_loaded
  (P : message -> Prop)
  : VLSM_incl X (pre_loaded_vlsm X P).
Proof.
  eapply VLSM_incl_trans; [| by apply pre_loaded_vlsm_incl].
  by apply basic_VLSM_strong_incl; cbv; itauto.
Qed.

Lemma pre_loaded_with_all_messages_vlsm_idem_l :
  VLSM_incl
    (pre_loaded_with_all_messages_vlsm (pre_loaded_with_all_messages_vlsm X))
    (pre_loaded_with_all_messages_vlsm X).
Proof.
  by apply basic_VLSM_strong_incl; cbv; itauto.
Qed.

Lemma pre_loaded_with_all_messages_vlsm_idem_r :
  VLSM_incl
    (pre_loaded_with_all_messages_vlsm X)
    (pre_loaded_with_all_messages_vlsm (pre_loaded_with_all_messages_vlsm X)).
Proof.
  by apply basic_VLSM_incl_preloaded; cbv; itauto.
Qed.

Lemma pre_loaded_with_all_messages_can_emit
  (m : message)
  (Hm : can_emit X m)
  : can_emit (pre_loaded_with_all_messages_vlsm X) m.
Proof.
  apply (VLSM_incl_can_emit vlsm_incl_pre_loaded_with_all_messages_vlsm).
  by rewrite mk_vlsm_machine.
Qed.

Lemma preloaded_weaken_finite_valid_trace_from
  (from : state) (tr : list transition_item)
  : finite_valid_trace_from X from tr ->
    finite_valid_trace_from (pre_loaded_with_all_messages_vlsm X) from tr.
Proof.
  by intros; eapply VLSM_incl_finite_valid_trace_from;
    [apply vlsm_incl_pre_loaded_with_all_messages_vlsm | destruct X].
Qed.

Lemma preloaded_weaken_finite_valid_trace_from_to
  (from to : state) (tr : list transition_item)
  : finite_valid_trace_from_to X from to tr ->
    finite_valid_trace_from_to (pre_loaded_with_all_messages_vlsm X) from to tr.
Proof.
  by intros; eapply VLSM_incl_finite_valid_trace_from_to;
    [apply vlsm_incl_pre_loaded_with_all_messages_vlsm | destruct X].
Qed.

End sec_VLSM_incl_preloaded_properties.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export bar_induction2_con.
Require Export subst_tacs.
Require Export sequents_equality.
Require Export per_props_isect.
Require Export lsubstc_vars.

(* !!MOVE *)
Lemma eq_kseq_trans {o} :
  forall lib (s1 s2 s3 : @CTerm o) n,
    eq_kseq lib s1 s2 n
    -> eq_kseq lib s2 s3 n
    -> eq_kseq lib s1 s3 n.
Proof.
  introv eqk1 eqk2.
  unfold eq_kseq in *.
  eapply equality_trans; eauto.
Qed.

(* !!MOVE *)
Lemma type_natk2nat_if_member_nat {o} :
  forall lib (t : @CTerm o),
    member lib t mkc_tnat
    -> type lib (natk2nat t).
Proof.
  introv mem.
  apply tequality_natk2nat.
  apply member_tnat_implies_computes in mem; exrepnd.
  exists (Z.of_nat k) (Z.of_nat k).
  rewrite <- mkc_nat_eq; dands; spcast; auto.
  introv lek.
  destruct (Z.le_gt_cases (Z.of_nat k) k0) as [d|d]; tcsp.
Qed.

(* !!MOVE *)
Lemma is_seq_implies_is_kseq {o} :
  forall lib (s : @CTerm o) n,
    is_seq lib s
    -> is_kseq lib s n.
Proof.
  introv iss.
  unfold is_seq in iss; unfold is_kseq, eq_kseq.
  apply equality_nat2nat_to_natk2nat; auto.
  apply nat_in_nat.
Qed.

(**

  Bar induction, where
    X is the proposition
    B is the bar
    ext(s,n,t) = \m. if m=n then t else s m
<<
   H |- ↓(X 0 (norm c 0))

     By bar_induction B R i a s x m n con t

     H, n:ℕ, s: ℕn → ℕ |- (B n s) ∈ Type(i)                                   // B is a well-formed predicate on finite sequences
     H, n:ℕ, s: ℕn → ℕ |- (R n s) ∈ Type(i)                                   // R is a well-formed predicate on finite sequences
     H, s:ℕ → ℕ, con:(∩m:ℕ.↓(R m s)) |- ↓(∃n:ℕ. B n s)                       // B is a bar
     H, n:ℕ, s:ℕn → ℕ, con:↓(R n s), m: B n s |- X n s                         // Base case: the conclusion is true at the bar
     H, n:ℕ, s:ℕn → ℕ, x:(∩m:ℕ.↓(R n s) → ↓(X (n + 1) (ext(s,n,m)))) |- X n s   // induction case
>>

*)

Definition rule_bar_induction_nat_con {o}
           (f X c B R e : @NTerm o)
           (s n m v x con : NVar)
           (i : nat)
           (H : barehypotheses) :=
  mk_rule
    (mk_bseq H (mk_conclax (mk_squash (mk_apply2 X mk_zero (mk_seq2kseq c (mk_nat 0) v)))))
    [ (* well-formedness of the bar B *)
      mk_bseq (snoc (snoc H (mk_hyp n mk_tnat))
                    (mk_hyp s (mk_natk2nat (mk_var n))))
              (mk_conclax (mk_member (mk_apply2 B (mk_var n) (mk_var s)) (mk_uni i))),

      (* well-formedness of the condition R *)
      mk_bseq (snoc (snoc H (mk_hyp n mk_tnat))
                    (mk_hyp s (mk_natk2nat (mk_var n))))
              (mk_conclax (mk_member (mk_apply2 R (mk_var n) (mk_var s)) (mk_uni i))),

      (* B is a bar *)
      mk_bseq (snoc (snoc H (mk_hyp s mk_nat2nat))
                    (mk_hyp con (mk_isect
                                   mk_tnat
                                   m
                                   (mk_squash (mk_apply2 R (mk_var m) (mk_var s))))))
              (mk_conclax (mk_squash
                             (mk_exists
                                mk_tnat
                                n
                                (mk_apply2 B (mk_var n) (mk_var s))))),

      (* base case *)
      mk_bseq (snoc (snoc (snoc (snoc H (mk_hyp n mk_tnat))
                                (mk_hyp s (mk_natk2nat (mk_var n))))
                          (mk_hyp con (mk_squash (mk_apply2 R (mk_var n) (mk_var s)))))
                    (mk_hyp m (mk_apply2 B (mk_var n) (mk_var s))))
              (mk_concl (mk_apply2 X (mk_var n) (mk_var s)) e),

      (* induction case *)
      mk_bseq (snoc (snoc (snoc H (mk_hyp n mk_tnat))
                          (mk_hyp s (mk_natk2nat (mk_var n))))
                    (mk_hyp x (mk_isect
                                 mk_tnat
                                 m
                                 (mk_ufun
                                    (mk_squash (mk_apply2 R (mk_var n) (mk_var s)))
                                    (mk_squash (mk_apply2 X (mk_plus1 (mk_var n)) (mk_update_seq (mk_var s) (mk_var n) (mk_var m) v)))))))
              (mk_conclax (mk_apply2 X (mk_var n) (mk_var s)))
    ]
    [].

Lemma rule_bar_induction_nat_con_true {o} :
  forall lib (f X c B R d e : @NTerm o)
         (s n m v x con : NVar)
         (i : nat)
         (H : @barehypotheses o)
         (dxv : x <> v)
         (dsv : s <> v)
         (dnv : n <> v)
         (dmv : m <> v)
         (dconv : con <> v)
         (dnm : n <> m)
         (dsm : s <> m)
         (nvc : !LIn v (free_vars c))
         (nnB : !LIn n (free_vars B))
         (nsB : !LIn s (free_vars B))
         (nnR : !LIn n (free_vars R))
         (nsR : !LIn s (free_vars R)),
    rule_true lib (rule_bar_induction_nat_con f X c B R e s n m v x con i H).
Proof.
  unfold rule_bar_induction_nat_con, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp  as [wf1 hyp_wfb].
  destruct Hyp0 as [wf2 hyp_wfr].
  destruct Hyp1 as [wf3 hyp_bar].
  destruct Hyp2 as [wf4 hyp_imp].
  destruct Hyp3 as [wf5 hyp_ind].
  destseq; allsimpl; proof_irr; GC.

  unfold closed_extract; simpl.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  assert (s <> n
          # s <> x
          # n <> x
          # con <> n
          # con <> s
          # con <> m
          # !LIn x (free_vars c)
          # !LIn s (free_vars c)
          # !LIn n (free_vars c)
          # !LIn con (free_vars c)
          # !LIn x (free_vars X)
          # !LIn s (free_vars X)
          # !LIn n (free_vars X)
          # !LIn m (free_vars X)
          # !LIn con (free_vars X)
          # !LIn con (free_vars B)
          # !LIn m (free_vars R)
          # !LIn x (vars_hyps H)
          # !LIn s (vars_hyps H)
          # !LIn n (vars_hyps H)
          # !LIn con (vars_hyps H)) as vhyps.

  {
    clear hyp_wfb hyp_wfr hyp_bar hyp_ind hyp_imp.
    dwfseq.
    assert (forall x : NVar, LIn x (free_vars c) -> x <> v -> LIn x (vars_hyps H)) as imp.
    {
      introv h1 h2.
      apply cg.
      repeat (first [rw remove_nvars_cons_r|rw remove_nvars_app_r]).
      allrw memvar_singleton.
      allrw <- beq_var_refl.
      allrw remove_nvars_nil_r; allrw app_nil_r.
      rw in_remove_nvars; rw in_single_iff; sp.
    }
    sp; GC;
      try (complete (discover; allapply @subset_hs_vars_hyps; sp));
      try (complete (pose proof (ct10 con) as xx; autodimp xx hyp;
                     repeat (rw in_snoc in xx); repndors; tcsp));
      try (complete (pose proof (ct9 m) as xx; autodimp xx hyp;
                     repeat (rw in_snoc in xx); repndors; tcsp)).
  }

  destruct vhyps as [ nsn vhyps ].
  destruct vhyps as [ nsx vhyps ].
  destruct vhyps as [ nnx vhyps ].
  destruct vhyps as [ nconn vhyps ].
  destruct vhyps as [ ncons vhyps ].
  destruct vhyps as [ nconm vhyps ].
  destruct vhyps as [ nxc vhyps ].
  destruct vhyps as [ nsc vhyps ].
  destruct vhyps as [ nnc vhyps ].
  destruct vhyps as [ nconc vhyps ].
  destruct vhyps as [ nxX vhyps ].
  destruct vhyps as [ nsX vhyps ].
  destruct vhyps as [ nnX vhyps ].
  destruct vhyps as [ nmX vhyps ].
  destruct vhyps as [ nconX vhyps ].
  destruct vhyps as [ nxH vhyps ].
  destruct vhyps as [ nsH vhyps ].
  destruct vhyps as [ nnH nconH ].
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.

  pose proof (lsubstc_mk_seq2kseq c 0 v w3 s1 c3) as sc1.
  repeat (autodimp sc1 hyp).
  exrepnd.
  rw sc1.

  pose proof (lsubstc_mk_seq2kseq c 0 v w3 s2 c7) as sc2.
  autodimp sc2 hyp.
  exrepnd.
  rw sc2.

  clear sc1 sc2.
  clear_irr.
  clear_wf_hyps.

  rw @tequality_mkc_squash.
  rw @member_mkc_squash.

  assert (!LIn n (dom_csub s1)) as nns1.
  { apply similarity_dom in sim; repnd.
    rw sim0; auto. }

  assert (!LIn n (dom_csub s2)) as nns2.
  { apply similarity_dom in sim; repnd.
    rw sim; auto. }

  assert (!LIn s (dom_csub s1)) as nss1.
  { apply similarity_dom in sim; repnd.
    rw sim0; auto. }

  assert (!LIn s (dom_csub s2)) as nss2.
  { apply similarity_dom in sim; repnd.
    rw sim; auto. }

  assert (!LIn x (dom_csub s1)) as nxs1.
  { apply similarity_dom in sim; repnd.
    rw sim0; auto. }

  assert (!LIn x (dom_csub s2)) as nxs2.
  { apply similarity_dom in sim; repnd.
    rw sim; auto. }

  assert (!LIn con (dom_csub s1)) as ncons1.
  { apply similarity_dom in sim; repnd.
    rw sim0; auto. }

  assert (!LIn con (dom_csub s2)) as ncons2.
  { apply similarity_dom in sim; repnd.
    rw sim; auto. }

  assert (wf_term B) as wB.
  { clear hyp_wfb.
    allrw @wf_member_iff2.
    allrw <- @wf_apply2_iff; sp.
  }

  assert (wf_term R) as wR.
  { clear hyp_wfr.
    allrw @wf_member_iff2.
    allrw <- @wf_apply2_iff; sp.
  }

  assert (cover_vars R s1 # cover_vars R s2) as cR.
  { clear hyp_wfr.
    allrw @covered_member.
    allrw @covered_apply2; repnd.
    allrw @vars_hyps_snoc; allsimpl.
    apply covered_snoc_implies in ct7; auto.
    apply covered_snoc_implies in ct7; auto.
    dands.
    - eapply s_cover_typ1;[exact ct7|exact sim].
    - eapply s_cover_typ1;[exact ct7|].
      apply similarity_sym in sim;[exact sim|]; auto.
  }
  destruct cR as [cR1 cR2].

  assert (cover_vars B s1 # cover_vars B s2) as cB.
  { clear hyp_wfb.
    allrw @covered_member.
    allrw @covered_apply2; repnd.
    allrw @vars_hyps_snoc; allsimpl.
    apply covered_snoc_implies in ct7; auto.
    apply covered_snoc_implies in ct7; auto.
    dands.
    - eapply s_cover_typ1;[exact ct7|exact sim].
    - eapply s_cover_typ1;[exact ct7|].
      apply similarity_sym in sim;[exact sim|]; auto.
  }
  destruct cB as [cB1 cB2].

  assert (forall k seq1 seq2 s1a s2a cB1 cB2,
            similarity lib s1a s2a H
            -> hyps_functionality lib s1a H
            -> eq_kseq lib seq1 seq2 k
            -> tequality
                 lib
                 (mkc_apply2 (lsubstc B wB s1a cB1) (mkc_nat k) seq1)
                 (mkc_apply2 (lsubstc B wB s2a cB2) (mkc_nat k) seq2)) as Bfunc.
  { introv sim0 hf0 eqk.
    vr_seq_true in hyp_wfb.
    pose proof (hyp_wfb
                  (snoc (snoc s1a (n,mkc_nat k)) (s,seq1))
                  (snoc (snoc s2a (n,mkc_nat k)) (s,seq2)))
      as h; clear hyp_wfb.
    repeat (autodimp h hyp).

    { apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; inj.
        eapply tequality_respects_alphaeqc_left;
          [apply alphaeqc_sym; apply lsubstc_mk_natk2nat_sp2; auto;
           apply similarity_dom in sim'3; repnd; rw sim'0; auto
          |].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym; apply lsubstc_mk_natk2nat_sp2; auto;
           apply similarity_dom in sim'3; repnd; rw sim'3; auto
          |].
        allrw @lsubstc_mkc_tnat.
        apply equality_int_nat_implies_cequivc in sim'1.
        eapply tequality_respects_cequivc_right;
          [apply implies_cequivc_natk2nat; exact sim'1|].
        eauto 3 with slow.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      introv equ' sim'.
      allrw @lsubstc_mkc_tnat.
      apply tnat_type.
    }

    { assert (@wf_term o (mk_natk2nat (mk_var n))) as wfn.
      { apply wf_term_mk_natk2nat; auto. }
      assert (cover_vars (mk_natk2nat (mk_var n)) (snoc s1a (n,mkc_nat k))) as cvn.
      { apply cover_vars_mk_natk2nat.
        apply cover_vars_var.
        rw @dom_csub_snoc.
        rw in_snoc; simpl; sp. }
      sim_snoc.
      dands; auto.

      { pose proof (cover_vars_mk_tnat s1a) as cvs1.
        pose proof (@wf_tnat o) as wftn.
        sim_snoc.
        dands; auto.
        allrw @lsubstc_mkc_tnat.
        apply equality_in_tnat_nat.
      }

      eapply alphaeqc_preserving_equality;
        [|apply alphaeqc_sym;
           apply lsubstc_mk_natk2nat_sp2; auto];
        auto.
      apply similarity_dom in sim0; repnd.
      rw sim1; auto.
    }

    exrepnd.
    lsubst_tac.
    apply tequality_in_uni_implies_tequality in h0; auto.
    apply member_if_inhabited in h1. auto.
  }

  assert (forall k seq1 seq2 s1a s2a cR1 cR2,
            similarity lib s1a s2a H
            -> hyps_functionality lib s1a H
            -> eq_kseq lib seq1 seq2 k
            -> tequality
                 lib
                 (mkc_apply2 (lsubstc R wR s1a cR1) (mkc_nat k) seq1)
                 (mkc_apply2 (lsubstc R wR s2a cR2) (mkc_nat k) seq2)) as Rfunc.
  { introv sim0 hf0 eqk.
    vr_seq_true in hyp_wfr.
    pose proof (hyp_wfr
                  (snoc (snoc s1a (n,mkc_nat k)) (s,seq1))
                  (snoc (snoc s2a (n,mkc_nat k)) (s,seq2)))
      as h; clear hyp_wfr.
    repeat (autodimp h hyp).

    { apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; inj.
        eapply tequality_respects_alphaeqc_left;
          [apply alphaeqc_sym; apply lsubstc_mk_natk2nat_sp2; auto;
           apply similarity_dom in sim'3; repnd; rw sim'0; auto
          |].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym; apply lsubstc_mk_natk2nat_sp2; auto;
           apply similarity_dom in sim'3; repnd; rw sim'3; auto
          |].
        allrw @lsubstc_mkc_tnat.
        apply equality_int_nat_implies_cequivc in sim'1.
        eapply tequality_respects_cequivc_right;
          [apply implies_cequivc_natk2nat; exact sim'1|].
        eauto 3 with slow.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      introv equ' sim'.
      allrw @lsubstc_mkc_tnat.
      apply tnat_type.
    }

    { assert (@wf_term o (mk_natk2nat (mk_var n))) as wfn.
      { apply wf_term_mk_natk2nat; auto. }
      assert (cover_vars (mk_natk2nat (mk_var n)) (snoc s1a (n,mkc_nat k))) as cvn.
      { apply cover_vars_mk_natk2nat.
        apply cover_vars_var.
        rw @dom_csub_snoc.
        rw in_snoc; simpl; sp. }
      sim_snoc.
      dands; auto.

      { pose proof (cover_vars_mk_tnat s1a) as cvs1.
        pose proof (@wf_tnat o) as wftn.
        sim_snoc.
        dands; auto.
        allrw @lsubstc_mkc_tnat.
        apply equality_in_tnat_nat.
      }

      eapply alphaeqc_preserving_equality;
        [|apply alphaeqc_sym;
           apply lsubstc_mk_natk2nat_sp2; auto];
        auto.
      apply similarity_dom in sim0; repnd.
      rw sim1; auto.
    }

    exrepnd.
    lsubst_tac.
    apply tequality_in_uni_implies_tequality in h0; auto.
    apply member_if_inhabited in h1.
    auto.
  }

  pose proof (bar_induction_meta4_con
                lib
                (fun_sim_eq lib s1 H B wB)
                (fun_sim_eq lib s1 H R wR)
                (fun_sim_eq lib s1 H X w0)
                (lsubstc B wB s1 cB1)
                (lsubstc R wR s1 cR1)
                (lsubstc X w0 s1 c0)
                (lsubstc c wt s1 ct4)
                v)
    as bi.

  repeat (autodimp bi hyp);
    [idtac (* well-formedness or R *)
    |idtac (* bar *)
    |idtac (* base case *)
    |idtac (* inductive case *)
    |(* conclusion *)
    pose proof (bi (lsubstc X w0 s2 c5) (seq2kseq (lsubstc c wt s2 ct5) 0 v)) as h;
    allrw <- @mkc_zero_eq;
    repeat (autodimp h hyp);[apply eq_kseq_seq2kseq_0|idtac|repnd; dands; complete auto];
    exists s2 c5;
    dands; complete auto
    ].

  - (* well-formedness of R *)
    introv eqk fos eqk1 fsim.
    unfold meta2_fun_on_seq in fos.
    pose proof (fos A2 s4) as q; clear fos.
    repeat (autodimp q hyp).
    { eapply eq_kseq_trans; eauto. }
    repnd.

    pose proof (Rfunc n0 s0 s3 s1 s1 cR1 cR1) as hr.
    repeat (autodimp hr hyp).
    { eapply similarity_refl; eauto. }

    dands.

    { eapply inhabited_type_tequality; eauto. }

    { eapply tequality_trans;[|exact q].
      apply tequality_sym; auto. }

  - (* base hypothesis *)
    intros seq1 iss mR.

    vr_seq_true in hyp_bar.
    pose proof (hyp_bar
                  (snoc (snoc s1 (s,seq1)) (con,mkc_axiom))
                  (snoc (snoc s1 (s,seq1)) (con,mkc_axiom)))
      as hf; clear hyp_bar.
    repeat (autodimp hf hyp).

    { apply hyps_functionality_snoc2; simpl; auto.

      {
        introv equ' sim'.

        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; inj.

        eapply alphaeqc_preserving_equality in sim'1;[|apply lsubstc_mk_nat2nat].

        lsubst_tac.
        apply tequality_isect.
        autorewrite with slow.
        dands; eauto 2 with slow.
        { apply tnat_type. }
        introv equn.
        repeat substc_lsubstc_vars3.
        lsubst_tac_c.
        apply tequality_mkc_squash.

        apply equality_in_tnat in equn.
        unfold equality_of_nat in equn; exrepnd; spcast.

        pose proof (Rfunc k t1 t2 s1a s2a cR1 c22) as hr.
        repeat (autodimp hr hyp).
        { unfold eq_kseq.
          apply equality_nat2nat_to_natk2nat; auto.
          apply nat_in_nat. }

        eapply tequality_respects_cequivc_left;
          [apply cequivc_sym;
           apply implies_cequivc_apply2;
           [apply cequivc_refl
           |apply computes_to_valc_implies_cequivc;exact equn1
           |apply cequivc_refl]
          |].
        eapply tequality_respects_cequivc_right;
          [apply cequivc_sym;
           apply implies_cequivc_apply2;
           [apply cequivc_refl
           |apply computes_to_valc_implies_cequivc;exact equn0
           |apply cequivc_refl]
          |].
        auto.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      {
        introv equ' sim'.
        eapply tequality_respects_alphaeqc_left;
          [apply alphaeqc_sym;
           apply lsubstc_mk_nat2nat; auto
          |].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym;
           apply lsubstc_mk_nat2nat; auto
          |].
        apply type_nat2nat.
      }
    }

    {
      assert (wf_term (mk_isect mk_tnat m (mk_squash (mk_apply2 R (mk_var m) (mk_var s))))) as wfi.
      {
        apply wf_isect; eauto 2 with slow.
        apply wf_squash.
        apply wf_apply2; eauto 2 with slow.
      }

      assert (cover_vars (mk_isect mk_tnat m (mk_squash (mk_apply2 R (mk_var m) (mk_var s))))
                         (snoc s1 (s, seq1))) as covi.
      {
        apply cover_vars_isect; dands; eauto 2 with slow.
        apply cover_vars_upto_squash.
        rewrite csub_filter_snoc; rewrite memvar_singleton; boolvar; tcsp.
        apply cover_vars_upto_apply2; dands; eauto 2 with slow.
        { apply cover_vars_upto_snoc_weak.
          apply cover_vars_upto_csub_filter_disjoint; eauto 2 with slow.
          apply disjoint_singleton_r; auto. }
        { apply cover_vars_upto_var; simpl; tcsp. }
        { apply cover_vars_upto_var; simpl.
          rewrite dom_csub_snoc; simpl; rw in_snoc; tcsp. }
      }
      sim_snoc2; dands; auto.

      {
        assert (cover_vars mk_nat2nat s1) as cvn.
        { apply cover_vars_mk_nat2nat. }
        sim_snoc2; dands; auto.
        { apply similarity_refl in sim; auto. }
        eapply alphaeqc_preserving_equality;
          [|apply alphaeqc_sym;
            apply lsubstc_mk_nat2nat; auto].
        auto.
      }

      lsubst_tac_c.
      apply member_in_isect.
      rewrite lsubstc_mk_tnat.
      dands; eauto 2 with slow.
      introv equn.
      repeat substc_lsubstc_vars3.
      lsubst_tac_c.
      rw @tequality_mkc_squash.
      rw @member_mkc_squash.

      apply equality_in_tnat in equn.
      unfold equality_of_nat in equn; exrepnd; spcast.
      pose proof (mR k (lsubstc R wR s1 cR1) seq1) as q.
      repeat (autodimp q hyp).

      {
        apply is_seq_implies_is_kseq.
        unfold eq_kseq; auto.
      }

      {
        unfold fun_sim_eq.
        exists s1 cR1; dands; auto.
        apply similarity_refl in sim; auto.
      }

      repnd.
      dands; auto.

      {
        eapply inhabited_type_cequivc;
          [apply cequivc_sym;
           apply implies_cequivc_apply2;
           [apply cequivc_refl
           |apply computes_to_valc_implies_cequivc;exact equn1
           |apply cequivc_refl]
          |].
        auto.
      }

      {
        eapply tequality_respects_cequivc_left;
          [apply cequivc_sym;
           apply implies_cequivc_apply2;
           [apply cequivc_refl
           |apply computes_to_valc_implies_cequivc;exact equn1
           |apply cequivc_refl]
          |].
        eapply tequality_respects_cequivc_right;
          [apply cequivc_sym;
           apply implies_cequivc_apply2;
           [apply cequivc_refl
           |apply computes_to_valc_implies_cequivc;exact equn0
           |apply cequivc_refl]
          |].
        auto.
      }
    }

    exrepnd.
    clear hf0.
    lsubst_tac.
    apply equality_in_mkc_squash in hf1; exrepnd.
    clear hf0 hf2.
    allunfold @mk_exists.
    lsubst_tac.
    allrw @lsubstc_mkc_tnat.
    apply inhabited_product in hf1; exrepnd.
    clear hf2.

    apply member_tnat_implies_computes in hf1; exrepnd.

    exists k.
    introv eqs fse.
    unfold fun_sim_eq in fse; exrepnd; subst.

    repeat substc_lsubstc_vars3.
    lsubst_tac.
    clear_wf_hyps.
    proof_irr.

    pose proof (Bfunc k seq1 (seq2kseq seq1 k v) s1 s1 cB1 cB1) as h.
    repeat (autodimp h hyp); eauto 3 with slow.

    { eapply similarity_refl; eauto. }

    { apply seq2kseq_prop3; auto.
      apply is_seq_implies_is_kseq; auto. }

    eapply inhabited_type_cequivc in hf3;
      [|apply implies_cequivc_apply2;
         [apply cequivc_refl
         |apply computes_to_valc_implies_cequivc;eauto
         |apply cequivc_refl]
      ].

    eapply inhabited_type_tequality in hf3;[|eauto].

    dands; auto.

  - (* base case *)
    intros k seq1 iss sr sb C seq2 eqs fse.
    clear iss.
    unfold fun_sim_eq in fse; exrepnd; subst.
    unfold meta2_fun_on_seq in sb.
    unfold meta2_fun_on_seq in sr.
    rename fse0 into sim0.

    assert (cover_vars B s0) as cB0.
    { eapply similarity_cover_vars;[exact sim0|]; auto. }

    assert (cover_vars R s0) as cR0.
    { eapply similarity_cover_vars;[exact sim0|]; auto. }

    pose proof (sb (lsubstc B wB s0 cB0) seq2) as hb; clear sb.
    repeat (autodimp hb hyp).
    { exists s0 cB0; dands; auto. }
    repnd.

    pose proof (sr (lsubstc R wR s0 cR0) seq2) as hr; clear sr.
    repeat (autodimp hr hyp).
    { exists s0 cR0; dands; auto. }
    repnd.

    unfold inhabited_type in hb0; exrepnd.
    rename hb1 into memb.
    rename hb  into teqb.
    rename hr0 into inhr.
    rename hr  into teqr.

    vr_seq_true in hyp_imp.
    pose proof (hyp_imp
                  (snoc (snoc (snoc (snoc s1 (n,mkc_nat k)) (s,seq1)) (con,mkc_axiom)) (m,t))
                  (snoc (snoc (snoc (snoc s0 (n,mkc_nat k)) (s,seq2)) (con,mkc_axiom)) (m,t)))
      as hf.
    repeat (autodimp hf hyp).

    { apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; inj.
        apply similarity_snoc in sim'3; simpl in sim'3.
        exrepnd; subst; ginv; inj.
        apply similarity_snoc in sim'4; simpl in sim'4.
        exrepnd; subst; ginv; inj.
        lsubst_tac.
        allrw @lsubstc_mkc_tnat.
        apply equality_int_nat_implies_cequivc in sim'3.
        eapply alphaeqc_preserving_equality in sim'2;
          [|apply lsubstc_mk_natk2nat_sp2; auto].
        eapply tequality_respects_cequivc_right;
          [apply implies_cequivc_apply2;
            [apply cequivc_refl
            |exact sim'3
            |apply cequivc_refl]
          |].
        auto.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; inj.
        apply similarity_snoc in sim'3; simpl in sim'3.
        exrepnd; subst; ginv; inj.
        lsubst_tac.
        allrw @lsubstc_mkc_tnat.
        apply equality_int_nat_implies_cequivc in sim'2.
        eapply alphaeqc_preserving_equality in sim'1;
          [|apply lsubstc_mk_natk2nat_sp2; auto].
        apply tequality_mkc_squash.
        eapply tequality_respects_cequivc_right;
          [apply implies_cequivc_apply2;
            [apply cequivc_refl
            |exact sim'2
            |apply cequivc_refl]
          |].
        auto.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; cpx.
        assert (!LIn n (dom_csub s2a)) as nns2a.
        { apply similarity_dom in sim'3; repnd.
          rw sim'3; auto. }
        eapply tequality_respects_alphaeqc_left;
          [apply alphaeqc_sym;
            apply lsubstc_mk_natk2nat_sp2; auto
          |].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym;
            apply lsubstc_mk_natk2nat_sp2; auto
          |].
        rw @lsubstc_mkc_tnat in sim'1.
        apply equality_int_nat_implies_cequivc in sim'1.
        eapply tequality_respects_cequivc_right;
          [apply implies_cequivc_natk2nat; exact sim'1|].
        eauto 3 with slow.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      introv equ' sim'.
      allrw @lsubstc_mkc_tnat.
      apply tnat_type.
    }

    { assert (wf_term (mk_apply2 B (mk_var n) (mk_var s))) as wfn.
      { apply wf_apply2; eauto 3 with slow. }
      assert (cover_vars (mk_apply2 B (mk_var n) (mk_var s)) (snoc (snoc (snoc s1 (n,mkc_nat k)) (s,seq1)) (con,mkc_axiom))) as cvn.
      { apply cover_vars_apply2.
        repeat (rw @cover_vars_var_iff).
        repeat (rw @dom_csub_snoc); simpl.
        repeat (rw in_snoc).
        dands; tcsp.
        repeat (apply cover_vars_snoc_weak); auto. }
      sim_snoc2.
      dands; auto.

      { assert (wf_term (mk_squash (mk_apply2 R (mk_var n) (mk_var s)))) as wfs.
        { apply wf_squash.
          apply wf_apply2; auto. }
        assert (cover_vars (mk_squash (mk_apply2 R (mk_var n) (mk_var s)))
                           (snoc (snoc s1 (n, mkc_nat k)) (s, seq1))) as covs.
        { apply cover_vars_squash.
          apply cover_vars_apply2; dands; eauto 3 with slow.
          { repeat (apply cover_vars_snoc_weak; auto). }
          { apply cover_vars_snoc_weak.
            apply cover_vars_var_iff.
            rw @dom_csub_snoc; simpl; rw in_snoc; tcsp. }
          { apply cover_vars_var_iff.
            rw @dom_csub_snoc; simpl; rw in_snoc; tcsp. }
        }
        sim_snoc2; dands; auto.

        { assert (cover_vars (mk_natk2nat (mk_var n)) (snoc s1 (n, mkc_nat k))) as covn.
          { apply cover_vars_mk_natk2nat.
            apply cover_vars_var_iff.
            rw @dom_csub_snoc; simpl; rw in_snoc; tcsp. }
          sim_snoc2; dands; auto.

          { sim_snoc2; eauto 3 with slow.
            dands; auto.
            rw @lsubstc_mk_tnat.
            apply nat_in_nat. }

          { eapply alphaeqc_preserving_equality;
              [|apply alphaeqc_sym; apply lsubstc_mk_natk2nat_sp2; auto].
            auto. }
        }

        { lsubst_tac.
          apply member_mkc_squash; auto. }
      }

      { lsubst_tac; auto. }
    }

    exrepnd.
    lsubst_tac.
    apply inhabited_type_if_equality in hf1.
    unfold meta_fun_on_seq.
    dands; auto.

  - (* induction case *)
    intros k seq1 iss ind C seq2 eqs fse.
    clear iss.
    unfold fun_sim_eq in fse; exrepnd; subst.

    vr_seq_true in hyp_ind.

    pose proof (hyp_ind
                  (snoc (snoc (snoc s1 (n,mkc_nat k)) (s,seq1)) (x,mkc_axiom))
                  (snoc (snoc (snoc s0 (n,mkc_nat k)) (s,seq2)) (x,mkc_axiom)))
      as hf; clear hyp_ind.
    repeat (autodimp hf hyp).

    { apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; inj.
        apply similarity_snoc in sim'3; simpl in sim'3.
        exrepnd; subst; ginv; inj.
        lsubst_tac.
        allrw @lsubstc_mkc_tnat.
        apply equality_int_nat_implies_cequivc in sim'2.
        eapply alphaeqc_preserving_equality in sim'1;
          [|apply lsubstc_mk_natk2nat_sp2; auto].

        apply tequality_isect; dands.
        { apply tnat_type. }
        introv en.
        repeat substc_lsubstc_vars3.
        lsubst_tac.

        apply equality_in_tnat in en.
        unfold equality_of_nat in en; exrepnd; spcast.

        apply tequality_mkc_ufun; dands.

        {
          apply tequality_mkc_squash.
          eapply tequality_respects_cequivc_right;
            [apply implies_cequivc_apply2;
             [apply cequivc_refl
             |exact sim'2
             |apply cequivc_refl]
            |].

          pose proof (Rfunc k t1 t2 s1a s2a0 cR1 c44) as hr.
          repeat (autodimp hr hyp).
        }

        introv inh.
        rw @inhabited_squash in inh.

        apply tequality_mkc_squash.

        eapply tequality_respects_cequivc_left;
          [apply cequivc_sym;
            apply implies_cequivc_apply2;
            [apply cequivc_refl
            |apply cequivc_lsubstc_mk_plus1_sp1;auto
            |apply cequivc_lsubstc_mk_update_seq_sp1;auto;
             exact en1]
          |].

        assert (!LIn n (dom_csub s2a0)) as nin2.
        { apply similarity_dom in sim'4; repnd.
          rw sim'4; auto. }

        assert (!LIn s (dom_csub s2a0)) as nis2.
        { apply similarity_dom in sim'4; repnd.
          rw sim'4; auto. }

        eapply tequality_respects_cequivc_right;
          [apply cequivc_sym;
            apply implies_cequivc_apply2;
            [apply cequivc_refl
            |apply cequivc_lsubstc_mk_plus1_sp2; auto;
             apply cequivc_sym;exact sim'2
            |apply cequivc_lsubstc_mk_update_seq_sp2;auto;
             [exact en0
             |apply cequivc_nat_implies_computes_to_valc;
               apply cequivc_sym;exact sim'2]
            ]
          |].

        pose proof (ind k0) as h; clear ind.
        unfold meta2_fun_on_upd_seq in h.
        unfold meta2_fun_on_seq in h; repnd.

        autodimp h hyp.

        {
          introv eqk funsim.
          unfold fun_sim_eq in funsim; exrepnd; subst.
          dands; auto.
        }

        pose proof (h (lsubstc X w0 s2a0 c50) (update_seq t2 k k0 v)) as q; clear h.
        repeat (autodimp q hyp).
        { apply eq_kseq_update; auto. }
        { exists s2a0 c50; dands; auto. }
        repnd; auto.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      { introv equ' sim'.
        apply similarity_snoc in sim'; simpl in sim'.
        exrepnd; subst; ginv; inj.
        assert (!LIn n (dom_csub s2a)) as nns2a.
        { apply similarity_dom in sim'3; repnd.
          rw sim'3; auto. }
        eapply tequality_respects_alphaeqc_left;
          [apply alphaeqc_sym;
            apply lsubstc_mk_natk2nat_sp2; auto
          |].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym;
            apply lsubstc_mk_natk2nat_sp2; auto
          |].
        rw @lsubstc_mkc_tnat in sim'1.
        apply equality_int_nat_implies_cequivc in sim'1.
        eapply tequality_respects_cequivc_right;
          [apply implies_cequivc_natk2nat; exact sim'1|].
        eauto 3 with slow.
      }

      apply hyps_functionality_snoc2; simpl; auto.

      introv equ' sim'.
      allrw @lsubstc_mkc_tnat.
      apply tnat_type.
    }

    { assert (wf_term
                (mk_isect
                   mk_tnat m
                   (mk_ufun
                      (mk_squash (mk_apply2 R (mk_var n) (mk_var s)))
                      (mk_squash
                         (mk_apply2
                            X
                            (mk_plus1 (mk_var n))
                            (mk_update_seq (mk_var s) (mk_var n) (mk_var m) v)))))) as wa.
      { apply wf_isect; auto.
        apply wf_ufun; dands; auto;
          apply wf_squash; apply wf_apply2; auto. }

      assert (cover_vars
                (mk_isect
                   mk_tnat m
                   (mk_ufun
                      (mk_squash (mk_apply2 R (mk_var n) (mk_var s)))
                      (mk_squash
                         (mk_apply2
                            X (mk_plus1 (mk_var n))
                            (mk_update_seq (mk_var s) (mk_var n) (mk_var m) v)))))
                (snoc (snoc s1 (n, mkc_nat k)) (s, seq1))) as ca.
      { apply cover_vars_isect; dands; eauto 3 with slow.
        apply cover_vars_upto_ufun; dands; auto;
          apply cover_vars_upto_squash;
          apply cover_vars_upto_apply2; dands; eauto 3 with slow.
        { apply cover_vars_upto_csub_filter_snoc_weak.
          apply cover_vars_upto_csub_filter_snoc_weak.
          apply cover_vars_upto_csub_filter_disjoint; eauto 2 with slow.
          apply disjoint_singleton_r; auto. }
        { apply cover_vars_upto_var; simpl.
          rw @dom_csub_csub_filter.
          repeat (rw @dom_csub_snoc); simpl.
          rw in_remove_nvars; simpl.
          repeat (rw in_snoc).
          right; dands; tcsp. }
        { apply cover_vars_upto_var; simpl.
          rw @dom_csub_csub_filter.
          repeat (rw @dom_csub_snoc); simpl.
          rw in_remove_nvars; simpl.
          repeat (rw in_snoc).
          right; dands; tcsp. }
        { apply cover_vars_upto_csub_filter_snoc_weak.
          apply cover_vars_upto_csub_filter_snoc_weak.
          apply cover_vars_upto_csub_filter_disjoint; eauto 2 with slow.
          apply disjoint_singleton_r; auto. }
        { unfold mk_plus1.
          apply cover_vars_upto_add; dands; eauto 3 with slow.
          apply cover_vars_upto_var; simpl.
          rw @dom_csub_csub_filter.
          repeat (rw @dom_csub_snoc); simpl.
          rw in_remove_nvars; simpl.
          repeat (rw in_snoc).
          right; dands; tcsp. }
        { unfold mk_update_seq.
          apply cover_vars_upto_lam.
          rw @csub_filter_swap.
          rw <- @csub_filter_app_r; simpl.
          repeat (rw @csub_filter_snoc).
          allrw memvar_cons; simpl.
          boolvar;tcsp;GC;[].
          apply cover_vars_upto_int_eq; dands.
          { apply cover_vars_upto_var; simpl.
            repeat (rw @dom_csub_snoc).
            repeat (rw in_snoc;simpl).
            sp. }
          { apply cover_vars_upto_var; simpl.
            repeat (rw @dom_csub_snoc).
            repeat (rw in_snoc;simpl).
            sp. }
          { apply cover_vars_upto_var; simpl.
            repeat (rw @dom_csub_snoc).
            repeat (rw in_snoc;simpl).
            sp. }
          { apply cover_vars_upto_apply; dands.
            { apply cover_vars_upto_var; simpl.
              repeat (rw @dom_csub_snoc).
              repeat (rw in_snoc;simpl).
              sp. }
            { apply cover_vars_upto_var; simpl.
              repeat (rw @dom_csub_snoc).
              repeat (rw in_snoc;simpl).
              sp. }
          }
        }
      }

      sim_snoc.
      dands; auto.

      { assert (@wf_term o (mk_natk2nat (mk_var n))) as wfk.
        { apply wf_term_mk_natk2nat; auto. }
        assert (cover_vars (mk_natk2nat (mk_var n)) (snoc s1 (n,mkc_nat k))) as cvk.
        { apply cover_vars_mk_natk2nat.
          apply cover_vars_var_iff.
          repeat (rw @dom_csub_snoc); simpl.
          repeat (rw in_snoc); sp. }
        sim_snoc.
        dands; auto.

        { assert (@wf_term o mk_tnat) as wft.
          { eauto 3 with slow. }
          assert (cover_vars mk_tnat s1) as cvt.
          { apply cover_vars_mk_tnat. }
          sim_snoc.
          dands; auto.
          allrw @lsubstc_mkc_tnat.
          eauto 3 with slow.
        }

        eapply alphaeqc_preserving_equality;
          [|apply alphaeqc_sym; apply lsubstc_mk_natk2nat_sp2; auto].
        auto.
      }

      { lsubst_tac.
        apply member_in_isect.
        rewrite lsubstc_mk_tnat.
        dands; eauto 2 with slow.
        introv en.
        repeat substc_lsubstc_vars3.
        lsubst_tac.

        apply equality_in_tnat in en.
        unfold equality_of_nat in en; exrepnd; spcast.

        dands.

        {
          apply equality_in_ufun.
          dands.

          {
            apply tequality_mkc_squash.
            apply Rfunc; auto.
            { eapply similarity_refl; eauto. }
            { apply is_kseq_if_eq_kseq in eqs; tcsp. }
          }

          {
            introv inh.
            apply tequality_mkc_squash.
            rw @inhabited_squash in inh.

            eapply tequality_respects_cequivc_left;
              [apply cequivc_sym;
               apply implies_cequivc_apply2;
               [apply cequivc_refl
               |apply cequivc_lsubstc_mk_plus1_sp1;auto
               |apply cequivc_lsubstc_mk_update_seq_sp1;auto;
                exact en1]
              |].

            eapply tequality_respects_cequivc_right;
              [apply cequivc_sym;
               apply implies_cequivc_apply2;
               [apply cequivc_refl
               |apply cequivc_lsubstc_mk_plus1_sp2; auto;
                apply cequivc_sym;exact sim'2
               |apply cequivc_lsubstc_mk_update_seq_sp1;auto;
                exact en1]
              |].

            pose proof (ind k0) as h; clear ind.
            autodimp h hyp.

            {
              introv eqk funsim.
              unfold fun_sim_eq in funsim; exrepnd; subst.
              dands; auto.
            }

            unfold meta2_fun_on_upd_seq in h.
            unfold meta2_fun_on_seq in h; repnd.

            pose proof (h (lsubstc X w0 s1 c0) (update_seq seq1 k k0 v)) as q; clear h.
            repeat (autodimp q hyp).
            { apply eq_kseq_update; auto.
              eapply eq_kseq_left; eauto. }
            { exists s1 c0; dands; auto.
              eapply similarity_refl; eauto. }
            repnd; auto.
          }

          {
            introv inh.
            rw @inhabited_squash in inh.
            apply member_mkc_squash.

            eapply inhabited_type_cequivc;
              [apply cequivc_sym;
               apply implies_cequivc_apply2;
               [apply cequivc_refl
               |apply cequivc_lsubstc_mk_plus1_sp1;auto
               |apply cequivc_lsubstc_mk_update_seq_sp1;auto;
                exact en1]
              |].

            pose proof (ind k0) as h; clear ind.

            autodimp h hyp.

            {
              introv eqk funsim.
              unfold fun_sim_eq in funsim; exrepnd; subst.
              dands; auto.
            }

            unfold meta2_fun_on_upd_seq in h.
            unfold meta2_fun_on_seq in h; repnd.

            pose proof (h (lsubstc X w0 s1 c0) (update_seq seq1 k k0 v)) as q; clear h.
            repeat (autodimp q hyp).
            { apply eq_kseq_update; auto.
              eapply eq_kseq_left; eauto. }
            { exists s1 c0; dands; auto.
              eapply similarity_refl; eauto. }
            repnd; auto.
          }
        }

        {
          apply tequality_mkc_ufun.
          dands.

          {
            apply tequality_mkc_squash.
            apply Rfunc; auto.
            { eapply similarity_refl; eauto. }
            { apply is_kseq_if_eq_kseq in eqs; tcsp. }
          }

          introv inh.
          rw @inhabited_squash in inh.
          apply tequality_mkc_squash.

          eapply tequality_respects_cequivc_left;
            [apply cequivc_sym;
             apply implies_cequivc_apply2;
             [apply cequivc_refl
             |apply cequivc_lsubstc_mk_plus1_sp1;auto
             |apply cequivc_lsubstc_mk_update_seq_sp1;auto;
              exact en1]
            |].

          eapply tequality_respects_cequivc_right;
            [apply cequivc_sym;
             apply implies_cequivc_apply2;
             [apply cequivc_refl
             |apply cequivc_lsubstc_mk_plus1_sp2; auto;
              apply cequivc_sym;exact sim'2
             |apply cequivc_lsubstc_mk_update_seq_sp1;auto;
              exact en0]
            |].

          pose proof (ind k0) as h; clear ind.
          autodimp h hyp.

          {
            introv eqk funsim.
            unfold fun_sim_eq in funsim; exrepnd; subst.
            dands; auto.
          }

          unfold meta2_fun_on_upd_seq in h.
          unfold meta2_fun_on_seq in h; repnd.

          pose proof (h (lsubstc X w0 s1 c0) (update_seq seq1 k k0 v)) as q; clear h.
          repeat (autodimp q hyp).
          { apply eq_kseq_update; auto.
            eapply eq_kseq_left; eauto. }
          { exists s1 c0; dands; auto.
            eapply similarity_refl; eauto. }
          repnd; auto.
        }
      }
    }

    exrepnd.
    lsubst_tac.
    apply inhabited_type_if_equality in hf1.
    dands; auto.

Qed.


Require Export Helix.DSigmaHCOL.DSigmaHCOLITree.
Require Import Helix.LLVMGen.Correctness_Prelude.
Require Import Paco.paco.
Import MInt64asNT.

Section Eval_Denote_Equiv.

  Hint Rewrite interp_Mem_bind : itree.
  Hint Rewrite interp_Mem_ret : itree.
  Hint Rewrite @interp_Mem_MemLU : itree.

  Ltac go := unfold denotePExpr, evalIUnCType, denoteIUnCType; autorewrite with itree.

  Lemma Denote_Eval_Equiv_MExpr: forall mem σ e bk size,
      evalMExpr mem σ e ≡ inr (bk,size) ->
      eutt Logic.eq
           (interp_Mem (denoteMExpr σ e) mem)
           (Ret (mem, (bk,size))).
  Proof.
    intros mem σ [] * EVAL; cbn* in *; simp; go; try reflexivity.
    rewrite Heqs; cbn*; go.
    reflexivity.
    cbn*; match_rewrite; reflexivity.
  Qed.

  Lemma Denote_Eval_Equiv_NExpr: forall mem σ e v,
        evalNExpr σ e ≡ inr v ->
        eutt Logic.eq
             (interp_Mem (denoteNExpr σ e) mem)
             (Ret (mem, v)).
  Proof.
    induction e; cbn; intros * HEval; cbn* in *; simp; go;
      try (reflexivity ||
           (rewrite IHe1; [| reflexivity]; go; rewrite IHe2; [| reflexivity]; go; try (match_rewrite; go); reflexivity)).
  Qed.

    Lemma Denote_Eval_Equiv_AExpr: forall mem σ e v,
        evalAExpr mem σ e ≡ inr v ->
        eutt Logic.eq
             (interp_Mem (denoteAExpr σ e) mem)
             (Ret (mem, v)).
    Proof.
      induction e; cbn; intros * HEval; cbn* in *; simp; go;
        try (reflexivity ||
             (rewrite IHe1; [| reflexivity]; go; rewrite IHe2; [| reflexivity]; go; reflexivity) ||
             (rewrite IHe; [| reflexivity]; go; reflexivity)).
      rewrite Denote_Eval_Equiv_NExpr; eauto; go;
             rewrite Denote_Eval_Equiv_MExpr; eauto; go;
             repeat match_rewrite; go; reflexivity.
    Qed.

    Lemma Denote_Eval_Equiv_IMap: forall mem n f σ m1 m2 id,
        evalDSHIMap mem n f σ m1 m2 ≡ inr id ->
        eutt Logic.eq
             (interp_Mem (denoteDSHIMap n f σ m1 m2) mem)
             (Ret (mem, id)).
    Proof.
      induction n; intros; cbn* in *; simp; go; try reflexivity.
      rewrite Denote_Eval_Equiv_AExpr; eauto; go.
      rewrite IHn; eauto; reflexivity.
    Qed.

    Lemma Denote_Eval_Equiv_BinCType: forall mem σ f i a b v,
        evalIBinCType mem σ f i a b ≡ inr v ->
        eutt Logic.eq
             (interp_Mem (denoteIBinCType σ f i a b) mem)
             (Ret (mem, v)).
    Proof.
      unfold evalIBinCType, denoteIBinCType; intros.
      eapply Denote_Eval_Equiv_AExpr; eauto.
    Qed.

    Lemma Denote_Eval_Equiv_BinOp: forall mem n off σ f x y blk,
        evalDSHBinOp mem n off f σ x y ≡ inr blk ->
        eutt Logic.eq
             (interp_Mem (denoteDSHBinOp n off f σ x y) mem)
             (Ret (mem, blk)).
    Proof.
      induction n as [| n IH]; intros; cbn* in *; simp; go; try reflexivity.
      - rewrite Denote_Eval_Equiv_BinCType; eauto; go.
        rewrite IH; eauto; go; reflexivity.
    Qed.

    Import MonadNotation.
    Local Open Scope monad_scope.

    Definition denote_Loop_for_i_to_N σ body (i N: nat) :=
      iter (fun (p: nat) =>
              if EqNat.beq_nat p N
              then ret (inr tt)
              else
                vp <- lift_Serr (from_nat p) ;;
                denoteDSHOperator ((DSHnatVal vp , false):: σ) body;;
                Ret (inl (S p))
           ) i.

    Lemma denote_Loop_for_0_to_N:
      forall σ body N, denote_Loop_for_i_to_N σ body 0 N ≈ denoteDSHOperator σ (DSHLoop N body).
    Proof.
      unfold denote_Loop_for_i_to_N; reflexivity.
    Qed.

    (* loop over [i .. N)
       Some boundary cases:
       - i<N => either [Some _] or [None] if runs out of fuel
       - i>N => same as [eval_Loop_for_0_to_N]
       - N=0 =>
         - fuel=0 => [None]
         - fuel>0 => [Some (ret mem)] no-op
       - i=N =>
         - fuel=0 => [None]
         - fuel>0 => [Some (ret mem)] no-op

      NOTE: Struct [{struct N}] works instead of [{struct fuel}] here as well.
     *)
    Fixpoint eval_Loop_for_i_to_N σ body (i N: nat) mem fuel {struct fuel} :=
      match fuel with
      | O => None
      | S fuel =>
        match N with
        | O => Some (ret mem)
        | S N =>
          if EqNat.beq_nat i (S N) then
            Some (ret mem)
          else
            match eval_Loop_for_i_to_N σ body i N mem fuel with
            | Some (inr mem) =>
              match from_nat N with
              | inl msg => Some (inl msg)
              | inr vN =>
                evalDSHOperator ((DSHnatVal vN , false) :: σ) body mem fuel
              end
            | Some (inl msg) => Some (inl msg)
            | None => None
            end
        end
      end.

    (* TODO : MOVE THIS TO ITREE *)
    Instance eutt_interp_state_eq {E F: Type -> Type} {S : Type} {R}
             (h : E ~> Monads.stateT S (itree F)) :
      Proper (eutt Logic.eq ==> Logic.eq ==> eutt Logic.eq) (@interp_state E (itree F) S _ _ _ h R).
    Proof.
      repeat intro. subst. revert_until R.
      einit. ecofix CIH. intros.

      rewrite !unfold_interp_state. punfold H0. red in H0.
      induction H0; intros; subst; simpl; pclearbot.
      - eret.
      - etau.
      - ebind. econstructor; [reflexivity|].
        intros; subst.
        etau. ebase.
      - rewrite tau_euttge, unfold_interp_state; eauto.
      - rewrite tau_euttge, unfold_interp_state; eauto.
    Qed.

    Lemma eval_Loop_for_N_to_N: forall fuel σ op N mem,
        eval_Loop_for_i_to_N σ op N N mem (S fuel) ≡ Some (ret mem).
    Proof.
      intros fuel σ op [| N] mem; [reflexivity |].
      simpl; rewrite Nat.eqb_refl; reflexivity.
    Qed.

    Lemma eval_Loop_for_i_to_N_invert: forall σ i ii N op fuel mem_i mem_f,
        i < N ->
        from_nat i ≡ inr ii ->
        eval_Loop_for_i_to_N σ op i N mem_i fuel ≡ Some (inr mem_f) ->
        exists mem_aux,
          evalDSHOperator ((DSHnatVal ii , false) :: σ) op mem_i fuel ≡ Some (inr mem_aux) /\
          eval_Loop_for_i_to_N σ op (S i) N mem_aux fuel ≡ Some (inr mem_f).
    Proof.
      (* This proof is surprisingly painful to go through *)
      intros.
      (* Induction on the number of steps remaining *)
      remember (N - i) as k.
      revert σ fuel i ii N Heqk mem_i mem_f H0 H1 H.
      induction k as [| k IH];
        intros σ fuel i ii N EQ mem_i mem_f Hn Heval ineq;[lia|].

      (* N > 0 for us to be able to take a step *)
      destruct N as [| N]; [lia |].
      (* We got some fuel since the computation succeeded *)
      destruct fuel as [| fuel]; [inv Heval |].
      (* We can now reduce *)
      simpl in Heval.

      (* We know there's still a step to be taken *)
      destruct (i =? S N)%nat eqn:EQ'; [apply beq_nat_true in EQ'; lia | apply beq_nat_false in EQ'].
      (* And that the recursive call succeeded since the computation did *)
      destruct (eval_Loop_for_i_to_N σ op i N mem_i fuel) eqn: HEval'; [| inv Heval].
      destruct s; inv Heval.

      (* Now there are two cases:
         either a single step was remaining and we should be able to conclude directly;
         or more were remaining, and we should be able to conclude by induction
       *)

      destruct (i =? N)%nat eqn: EQ''; [apply beq_nat_true in EQ''; subst; clear IH |].
      - clear EQ' EQ ineq.
        rewrite Hn in H0.
        destruct fuel as [| fuel]; [inv HEval' |].
        rewrite eval_Loop_for_N_to_N in HEval'.
        setoid_rewrite eval_Loop_for_N_to_N.
        inv HEval'.
        exists mem_f.
        split; [apply evalDSHOperator_fuel_monotone; auto | auto ].
        rewrite Hn.
        auto.
      - destruct (from_nat N) eqn:NN.
        +
          eapply IH in HEval';[|lia|eauto|apply beq_nat_false in EQ''; lia].
          destruct HEval' as (mem_aux & STEP & TAIL).
          exists mem_aux; split; [apply evalDSHOperator_fuel_monotone; auto |].
          cbn; rewrite EQ'', TAIL.
          rewrite NN.
          reflexivity.
        +
          eapply IH in HEval';[|lia|eauto|apply beq_nat_false in EQ''; lia].
          destruct HEval' as (mem_aux & STEP & TAIL).
          exists mem_aux; split; [apply evalDSHOperator_fuel_monotone; auto |].
          cbn; rewrite EQ'', TAIL.
          rewrite NN.
          reflexivity.
    Qed.

    Lemma eval_Loop_for_i_to_N_i_gt_N σ op i N fuel mem:
      i > N ->
      eval_Loop_for_i_to_N σ op i N mem fuel ≡ eval_Loop_for_i_to_N σ op 0 N mem fuel.
    Proof.
      revert fuel.
      induction N; intros.
      +
        destruct fuel;reflexivity.
      +
        destruct fuel; [ reflexivity|].
        cbn.
        break_if; [apply beq_nat_true in Heqb; lia| ].
        apply beq_nat_false in Heqb.
        rewrite IHN.
        reflexivity.
        lia.
    Qed.

    Lemma eval_Loop_for_0_to_N:
      forall σ body N mem mem' fuel,
        evalDSHOperator σ (DSHLoop N body) mem fuel ≡ Some (inr mem') ->
        eval_Loop_for_i_to_N σ body 0 N mem fuel ≡ Some (inr mem').
    Proof.
      induction N as [| N IH]; intros.
      - destruct fuel; auto.
      - destruct fuel as [| fuel ]; [auto |].
        cbn in *.
        repeat break_match_hyp; try some_none; try some_inv.
        apply IH in Heqo.
        repeat break_match.
        + some_inv.
        + some_inv.
          auto.
        + some_none.
    Qed.

    Lemma eval_Loop_for_i_to_N_fuel_monotone:
      forall res σ op i N fuel mem,
        eval_Loop_for_i_to_N σ op i N mem fuel ≡ Some res ->
        eval_Loop_for_i_to_N σ op i N mem (S fuel) ≡ Some res.
    Proof.
      intros res σ op i N fuel mem H.
      revert H.
      revert res σ i fuel.
      induction N; intros.
      -
        destruct fuel; cbn in *; [some_none| apply H].
      -
        cbn.
        destruct fuel; [cbn in H; some_none|].
        break_if.
        +
          apply beq_nat_true in Heqb.
          subst.
          cbn in H.
          rewrite Nat.eqb_refl in H.
          apply H.
        +
          repeat break_match_goal; subst; cbn in H; rewrite Heqb in H.
          *
            rewrite <- Heqo.
            repeat break_match_hyp; subst.
            --
              rewrite <- H.
              apply IHN.
              apply Heqo0.
            --
              apply IHN in Heqo0.
              rewrite Heqo0 in Heqo.
              inv Heqo.
            --
              apply IHN in Heqo0.
              rewrite Heqo0 in Heqo.
              inv Heqo.
            --
              some_none.
          *
            repeat break_match_hyp; subst.
            --
              apply IHN in Heqo0.
              rewrite Heqo0 in Heqo.
              inv Heqo.
            --
              apply IHN in Heqo0.
              rewrite Heqo0 in Heqo.
              inv Heqo.
              inv Heqs1.
              apply H.
            --
              inv Heqs1.
            --
              some_none.
          *
            repeat break_match_hyp; subst.
            --
              apply IHN in Heqo0.
              rewrite Heqo0 in Heqo.
              inv Heqo.
            --
              inv Heqs1.
            --
              apply IHN in Heqo0.
              rewrite Heqo0 in Heqo.
              inv Heqo.
              inv Heqs1.
              apply evalDSHOperator_fuel_monotone.
              apply H.
            --
              some_none.
          *
            exfalso.
            break_match_hyp.
            --
              apply IHN in Heqo0.
              some_none.
            --
              some_none.
    Qed.

    Lemma eval_Loop_for_i_to_N_fuel_monotone_gt:
      forall res σ op i N fuel fuel' mem,
        fuel'>fuel ->
        eval_Loop_for_i_to_N σ op i N mem fuel ≡ Some res ->
        eval_Loop_for_i_to_N σ op i N mem fuel' ≡ Some res.
    Proof.
      intros H.
      intros σ op i N fuel fuel' mem H0 H1.
      remember (fuel'-fuel) as d.
      assert(F: fuel' ≡ fuel + d) by lia.
      subst fuel'.
      clear H0 Heqd.
      induction d.
      -
        replace (fuel + 0) with fuel by lia.
        auto.
      -
        replace (fuel + S d) with (S (fuel + d)) by lia.
        apply eval_Loop_for_i_to_N_fuel_monotone.
        auto.
    Qed.

    (* Extend [from_nat_lt] to [le] *)
    Lemma from_nat_le:
      forall x xi y,
        from_nat x ≡ inr xi ->
        y<=x ->
        exists yi, from_nat y ≡ inr yi.
    Proof.
      intros.
      destruct (Nat.eq_dec x y).
      -
        subst.
        eexists.
        eauto.
      -
        eapply from_nat_lt; eauto.
        unfold lt, peano_naturals.nat_lt.
        lia.
    Qed.

    Lemma Loop_is_Iter_aux:
      ∀ (op : DSHOperator)
        (IHop: ∀ (σ : evalContext) (mem' : memory) (fuel : nat) (mem : memory),
            evalDSHOperator σ op mem (S fuel) ≡ Some (inr mem')
            → interp_Mem (denoteDSHOperator σ op) mem ≈ Ret (mem', ()))

        (i N: nat)
        (σ : evalContext) (mem : memory) (fuel : nat) (mem' : memory) {nn},
        from_nat N ≡ inr nn ->
        i <= (S N) ->
        eval_Loop_for_i_to_N σ op i (S N) mem (S fuel) ≡ Some (inr mem')
        → interp_state (case_ Mem_handler pure_state) (denote_Loop_for_i_to_N σ op i (S N)) mem ≈ Ret (mem', ()).
    Proof.
      intros op IHop i N σ mem fuel mem' nn NN ineq HEval.
      remember ((S N) - i) as k.
      revert Heqk σ mem mem' HEval.
      revert i ineq NN.
      induction k as [| k IH].
      - intros i ineq NN EQ.
        assert ((S N) ≡ i) by lia; clear EQ ineq; subst.
        intros.
        cbn in HEval.
        rewrite Nat.eqb_refl in HEval.
        inv HEval.
        unfold denote_Loop_for_i_to_N.
        iter_unfold_pointed.
        cbn; go.
        rewrite Nat.eqb_refl.
        go. cbn; go.
        reflexivity.
      - intros i ineq NN EQ σ mem mem' HEval.
        destruct (i =? S N)%nat eqn:EQ'.
          * unfold eval_Loop_for_i_to_N in HEval; rewrite EQ' in HEval.
            inv HEval.
            unfold denote_Loop_for_i_to_N.
            iter_unfold_pointed.
            cbn; go.
            rewrite EQ'.
            cbn; go.
            cbn; go.
            reflexivity.
          * unfold denote_Loop_for_i_to_N.
            iter_unfold_pointed.
            cbn; go.
            rewrite EQ'; cbn*; go.
            apply beq_nat_false in EQ'.
            assert(exists ii : t, from_nat i ≡ inr ii) as II.
            {
              assert(i<=N) by lia.
              eapply from_nat_le;
              eauto.
            }
            destruct II as [ii II].
            rewrite II.
            cbn.
            apply eval_Loop_for_i_to_N_invert with (ii:=ii) in HEval; [|lia| apply II].
            destruct HEval as (mem_aux & Eval_body & Eval_tail).
            apply evalDSHOperator_fuel_monotone in Eval_body.
            apply IHop in Eval_body.
            go.
            rewrite Eval_body; cbn; go.
            cbn; go.
            apply IH in Eval_tail;try lia;auto.
    Qed.

    Lemma Loop_is_Iter:
      ∀ (op : DSHOperator)
        (IHop: ∀ (σ : evalContext) (mem' : memory) (fuel : nat) (mem : memory),
            evalDSHOperator σ op mem (S fuel) ≡ Some (inr mem')
            → interp_Mem (denoteDSHOperator σ op) mem ≈ Ret (mem', ()))
        (N: nat) (σ : evalContext) (mem : memory) (fuel : nat) (mem' : memory),
        evalDSHOperator σ (DSHLoop N op) mem (S fuel) ≡ Some (inr mem') ->
        interp_state (case_ Mem_handler pure_state) (denoteDSHOperator σ (DSHLoop N op)) mem ≈ Ret (mem', ()).
    Proof.
      intros.
      destruct N.
      -
        cbn in H; inv H.
        cbn; go.
        iter_unfold_pointed.
        cbn; go.
        cbn; go.
        reflexivity.
      -
        edestruct @evalDSHLoop_SN_in_range; eauto.
        apply eval_Loop_for_0_to_N in H.
        cbn; go.
        eapply Loop_is_Iter_aux;eauto.
        lia.
    Qed.

    Lemma Denote_Eval_Equiv_DSHMap2:
      forall n (σ: evalContext) mem f m1 m2 m3 m4,
        evalDSHMap2 mem n f σ m1 m2 m3  ≡ inr m4 ->
        eutt Logic.eq
             (interp_Mem (denoteDSHMap2 n f σ m1 m2 m3) mem)
             (Ret (mem, m4)).
    Proof.
      induction n as [| n IH]; intros σ mem f m1 m2 m3 m4 HEval; cbn in HEval.
      - inv_sum; cbn; go; reflexivity.
      - cbn* in *; simp; go.
        unfold denoteBinCType; cbn.
        rewrite Denote_Eval_Equiv_AExpr; eauto; go.
        rewrite IH; eauto; go.
        reflexivity.
    Qed.

    Lemma Denote_Eval_Equiv_DSHPower:
      forall n (σ: evalContext) mem f x y xoff yoff m,
        evalDSHPower mem σ n f x y xoff yoff  ≡ inr m ->
        eutt Logic.eq
             (interp_Mem (denoteDSHPower σ n f x y xoff yoff) mem)
             (Ret (mem, m)).
    Proof.
      induction n as [| n IH]; intros σ mem f x y xoff yoff m HEval; cbn in HEval.
      - inv_sum; cbn; go; reflexivity.
      - cbn* in *; simp; go.
        unfold denoteBinCType; rewrite Denote_Eval_Equiv_AExpr; eauto; go.
        rewrite IH; eauto; reflexivity.
    Qed.

    Theorem Denote_Eval_Equiv:
      forall (σ: evalContext) (op: DSHOperator) (mem: memory) (fuel: nat) (mem': memory),
        evalDSHOperator σ op mem fuel ≡ Some (inr mem') ->
        eutt Logic.eq (interp_Mem (denoteDSHOperator σ op) mem) (Ret (mem', tt)).
    Proof.
      intros ? ? ? ? ? H; destruct fuel as [| fuel]; [inversion H |].
      revert σ mem' fuel mem H.
      induction op; intros σ mem fuel mem' HEval; cbn in HEval.
      - simp; cbn; go; reflexivity.
      - cbn* in *; simp; go.
        rewrite Heqs0; cbn; go.
        rewrite Heqs; cbn.
        go.
        3: cbn*; rewrite Heqo1; reflexivity.
        2: cbn*; rewrite Heqo0; reflexivity.
        rewrite Denote_Eval_Equiv_NExpr; eauto; go.
        rewrite Denote_Eval_Equiv_NExpr; eauto; go.
        repeat match_rewrite; go.
        rewrite interp_Mem_MemSet.
        reflexivity.
      - cbn* in *; simp; go.
        cbn*; repeat match_rewrite; go.
        rewrite Heqs2. repeat match_rewrite; go.
        unfold assert_NT_le, assert_true_to_err in Heqs3.
        unfold assert_nat_le. unfold assert_true_to_err.
        break_if.
        go.
        3: cbn*; match_rewrite; eauto.
        2: cbn*; match_rewrite; eauto.
        rewrite  Denote_Eval_Equiv_IMap; eauto; go.
        rewrite interp_Mem_MemSet; reflexivity.
        exfalso.
        apply leb_complete_conv in Heqb.
        unfold to_nat in Heqb. break_if. 2 : inv Heqs3.
        eapply leb_complete in Heqb0.
        unfold to_nat in Heqb0. revert Heqb.
        apply le_not_lt. clear -Heqs Heqb0.
        unfold from_nat in Heqs.
        apply from_Z_intval in Heqs.
        rewrite <- Heqs in Heqb0.
        lia.
      - cbn* in *; simp; go.
        cbn*; repeat match_rewrite; go.
        rewrite Heqs2.
        repeat match_rewrite; go.
        2,3: cbn*; match_rewrite; eauto.
        rewrite  Denote_Eval_Equiv_BinOp; eauto; go.
        go.
        rewrite interp_Mem_MemSet; reflexivity.
      - cbn* in *; simp; go.
        cbn*; repeat match_rewrite; go.
        2,3,4: cbn*; match_rewrite; eauto.
        rewrite Denote_Eval_Equiv_DSHMap2; eauto; go.
        rewrite interp_Mem_MemSet; reflexivity.
      - cbn* in *; simp; go.
        cbn*; repeat match_rewrite; go.
        rewrite Heqs1.
        repeat match_rewrite; go.
        rewrite Denote_Eval_Equiv_NExpr; eauto; go.
        rewrite Denote_Eval_Equiv_NExpr; eauto; go.
        rewrite Denote_Eval_Equiv_NExpr; eauto; go.

        rewrite Heqs7. rewrite interp_Mem_ret. rewrite bind_ret_l.
        rewrite interp_Mem_bind.
        rewrite Denote_Eval_Equiv_DSHPower; eauto; go.
        2,3: cbn*; match_rewrite; eauto.
        rewrite interp_Mem_MemSet; reflexivity.
      - eapply Loop_is_Iter; eauto.
      - cbn; simp; go.
        Transparent interp_Mem.
        unfold interp_Mem.
        rewrite interp_state_trigger; cbn.
        Opaque interp_Mem.
        go.
        rewrite interp_Mem_MemSet; go.
        destruct fuel as [| fuel]; [inv Heqo |].
        rewrite IHop; eauto; go.
        Transparent interp_Mem.
        unfold interp_Mem.
        rewrite interp_state_trigger; cbn.
        reflexivity.
        Opaque interp_Mem.
      - cbn* in *; simp.
        unfold denotePExpr; cbn*; match_rewrite; go.
        2:cbn*; match_rewrite; eauto.
        rewrite interp_Mem_MemSet; reflexivity.
      - cbn; simp; go.
        rewrite IHop1; eauto using evalDSHOperator_fuel_monotone.
        go; rewrite IHop2; eauto using evalDSHOperator_fuel_monotone.
        reflexivity.
    Qed.

  End Eval_Denote_Equiv.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
(*Require Import depoolContract.Lib.CommonCommon.*)
(* Require Import depoolContract.Lib.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.
Require Export Coq.micromega.Lia.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

Require Export depoolContract.Scenarios.Common.CommonDefinitions.
Require Export depoolContract.Scenarios.Common.UtilProofs.
Require Export depoolContract.Scenarios.Common._returnOrReinvestForParticipant_attachedValueMove.
Require Export depoolContract.Scenarios.Correctness.ParticipantCorrect.

Lemma attachedValue_NewParticipant_correct : forall p stake,
    participantCorrectLocally p ->
    0 <= stake ->
    participantCorrectLocally (attachedValue_NewParticipant p stake).
Proof.
intros. unfold participantCorrectLocally in *. unfold _participantCorrectPositive in *.
inversion_clear H. inversion_clear H2. unfold attachedValue_NewParticipant.
repeat split ; simpl ; try assumption.
unfold _curPause. unfold _returnOrReinvestForParticipant_attachedValueMove.DePoolFuncs.intMin.
simpl. case_eq ( DePoolLib_ι_Participant_ι_withdrawValue p <=? stake) ; intros ; setoid_rewrite H2.
lia. apply Z.leb_gt in H2. replace 0 with (stake - stake). apply Z.sub_le_mono_r.
apply Z.lt_le_incl. assumption. lia.
Qed.

Lemma attachedValue_attachedValue_ge0 : forall l p stake,
    participantCorrectLocally p ->
    0 <= stake ->
    0 < attachedValue l p stake.
Proof.
intros. unfold attachedValue. case_eq (stake - _curPause p stake <? m_minStake l) ; intros.
lia. unfold _curPause. unfold _returnOrReinvestForParticipant_attachedValueMove.DePoolFuncs.intMin.
Opaque "+". simpl. Transparent "+".
case_eq ( DePoolLib_ι_Participant_ι_withdrawValue p <=? stake) ; intros ; setoid_rewrite H2.
unfold participantCorrectLocally in H. unfold _participantCorrectPositive in H.
inversion_clear H. inversion_clear H4. rewrite Z.add_comm. apply Z.add_nonneg_pos. auto. lia.
rewrite Z.add_comm. apply Z.add_nonneg_pos. auto. lia.
Qed.

Lemma attachedValue_attachedValue_NewStake : forall l p stake,
    participantCorrectLocally p ->
    0 <= stake ->
    attachedValue_NewStake l p stake = 0 \/ m_minStake l <= attachedValue_NewStake l p stake.
Proof.
intros. unfold attachedValue_NewStake. unfold participantCorrectLocally in H.
unfold _participantCorrectPositive in H. inversion_clear H. inversion_clear H2.
case_eq(stake - _curPause p stake <? m_minStake l) ; intros.
left. reflexivity. right. apply Z.ltb_ge in H2. assumption.
Qed.

Lemma attachedValue_attachedValue_plus_NewStake : forall l p stake,
    participantCorrectLocally p ->
    0 <= stake ->
    attachedValue l p stake + attachedValue_NewStake l p stake = 1 + stake.
Proof.
intros. unfold attachedValue. unfold attachedValue_NewStake.
case_eq(stake - _curPause p stake <? m_minStake l) ; intros ; lia.
Qed.

Lemma attachedValue_attachedValue_lt_1_plus_s : forall l p stake,
    0 <= stake ->
    attachedValue l p stake <= 1 + stake.
Proof.
intros. unfold attachedValue.
case_eq(stake - _curPause p stake <? m_minStake l) ; intros. lia. apply Zplus_le_compat_l.
unfold _curPause. apply min_lte_r.
Qed.


Require Import init.

Require Import tensor_product_universal.
Require Import tensor_product_isomorphisms.
Require Import tensor_power_base.
Require Export tensor_algebra_traditional_base.
Require Import tensor_algebra_traditional_mult.
Require Import module_category.
Require Import algebra_category.
Require Import linear_grade.

Require Import set.

(** This file constructs the canonical injection of vectors into the tensor
algebra and the basic facts about it.
*)

(* begin hide *)
Section TensorAlgebraObj.

(* end hide *)
Context {F : CRingObj} (V : ModuleObj F).

(* begin hide *)
Let U := cring_U F.
Let UP := cring_plus F.
Let UZ := cring_zero F.
Let UN := cring_neg F.
Let UPA := cring_plus_assoc F.
Let UPC := cring_plus_comm F.
Let UPZ := cring_plus_lid F.
Let UPN := cring_plus_linv F.
Let UM := cring_mult F.
Let UO := cring_one F.
Let UMA := cring_mult_assoc F.
Let UMC := cring_mult_comm F.
Let UMO := cring_mult_lid F.
Let UMD := cring_ldist F.
Let VP := module_plus V.
Let VZ := module_zero V.
Let VN := module_neg V.
Let VPC := module_plus_comm V.
Let VPA := module_plus_assoc V.
Let VPZ := module_plus_lid V.
Let VPN := module_plus_linv V.
Let VSM := module_scalar V.
Let VSMC := module_scalar_comp V.
Let VSMO := module_scalar_id V.
Let VSML := module_scalar_ldist V.
Let VSMR := module_scalar_rdist V.
Let TP k := module_plus (tensor_power V k).
Let TZ k := module_zero (tensor_power V k).
Let TN k := module_neg (tensor_power V k).
Let TPC k := module_plus_comm (tensor_power V k).
Let TPA k := module_plus_assoc (tensor_power V k).
Let TPZ k := module_plus_lid (tensor_power V k).
Let TPN k := module_plus_linv (tensor_power V k).
Let TSM k := module_scalar (tensor_power V k).
Let TSMC k := module_scalar_comp (tensor_power V k).
Let TSMO k := module_scalar_id (tensor_power V k).
Let TSML k := module_scalar_ldist (tensor_power V k).
Let TSMR k := module_scalar_rdist (tensor_power V k).
Let TAP := tensor_algebra_plus V.
Let TAZ := tensor_algebra_zero V.
Let TAN := tensor_algebra_neg V.
Let TAPC := tensor_algebra_plus_comm V.
Let TAPA := tensor_algebra_plus_assoc V.
Let TAPZ := tensor_algebra_plus_lid V.
Let TAPN := tensor_algebra_plus_linv V.
Let TASM := tensor_algebra_scalar_mult V.
Let TASMC := tensor_algebra_scalar_comp V.
Let TASMO := tensor_algebra_scalar_id V.
Let TASML := tensor_algebra_scalar_ldist V.
Let TASMR := tensor_algebra_scalar_rdist V.
Let TAG := tensor_grade V.
Let TAM := tensor_mult_class V.
Let TAML := tensor_mult_ldist V.
Let TAMR := tensor_mult_rdist V.
Let TAMA := tensor_mult_assoc V.
Existing Instances UP UZ UN UPA UPC UPZ UPN UM UO UMA UMC UMO UMD VP VZ VN VPC
    VPA VPZ VPN VSM VSMC VSMO VSML VSMR TP TZ TN TPC TPA TPZ TPN TSM TSMC TSMO
    TSML TSMR TAP TAZ TAN TAPC TAPA TAPZ TAPN TASM TASMC TASMO TASML TASMR TAG
    TAM TAML TAMR TAMA.
(* end hide *)
Let k_tensor k := module_V (tensor_power V k).

Definition vector_to_tensor v := power_to_tensor V (k := 1)
    (tensor_mult V (cring_module F) v 1).

Theorem vector_to_tensor_plus : ∀ u v,
    vector_to_tensor (u + v) = vector_to_tensor u + vector_to_tensor v.
Proof.
    intros u v.
    unfold vector_to_tensor.
    rewrite (tensor_rdist V).
    rewrite (power_to_tensor_plus V).
    reflexivity.
Qed.

Theorem vector_to_tensor_scalar : ∀ α v,
    vector_to_tensor (α · v) = α · vector_to_tensor v.
Proof.
    intros α v.
    unfold vector_to_tensor.
    rewrite (tensor_lscalar V).
    rewrite (power_to_tensor_scalar V).
    reflexivity.
Qed.
(* begin hide *)

End TensorAlgebraObj.
(* end hide *)


Inductive op1 : Type :=
  | OP_ISZERO
  | OP_NOT
.

Inductive op2 : Type :=
  | OP_ADD
  | OP_MUL
  | OP_SUB
  | OP_DIV
  | OP_SDIV
  | OP_MOD
  | OP_SMOD
  | OP_EXP
  | OP_SIGNEXTEND
  | OP_LT
  | OP_GT
  | OP_SLT
  | OP_SGT
  | OP_EQ
  | OP_AND
  | OP_OR
  | OP_XOR
  | OP_BYTE
.

Inductive op3 : Type :=
  | OP_ADDMOD
  | OP_MULMOD
.

Inductive so_instruction : Type :=
  | I_OP1 : op1 -> so_instruction
  | I_OP2 : op2 -> so_instruction
  | I_OP3 : op3 -> so_instruction
  | I_POP
  | I_PUSH : nat -> so_instruction (* coerced from a list of 1-32 bytes, big endian; the rest is zero *)
  | I_DUP : nat -> so_instruction
  | I_SWAP : nat -> so_instruction
.

Inductive mem_instruction : Type :=
  | I_MLOAD
  | I_MSTORE
  | I_MSTORE8
.

Inductive storage_instruction : Type :=
  | I_SLOAD
  | I_SSTORE
.

Inductive env_instruction : Type :=
  | I_ADDRESS | I_BALANCE | I_ORIGIN
  | I_CALLER | I_CALLVALUE | I_CALLDATALOAD | I_CALLDATASIZE | I_CALLDATACOPY
  | I_CODESIZE | I_CODECOPY | I_GASPRICE | I_EXTCODESIZE | I_EXTCODECOPY
.

Inductive block_instruction : Type :=
  | I_BLOCKHASH | I_COINBASE | I_TIMESTAMP | I_NUMBER | I_DIFFICULTY | I_GASLIMIT
.

Inductive system_instruction : Type :=
  | I_CREATE | I_CALL | I_CALLCODE | I_RETURN | I_DELEGATECALL | I_SUICIDE
.

Inductive other_instruction : Type :=
  | I_SHA3
  | I_MSIZE | I_GAS | I_JUMPDEST (* NO-OP - mark as label *)
  | I_LOG : nat (* 0-4 *) -> other_instruction
.

Inductive instruction : Type :=
  | I_STOP
  | I_STACK : so_instruction -> instruction
  | I_MEMINS : mem_instruction -> instruction
  | I_STORINS : storage_instruction -> instruction

  | I_JUMP
  | I_JUMPI
  | I_PC

  | I_ENV : env_instruction -> instruction
  | I_BLOCK : block_instruction -> instruction
  | I_SYS : system_instruction -> instruction
  | I_OTHER : other_instruction -> instruction
  | I_INVALID : instruction
.

Definition delta_alpha (i: instruction) : nat*nat :=
  match i with
    | I_STOP => (0, 0)
    | I_STACK (I_OP1 _) => (1, 1)
    | I_STACK (I_OP2 _) => (2, 1)
    | I_STACK (I_OP3 _) => (3, 1)
    | I_STACK I_POP => (1, 0)
    | I_STACK (I_PUSH n) => (0, 1)
    | I_STACK (I_DUP n) => (n, 1 + n)
    | I_STACK (I_SWAP n) => (2 + n, 2 + n)
    | I_OTHER I_SHA3 => (2, 1)

    | I_ENV I_ADDRESS => (0, 1)
    | I_ENV I_BALANCE => (1, 1)
    | I_ENV I_ORIGIN => (0, 1)
    | I_ENV I_CALLER => (0, 1)
    | I_ENV I_CALLVALUE => (0, 1)
    | I_ENV I_CALLDATALOAD => (1, 1)
    | I_ENV I_CALLDATASIZE => (0, 1)
    | I_ENV I_CALLDATACOPY => (3, 0)
    | I_ENV I_CODESIZE => (0, 1)
    | I_ENV I_CODECOPY => (3, 0)
    | I_ENV I_GASPRICE => (0, 1)
    | I_ENV I_EXTCODESIZE => (1, 1)
    | I_ENV I_EXTCODECOPY => (4, 0)

    | I_BLOCK I_BLOCKHASH => (1, 1)
    | I_BLOCK I_COINBASE => (0, 1)
    | I_BLOCK I_TIMESTAMP => (0, 1)
    | I_BLOCK I_NUMBER => (0, 1)
    | I_BLOCK I_DIFFICULTY => (0, 1)
    | I_BLOCK I_GASLIMIT => (0, 1)

    | I_MEMINS I_MLOAD => (1, 1)
    | I_MEMINS I_MSTORE => (2, 0)
    | I_MEMINS I_MSTORE8 => (2, 0)
    | I_STORINS I_SLOAD => (1, 1)
    | I_STORINS I_SSTORE => (2, 0)

    | I_JUMP => (1, 0)
    | I_JUMPI => (2, 0)
    | I_PC => (0, 1)

    | I_OTHER I_MSIZE => (0, 1)
    | I_OTHER I_GAS => (0, 1)
    | I_OTHER I_JUMPDEST  => (0, 0) (* NO-OP - mark as label *)

    | I_OTHER (I_LOG n) => (n + 2, 0)

    | I_SYS I_CREATE => (3, 1)
    | I_SYS I_CALL => (7, 1)
    | I_SYS I_CALLCODE => (7, 1)
    | I_SYS I_RETURN => (2, 0)
    | I_SYS I_DELEGATECALL => (6, 1)
    | I_INVALID => (0, 0)
    | I_SYS I_SUICIDE => (1, 10)
  end.

Require Import List PeanoNat.
Import ListNotations.

Local Definition fill16 (l : list instruction) : list instruction:=
  l ++ repeat I_INVALID (16 - length l).

(* 0s: Stop and Arithmetic Operations *)
Definition opcode_0s := fill16 [
 I_STOP;

 I_STACK (I_OP2 OP_ADD);
 I_STACK (I_OP2 OP_MUL);
 I_STACK (I_OP2 OP_SUB);
 I_STACK (I_OP2 OP_DIV);
 I_STACK (I_OP2 OP_SDIV);
 I_STACK (I_OP2 OP_MOD);
 I_STACK (I_OP2 OP_SMOD);
 I_STACK (I_OP3 OP_ADDMOD);
 I_STACK (I_OP3 OP_MULMOD);
 I_STACK (I_OP2 OP_EXP);
 I_STACK (I_OP2 OP_SIGNEXTEND)
].

(* 10s: Comparison & Bitwise Logic Operations *)
Definition opcode_10s := fill16 [
 I_STACK (I_OP2 OP_LT);
 I_STACK (I_OP2 OP_GT);
 I_STACK (I_OP2 OP_SLT);
 I_STACK (I_OP2 OP_SGT);
 I_STACK (I_OP2 OP_EQ);
 I_STACK (I_OP1 OP_ISZERO);
 I_STACK (I_OP2 OP_AND);
 I_STACK (I_OP2 OP_OR);
 I_STACK (I_OP2 OP_XOR);
 I_STACK (I_OP1 OP_NOT);
 I_STACK (I_OP2 OP_BYTE)
].

(* 20s: SHA3 *)
Definition opcode_20s := fill16 [
  I_OTHER I_SHA3
].

(* 30s: Environmental Information *)
Definition opcode_30s := fill16 [
 I_ENV I_ADDRESS;
 I_ENV I_BALANCE;
 I_ENV I_ORIGIN;
 I_ENV I_CALLER;
 I_ENV I_CALLVALUE;
 I_ENV I_CALLDATALOAD;
 I_ENV I_CALLDATASIZE;
 I_ENV I_CALLDATACOPY;
 I_ENV I_CODESIZE;
 I_ENV I_CODECOPY;
 I_ENV I_GASPRICE;
 I_ENV I_EXTCODESIZE;
 I_ENV I_EXTCODECOPY
].

(* 50s: Stack, Memory, Storage and Flow Operations *)
Definition opcode_40s := fill16 [
 I_BLOCK I_BLOCKHASH;
 I_BLOCK I_COINBASE;
 I_BLOCK I_TIMESTAMP;
 I_BLOCK I_NUMBER;
 I_BLOCK I_DIFFICULTY;
 I_BLOCK I_GASLIMIT
].

(* 50s: Stack, Memory, Storage and Flow Operations *)
Definition opcode_50s := fill16 [
 I_STACK I_POP;
 I_MEMINS I_MLOAD;
 I_MEMINS I_MSTORE;
 I_MEMINS I_MSTORE8;
 I_STORINS I_SLOAD;
 I_STORINS I_SSTORE;
 I_JUMP;
 I_JUMPI;
 I_PC;
 I_OTHER I_MSIZE;
 I_OTHER I_GAS;
 I_OTHER I_JUMPDEST
].

(* f0s: System operations *)
Definition opcode_f0s := [
 I_SYS I_CREATE;
 I_SYS I_CALL;
 I_SYS I_CALLCODE;
 I_SYS I_RETURN;
 I_SYS I_DELEGATECALL
] ++ repeat I_INVALID 10 ++ [
 I_SYS I_SUICIDE
].

Definition opcode : list instruction := []
(* 0 *) ++ opcode_0s
(* 1 *) ++ opcode_10s
(* 2 *) ++ opcode_20s
(* 3 *) ++ opcode_30s
(* 4 *) ++ opcode_40s
(* 5 *) ++ opcode_50s
(* 6 *) ++ map (fun n => I_STACK (I_PUSH n)) (seq 1 16)
(* 7 *) ++ map (fun n => I_STACK (I_PUSH n)) (seq 17 16)
(* 8 *) ++ map (fun n => I_STACK (I_DUP n)) (seq 1 16)
(* 9 *) ++ map (fun n => I_STACK (I_SWAP n)) (seq 1 16)
(* a *) ++ fill16 (map (fun n => I_OTHER (I_LOG n)) (seq 0 5))
(* b *) ++ fill16 []
(* c *) ++ fill16 []
(* d *) ++ fill16 []
(* e *) ++ fill16 []
(* f *) ++ opcode_f0s
.

Definition delta (i: instruction) := fst (delta_alpha i).
Definition alpha (i: instruction) := snd (delta_alpha i).

Require Export Word.
Include Word.Word.

Definition eval_op1 (op : op1) (x : word) : word :=
  match op with
    | OP_ISZERO => if eq x zero then one else zero
    | OP_NOT => neg x
  end.

Definition eval_op2 (op : op2) (x y : word) : word :=
  match op with
    | OP_ADD => add x y
    | OP_MUL => mul x y
    | OP_SUB => sub x y
    | OP_DIV => divu x y
    | OP_SDIV => divs x y
    | OP_MOD => modu x y
    | OP_SMOD => mods x y
    | OP_EXP => exp x y
    | OP_SIGNEXTEND => sext x y
    | OP_LT => if lt x y then one else zero
    | OP_GT => if lt y x then one else zero
    | OP_SLT => negative (sub x y)
    | OP_SGT => negative (sub y x)
    | OP_EQ => if eq x y then one else zero
    | OP_AND => and x y
    | OP_OR => or x y
    | OP_XOR => xor x y
    | OP_BYTE => get_byte x y
  end.

Definition eval_op3 (op : op3) (x y m : word) : word :=
  match op with
    | OP_ADDMOD => addmod x y m
    | OP_MULMOD => mulmod x y m
  end.


Set Implicit Arguments.

Require Import QArith.
Require Import QvecArith PerceptronDef.

Extraction Language Haskell.

Extract Inductive Vector.t =>
  "([])" [ "[]" "(\a _ v -> a : v)" ]
              "(\fNil fCons v ->
                   case v of
                     [] -> fNil ()
                     (a : v') -> fCons a O v')".
Extract Inductive prod => "(,)" [ "(,)" ].
Extract Inductive list => "([])" [ "[]" "(:)" ].
Extract Inductive bool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ].
Extract Constant Bool.eqb => "(Prelude.==)".
Extract Constant negb => "(Prelude.not)".
Extract Constant Coq.Vectors.Vector.map =>
  "(\g _ l -> Prelude.map g l)".
Extract Constant Coq.Vectors.Vector.map2 =>
  "(\g _ l1 l2 -> Prelude.map (\(x,y) -> g x y) (Prelude.zip l1 l2))".
Extract Constant Coq.Vectors.Vector.fold_left =>
  "(\g a _ l -> Prelude.foldl g a l)".

Definition gas (T : Type) (f : nat -> T) : T := f O.

Extract Constant gas =>
  "(\f -> let infiniteGas = S infiniteGas in f infiniteGas)".

Definition fueled_perceptron
           (n _ : nat)
           (T : list (Qvec n * bool)) (w : Qvec (S n))
  : option (Qvec (S n)) :=
  gas (fun fuel => perceptron fuel T w).

Extraction "./Benchmarks/hs/Perceptron.hs" fueled_perceptron inner_perceptron_MCE.

Extract Inductive positive =>
"Prelude.Integer" [ "(\x -> (Prelude.+) ((Prelude.*) 2 x) 1)"
                    "(\x -> (Prelude.*) 2 x)" "1" ]
              "(\xI xO xH p ->
                   if (Prelude.==) p 1 then xH ()
                   else if Prelude.even p then xO (Prelude.quot p 2)
                        else xI (Prelude.quot p 2))".

Extract Inductive Z =>
  "Prelude.Integer" [ "0" "" "(\x -> (Prelude.*) x (-1))" ]
              "(\fO fPos fNeg z ->
                   if (Prelude.==) z 0 then fO ()
                   else if (Prelude.>) z 0 then fPos z
                        else fNeg ((Prelude.*) z (-1)))".

Extract Constant Z.add => "(Prelude.+)".
Extract Constant Z.mul => "(Prelude.*)".
Extract Constant Z.eqb => "(Prelude.==)".
Extract Constant Z.gtb => "(Prelude.>)".
Extract Constant Z.geb => "(Prelude.>=)".

Extract Inductive Q =>
  "Rational" [ "(\n d -> (Data.Ratio.%) n d)" ]
             "(\fNum fDen q -> Prelude.error ""induction on Q unsupported!"")".

Extract Constant Qplus => "(Prelude.+)".
Extract Constant Qmult => "(Prelude.*)".
Extract Constant Qred => "(\x -> x)".
Extract Constant Qeq_bool => "(Prelude.==)".
Extract Constant Qle_bool => "(Prelude.<=)".

Extraction "./Benchmarks/hsopt/Perceptron.hs" fueled_perceptron inner_perceptron_MCE.