Require Import Coq.Lists.List.
Import ListNotations.

Require Export Parser.Description.
Require Export Parser.Option.

Definition disj_rule { A }: Rule [A; A] A :=
  fun (premises: hlist [ option A; option A ]) =>
    let opt1: option A := h_head premises in
    let opt2: option A := h_head (h_tail premises) in
    or_else opt1 opt2.

Definition id_rule { A }: Rule [A] A :=
  fun (premises: hlist [ option A ]) =>
    h_head premises.

Definition some_rule { AS A } (a: A): Rule AS A :=
  fun _ => Some a.

Definition map_rule { A B } (f: A -> B): Rule [A] B :=
  fun (premises: hlist [ option A ]) =>
    let opt: option A := h_head premises in
    option_map f opt.

Definition combine_rule { A1 A2 A: Type } (f: A1 -> A2 -> A): Rule [A1; A2] A :=
  fun (premises: hlist [ option A1; option A2 ]) =>
    let opt1: option A1 := h_head premises in
    let opt2: option A2 := h_head (h_tail premises) in
    option_flat_map (fun v1 => option_map (fun v2 => f v1 v2) opt2) opt1.

Definition left_rule { A1 A2: Type }: Rule [A1; A2] A1 :=
  fun (premises: hlist [ option A1; option A2 ]) =>
    h_head premises.

Definition right_rule { A1 A2: Type }: Rule [A1; A2] A2 :=
  fun (premises: hlist [ option A1; option A2 ]) =>
    h_head (h_tail premises).

Ltac rules :=
  unfold disj_rule in * ||
  unfold id_rule in * ||
  unfold some_rule in * ||
  unfold map_rule in * ||
  unfold combine_rule in * ||
  unfold left_rule in * ||
  unfold right_rule in *.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Confluence, boundedness, length preserving transformations
  - Modules AddFreshLoop, AddFreshLoop': add rules aX <-> X'b where X' is fresh
  - Module DerivableRule: add derivable rule / removing redundant rule
  - Module DerivableRule': add rule that is derivable with a prefix
  - Module Reordering: change order, duplicate rules
*)

Require Import List Lia.
Import ListNotations.
Require Import Relation_Operators Operators_Properties.

Require Import Undecidability.StackMachines.SMN.
Require Undecidability.StackMachines.SSM.

From Undecidability.StackMachines.Util Require Import Nat_facts List_facts SMN_facts.

Require Import Undecidability.StackMachines.Util.SMN_transform.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Module Argument.
Section Reduction.
  Variable M : SMN.
  Variable confluent_M : confluent M.
  Variable basic_M : Forall basic M.

  Definition encode_Instruction (op: Instruction) : SSM.instruction :=
    match op with
    | (([], [a], x), ([b], [], y)) => (x, y, a, b, false)
    | (([a], [], x), ([], [b], y)) => (x, y, a, b, true)
    | _ => (0, 0, true, true, true)
    end.

  Definition M' : SSM.ssm := map encode_Instruction M.

  Lemma basic_instructions : forall op, In op M -> basic op.
  Proof using basic_M. by apply /Forall_forall. Qed.

  Lemma simulation_step {x y} : step M x y -> SSM.step M' x y.
  Proof using basic_M.
    case=> v w l r l' r' {}x {}y Hop. move: Hop (Hop) => /basic_instructions.
    move H1op: (l, r, x, (l', r', y)) => op H2op. case: H2op H1op.
    - move=> > [] *. subst. apply: SSM.step_r. rewrite /M' in_map_iff. eexists. by constructor; last by eassumption.
    - move=> > [] *. subst. apply: SSM.step_l. rewrite /M' in_map_iff. eexists. by constructor; last by eassumption.
  Qed.

  Lemma simulation {x y} : reachable M x y -> SSM.reachable M' x y.
  Proof using basic_M.
    elim.
    - move=> ? ? /simulation_step ?. by apply: rt_step.
    - move=> *. by apply: rt_refl.
    - move=> *. apply: rt_trans; by eassumption.
  Qed.

  Lemma inverse_simulation_step {x y} : SSM.step M' x y -> step M x y.
  Proof using basic_M.
    case=> >.
    - rewrite /M' in_map_iff. move=> [[[[l r] {}x] [[l' r'] {}y]]] [] + HM.
      move: HM (HM) => /basic_instructions.
      move H1op: (l, r, x, (l', r', y)) => op H2op. case: H2op H1op.
      + move=> > /=. by congruence.
      + move=> > [] /= ? ? ? ? ? ? + [] *. subst. move /transition. by apply.
    - rewrite /M' in_map_iff. move=> [[[[l r] {}x] [[l' r'] {}y]]] [] + HM.
      move: HM (HM) => /basic_instructions.
      move H1op: (l, r, x, (l', r', y)) => op H2op. case: H2op H1op.
      + move=> > [] /= ? ? ? ? ? ? + [] *. subst. move /transition. by apply.
      + move=> > /=. by congruence.
  Qed.

  Lemma inverse_simulation {x y} : SSM.reachable M' x y -> reachable M x y.
  Proof using basic_M.
    elim.
    - move=> ? ? /inverse_simulation_step ?. by apply: rt_step.
    - move=> *. by apply: rt_refl.
    - move=> *. apply: rt_trans; by eassumption.
  Qed.

  Lemma confluent_M' : SSM.confluent M'.
  Proof using basic_M confluent_M.
    move=> ? ? ? /inverse_simulation /= H1 /inverse_simulation /= H2.
    have [? []] := confluent_M _ _ _ H1 H2.
    move=> /simulation /= ? /simulation /= ?.
    eexists. constructor; by eassumption.
  Qed.

  Lemma boundedness : (exists NM, bounded M NM) <-> (exists NM', SSM.bounded M' NM').
  Proof using basic_M.
    constructor.
    - move=> [NM bounded_M]. exists NM.
      move=> X. have [L [HL ?]] := bounded_M X.
      exists L. constructor; last done.
      by move=> ? /inverse_simulation /= /HL ?.
    - move=> [NM' bounded_M']. exists NM'.
      move=> X. have [L [HL ?]] := bounded_M' X.
      exists L. constructor; last done.
      by move=> ? /simulation /= /HL ?.
  Qed.

End Reduction.
End Argument.

Require Import Undecidability.Synthetic.Definitions.

(* compute from a deterministic, length-preserving SMN a confluent simple stack machine *)
Local Definition SMNdl_to_cssm : { M : SMN | deterministic M /\ length_preserving M } -> SSM.cssm.
Proof.
  move=> [M [/deterministic_confluent H1M H2M]].
  exists (Argument.M' (sval (construct_basic_SMN M H1M H2M))).
  apply: Argument.confluent_M'.
  - exact (fst (snd (svalP (construct_basic_SMN M H1M H2M)))).
  - exact (fst ((svalP (construct_basic_SMN M H1M H2M)))).
Defined.

(* many-one reduction from deterministic, length-preserving stack machine uniform boundedness to confluent simple stack machine uniform boundedness *)
Theorem reduction : SMNdl_UB ⪯ SSM.CSSM_UB.
Proof.
  exists SMNdl_to_cssm. move=> [M [H1M H2M]]. constructor.
  - move=> [nMN] /=.
    set M1 := (construct_basic_SMN M (deterministic_confluent H1M) H2M).
    move=> HM. have [? [?]] := svalP M1.
    move /iffLR => /(_ ltac:(by eexists)) => /Argument.boundedness. by apply.
  - move /Argument.boundedness. set M1 := (construct_basic_SMN M (deterministic_confluent H1M) H2M).
    have [? [? <-]] := svalP M1. by apply.
Qed.


Require Import ssreflect ssrbool.
Require Import machine_int.
Import MachineInt.
Require Import C_pp.
Require Import POLAR_asn1_get_len.

Set Printing Width 99999.
Set Printing Depth 99999.

Goal pp_cmd PolarSSL.asn1_get_len "" = "_p_ = *(p); if ((_Bool)(((end - _p_)) < (1))) { ret = 20; ; } else { _c_ = *(_p_); if ((_Bool)(((_c_) & (128)) == (0))) { _len0_ = *(_p_); *(len) = _len0_; _p1_ = (_p_) + (1); *(p) = _p1_; if ((_Bool)(((end - _p1_)) < (_len0_))) { ret = 20; ; } else { ret = 0; ; } } else { _n_ = (_c_) & (127); if ((_Bool)((_n_) == (1))) { if ((_Bool)(((end - _p_)) < (2))) { ret = 20; ; } else { _len1_ = *((_p_) + (1)); *(len) = _len1_; _p2_ = (_p_) + (2); *(p) = _p2_; if ((_Bool)(((end - _p2_)) < (_len1_))) { ret = 20; ; } else { ret = 0; ; } } } else { if ((_Bool)((_n_) == (2))) { if ((_Bool)(((end - _p_)) < (3))) { ret = 20; ; } else { _len2_ = *((_p_) + (1)); _len3_ = *((_p_) + (2)); _len4_ = ((_len2_) << (8)) | (_len3_); *(len) = _len4_; _p3_ = (_p_) + (3); *(p) = _p3_; if ((_Bool)(((end - _p3_)) < (_len4_))) { ret = 20; ; } else { ret = 0; ; } } } else { ret = 24; ; } } } }"%string.
Proof.
rewrite //=.
rewrite /pp_sint /pp_binop /zero32 /one32 !Z2sK //=.
Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import Epsilon.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext ssrnat_ext machine_int multi_int.
Require Import encode_decode integral_type uniq_tac.
Import MachineInt.
Require Import mips_bipl mips_cmd mips_tactics mips_syntax.
Import mips_bipl.expr_m.
Require Import simu.
Import simu.simu_m.

Require Import multi_halve_u_prg multi_halve_u_simu.
Require Import multi_double_u_prg multi_double_u_simu multi_double_u_safe_termination.
Require Import multi_lt_prg multi_lt_termination.
Require Import multi_is_even_u_and_prg multi_is_even_u_and_simu.
Require Import multi_halve_u_safe_termination.
Require Import begcd begcd_mips0.

Local Open Scope machine_int_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope heap_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope assoc_scope.
Local Open Scope uniq_scope.
Local Open Scope asm_expr_scope.
Local Open Scope simu_scope.

Definition prelude_mips rk rg rx ry a0 a1 a2 a3 :=
  multi_is_even_u_and rk rx ry a0 a1 ;
  While (bne a0 r0) {{
    (multi_halve_u rk rx a0 a1 a2 a3 ;
     multi_halve_u rk ry a0 a1 a2 a3 ;
     multi_double_u rk rg a0 a1 a2 a3) ;
    multi_is_even_u_and rk rx ry a0 a1 }}.

Lemma sim_begcd_prelude g u v u1 u2 u3 v1 v2 v3 t1 t2 t3 k
  rk rg ru rv ru1 ru2 ru3 rv1 rv2 rv3 rt1 rt2 rt3 a0 a1 a2 a3 :
  uniq(g, u, v, u1, u2, u3, v1, v2, v3, t1, t2, t3) ->
  uniq(rk, rg, ru, rv, ru1, ru2, ru3, rv1, rv2, rv3, rt1, rt2, rt3, a0, a1, a2, a3, r0) ->
  EGCD.prelude u v g
    <=( state_mint
          (g |=> unsign rk rg \U+ (u |=> unsign rk ru \U+ (v |=> unsign rk rv  \U+
          (u1 |=> signed k ru1 \U+ (u2 |=> signed k ru2 \U+ (u3 |=> signed k ru3 \U+
          (v1 |=> signed k rv1 \U+ (v2 |=> signed k rv2 \U+ (v3 |=> signed k rv3 \U+
          (t1 |=> signed k rt1 \U+ (t2 |=> signed k rt2 \U+ t3 |=> signed k rt3))))))))))),
        fun st s h =>
           ([ u ]_ st * [ g ]_ st)%pseudo_expr < \B^(Z.abs_nat (u2Z [ rk ]_ s)) /\
           (0 <= [ g ]_ st)%pseudo_expr /\
           (0 < [ u ]_ st)%pseudo_expr /\
           0 < (u2Z [ rk ]_s) )
  prelude_mips rk rg ru rv a0 a1 a2 a3.
Proof.
move=> Hvars Hregs.
apply fwd_sim_while ; first by done.
- rewrite /invariant => st s h [st_s_h H] s' h' Hmips; split.
  + set d := assoc.union _ _ in st_s_h.
    have : invariant (state_mint d) (multi_is_even_u_and rk ru rv a0 a1).
      apply state_mint_invariant => //.
      rewrite /d [mips_frame.modified_regs _]/=; by Disj_mints_regs.
    by move/(_ _ _ _ st_s_h _ _ Hmips).
  + Rewrite_reg rk s. exact H.
- rewrite /rela_hoare => st s h Hyp st' Hseplog s' h' Hmips.
  have -> : ([ u ]_ st' = [ u ]_ st / 2)%pseudo_expr.
    case/syntax_m.seplog_m.semop_prop_m.exec_seq_inv : Hseplog.
    case.
    + move=> [st'' h''] [Hseplog1 Hseplog2].
      apply trans_eq with ([ u ]_ st'')%pseudo_expr.
      + Rewrite_var u st''. reflexivity.
      + move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : Hseplog1.
        case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
        by syntax_m.seplog_m.assert_m.expr_m.Store_upd.
    + case=> _. by move/syntax_m.seplog_m.semop_prop_m.from_none.
  have -> : ([ g ]_ st' = [ g ]_ st * 2)%pseudo_expr.
    move/syntax_m.seplog_m.semop_prop_m.exec_seq_assoc' : Hseplog.
    case/syntax_m.seplog_m.semop_prop_m.exec_seq_inv => st'' [st_st''].
    destruct st'' as [[st'' h'']|]; last by move/syntax_m.seplog_m.semop_prop_m.from_none.
    move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv.
    case/syntax_m.seplog_m.exec0_assign_inv => Hh'' /= ->.
    syntax_m.seplog_m.assert_m.expr_m.Store_upd.
    rewrite (syntax_m.var_unchanged _ _ _ _ _ st_st'' g) //.
    rewrite [syntax_m.seplog_m.modified_vars _]/=; move/inP; rewrite -/(~ _); by Uniq_not_In.
  Rewrite_reg rk s.
  have u_st_even : (2 | ([ u ]_st)%pseudo_expr).
    apply Zmod_divide => //.
    case : Hyp => _ [] _ /= /andP []. by move/eqP.
  split.
    rewrite mulZC -mulZA -Zdivide_Zdiv_eq // mulZC; tauto.
  split; first lia.
  split; last tauto.
  apply: (proj1 (Zdivide_Zdiv_lt_pos _ _ _ _ _)) => //; tauto.
- apply fwd_sim_b_stren with (state_mint
        (g |=> unsign rk rg \U+ (u |=> unsign rk ru \U+ (v |=> unsign rk rv \U+
        (u1 |=> signed k ru1 \U+ (u2 |=> signed k ru2 \U+ (u3 |=> signed k ru3 \U+
        (v1 |=> signed k rv1 \U+ (v2 |=> signed k rv2 \U+ (v3 |=> signed k rv3 \U+
        (t1 |=> signed k rt1 \U+ (t2 |=> signed k rt2 \U+ t3 |=> signed k rt3)))))))))))).
    by intuition.
  assoc_tac_m.put_in_front v.
  assoc_tac_m.put_in_front u.
  apply fwd_sim_b_multi_is_even_u_and.
  + rewrite [Equality.sort assoc.l]/= in Hvars *; by Uniq_uniq O.
  + by Uniq_uniq r0 .
- apply fwd_sim_seq with (fun st s _ => 0 <= [ g ]_ st /\ 0 < [ u ]_ st /\
  ([ u ]_ st * [ g ]_ st) < 2 ^^ (Z.abs_nat (u2Z ([rk ]_ s)%asm_expr) * 32 - 1))%pseudo_expr => //.
  + rewrite /rela_hoare => st s h Hyp st' Hseplog s' h' Hmips.
    have -> : ([ u ]_ st' = [ u ]_ st / 2)%pseudo_expr.
      move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : Hseplog.
      case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
      by syntax_m.seplog_m.assert_m.expr_m.Store_upd.
    Rewrite_var g st. Rewrite_reg rk s.
    split; first tauto.
    have u_st_even : (2 | ([ u ]_st)%pseudo_expr).
      apply Zmod_divide => //. case : Hyp => _ [] _ /=. by case/andP => /eqP.
    split.
    * apply: (proj1 (Zdivide_Zdiv_lt_pos _ _ _ _ _)) => //; tauto.
    * apply (@Z.lt_le_trans _ (\B^(Z.abs_nat (u2Z ([rk ]_ s))) / 2)).
      - rewrite mulZC -Zdivide_Zdiv_eq_2 //.
        apply Zdiv_lt_upper_bound => //.
        rewrite (mulZC _ 2) -Z_div_exact_full_2 //.
        + rewrite mulZC; tauto.
        + apply Zpower_mod, lt_O_neq.
          apply/ltP; rewrite muln_gt0 /= andbT.
          apply/O_lt_Zabs_nat; tauto.
     - rewrite Zpower_div //; first exact: leZZ.
       apply/lt_O_neq/ltP; rewrite muln_gt0 /= andbT.
       apply/O_lt_Zabs_nat; tauto.
  + assoc_tac_m.put_in_front u.
    apply pfwd_sim_fwd_sim_spec; last by apply multi_halve_u_safe_termination; Uniq_uniq r0.
    apply pfwd_sim_halve_u.
    - by Uniq_uniq r0.
    - by Disj_mints_regs.
    - by Notin_dom.
    - by Notin_cdom.
  + apply fwd_sim_seq with (fun st s _ =>
    ([ g ]_ st)%pseudo_expr < 2 ^^ ((Z.abs_nat (u2Z ([rk ]_ s)) * 32) - 1)) => //.
    * rewrite /rela_hoare => st s h HP0 st' Hseplog s' h' Hmips.
      Rewrite_var g st. Rewrite_reg rk s.
      apply Zlt_Zmult_inv with ([ u ]_ st)%pseudo_expr.
      - tauto.
      - tauto.
      - apply (@leZ_trans 1) => //; exact: expZ_ge1.
    * assoc_tac_m.put_in_front u.
      apply pfwd_sim_fwd_sim_spec; last first.
        assoc_tac_m.put_in_front v.
        apply multi_halve_u_safe_termination; by Uniq_uniq r0.
      assoc_tac_m.put_in_front v.
      apply pfwd_sim_halve_u => //.
      - by Uniq_uniq r0.
      - by Disj_mints_regs.
      - by Notin_dom.
      - by Notin_cdom.
    * apply pfwd_sim_fwd_sim_spec; last by apply multi_double_u_safe_termination; Uniq_uniq r0.
      apply pfwd_sim_double_u.
      - by Uniq_uniq r0.
      - by Disj_mints_regs.
      - by Notin_dom.
      - by Notin_cdom.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C G Aprime Aprimeprime Bprime Cprime Bprimeprime Bprimeprimeprime : Universe, ((wd_ Aprime Bprimeprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ Aprimeprime Bprimeprime /\ (wd_ Aprime Bprimeprimeprime /\ (wd_ Aprime Bprime /\ (wd_ Bprime Bprimeprimeprime /\ (wd_ G Aprime /\ (wd_ G Aprimeprime /\ (wd_ G Bprimeprime /\ (wd_ Bprimeprime Bprimeprimeprime /\ (wd_ G Bprimeprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ B G /\ (wd_ Bprimeprime B /\ (wd_ A G /\ (wd_ Aprimeprime A /\ (col_ Aprime Bprime Bprimeprimeprime /\ (col_ G Bprimeprime Bprimeprimeprime /\ (col_ Bprimeprime B G /\ (col_ Cprime A B /\ (col_ Bprime A C /\ (col_ G Aprime Aprimeprime /\ (col_ Aprimeprime A G /\ (col_ Aprime B C /\ col_ A B G)))))))))))))))))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Integers.
Require Import Coqlib.
Require Import List. Import ListNotations.
Require Import DRBG_working_state.
Require Import DRBG_state_handle.
Require Import entropy.

(* API spec? *)
Definition DRBG_instantiate_function
           (instantiate_algorithm: list Z -> list Z -> list Z -> Z -> DRBG_working_state)
           (min_entropy_length max_entropy_length: Z)
           (get_nonce: unit -> list Z)
           (highest_supported_security_strength: Z)
           (max_personalization_string_length: Z)
           (prediction_resistance_supported: bool)
           (entropy_stream: ENTROPY.stream)
           (requested_instantiation_security_strength: Z)
           (prediction_resistance_flag: bool)
           (personalization_string: list Z): ENTROPY.result DRBG_state_handle :=
  if Z.gtb requested_instantiation_security_strength highest_supported_security_strength
  then ENTROPY.error ENTROPY.generic_error entropy_stream
  else match prediction_resistance_flag, prediction_resistance_supported with
         | true, false => ENTROPY.error ENTROPY.generic_error entropy_stream
         | _ , _ =>
           if Z.gtb (Zlength personalization_string) max_personalization_string_length
           then ENTROPY.error ENTROPY.generic_error entropy_stream
           else
             let security_strength := requested_instantiation_security_strength in
             (* TODO actually follow specs *)
             (* here get_entropy returns min_entropy_length entropy *)
             match get_entropy security_strength min_entropy_length
                               max_entropy_length prediction_resistance_flag
                               entropy_stream with
               | ENTROPY.error e s' => ENTROPY.error ENTROPY.catastrophic_error s'
               | ENTROPY.success entropy_input entropy_stream =>
                 let nonce := get_nonce tt in
                 let initial_working_state :=
                     (* actual instantiate algorithm is called here *)
                     instantiate_algorithm entropy_input nonce
                                           personalization_string security_strength in
                 ENTROPY.success (initial_working_state, security_strength,
                                  prediction_resistance_flag) entropy_stream
             end
       end.


Unset Structural Injection.

Inductive nCk : nat -> nat -> Type :=
  |zz : nCk 0 0
  | incl { m n : nat } : nCk m n -> nCk (S m) (S n)
  | excl { m n : nat } : nCk m n -> nCk (S m) n.

Definition nCkComp { l m n : nat } :
  nCk l m -> nCk m n -> nCk l n.
Proof.
  intro.
  revert n.
  induction H.
  auto.
(* ( incl w ) o zz -> contradiction *)
  intros.
    remember (S n) as sn.
    destruct H0.
      discriminate Heqsn.
    apply incl.
      apply IHnCk.
      injection Heqsn.
      intro.
      rewrite <- H1.
      auto.
    apply excl.
      apply IHnCk.
      injection Heqsn.
      intro. rewrite <- H1.
      auto.
  intros.
  apply excl.
  apply IHnCk.
  auto.
Defined.

Lemma nCkEq { k l m n : nat } ( cs : nCk k l ) (ct : nCk l m) (cr : nCk m n ):
  nCkComp cs (nCkComp ct cr) = nCkComp (nCkComp cs ct) cr.
Proof.
  revert m n ct cr.
  induction cs.
  intros. simpl. auto.
  intros.
  destruct n.
   destruct m0.
    destruct n0.
     destruct cr.
(* Anomaly: Evar ?nnn was not declared. Please report. *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A C M R B Bprime Rprime X : Universe, ((wd_ A R /\ (wd_ B R /\ (wd_ P Q /\ (wd_ A C /\ (wd_ M X /\ (wd_ M Rprime /\ (wd_ M R /\ (wd_ A P /\ (wd_ A Q /\ (wd_ C P /\ (wd_ C Q /\ (wd_ M A /\ (wd_ M C /\ (wd_ R Rprime /\ (col_ M P Q /\ (col_ R P Q /\ (col_ P M R /\ (col_ Q M R /\ (col_ C X B /\ (col_ M X Rprime /\ (col_ Bprime C Rprime /\ (col_ A M C /\ (col_ R A B /\ (col_ M R Rprime /\ col_ M B Bprime)))))))))))))))))))))))) -> col_ P Q X)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Util IL Sawtooth LabelsDefined OptionR.
Require Import Annotation Liveness.Liveness Restrict SetOperations Coherence.
Require Import Sim SimTactics  SimCompanion SimCompanionTactics.

Set Implicit Arguments.
Unset Printing Records.

(** ** Definition of invariance *)

Definition invariant (s:stmt) :=
  forall (E:onv val), sim bot3 Bisim (nil:list F.block,E,s) (nil:list I.block,E,s).

(** ** Agreement Invariant *)

Definition rd_agree (DL:list (option (set var)))
           L (E:onv val)
  := forall n blk G', get L n blk -> get DL n (Some G') ->
                      agree_on eq G' E (F.block_E blk).

Lemma rd_agree_update DL L E G x v
 (RA:rd_agree DL L E)
  : rd_agree (restr (G \ singleton x) ⊝ DL) L (E [x <- v]).
Proof.
  intros. hnf; intros; inv_get.
  eapply agree_on_update_dead.
  rewrite H1. cset_tac.
  eapply RA; eauto.
Qed.

Lemma rd_agree_update_list DL L E E' (G:set var) Z n vl
 (RA:rd_agree DL L E)
 (ZD:of_list Z ∩ G [=] ∅)
 (LEQ:length Z = length vl)
 (AG:agree_on eq G E E')
: rd_agree (restr G ⊝ (drop n DL)) (drop n L) (E'[Z <-- vl]).
Proof.
  hnf; intros.
  assert (G' ⊆ G). {
    eapply bounded_get; eauto. eapply bounded_restrict; reflexivity.
  }
  assert (G' [=] G' \ of_list Z) by (split; cset_tac; intuition eauto).
  rewrite H2. eapply update_with_list_agree_minus; eauto.
  inv_get.
  hnf in RA.
  etransitivity; try eapply RA; eauto.
  symmetry. eauto using agree_on_incl.
Qed.

(** ** Main Theorem about Coherence *)

(** [strip] removes the environment from a closure  *)

Definition strip (b:F.block) : I.block :=
  I.blockI (F.block_Z b) (F.block_s b) (F.block_n b).

Lemma sawtooth_strip L
  : sawtooth L -> sawtooth (strip ⊝ L).
Proof.
  intros. general induction H; simpl; eauto using @sawtooth.
  - rewrite map_app. econstructor; eauto.
    revert H0; clear_all. generalize 0.
    intros.
    general induction H0; simpl; eauto using @tooth.
Qed.

Hint Resolve sawtooth_strip.

Lemma block_Z_strip L
  : I.block_Z ⊝ strip ⊝ L = F.block_Z ⊝ L.
Proof.
  intros. general induction L; simpl; eauto.
  f_equal; eauto.
Qed.

Lemma mkBlock_strip F L E
  : mapi I.mkBlock F ++ strip ⊝ L = strip ⊝ (mapi (F.mkBlock E) F ++ L).
Proof.
  unfold mapi. generalize 0.
  general induction F; simpl; eauto.
  f_equal. erewrite IHF; eauto.
Qed.

(** The Bisimulation candidate. *)

Local Hint Extern 5 =>
match goal with
| [ H : ?m >= ?k, H' : ?k = ?n |- context [ ?n + (?m - ?n) ] ] =>
  let H := fresh "H" in
  assert (H:n + (m - n) = m) by omega;
    rewrite H;
    clear H
| [ H : ?m >= ?k, H' : ?k = ?n |- context [ ?n + (?m - ?k) ] ] =>
  let H := fresh "H" in
  assert (H:n + (m - k) = m) by omega;
    rewrite H;
    clear H
end.

Lemma rd_agree_extend F als AL L E
: length F = length als
  -> rd_agree AL L E
  -> rd_agree (Some ⊝ (getAnn ⊝ als) \\ (fst ⊝ F) ++ AL) (mapi (F.mkBlock E) F ++ L) E.
Proof.
  intros. hnf; intros.
  eapply get_app_cases in H1; eauto. destruct H1; inv_get.
  - reflexivity.
  - dcr.
    eapply H0; eauto.
    assert (❬mapi (F.mkBlock E) F❭ = ❬Some ⊝ (getAnn ⊝ als) \\ (fst ⊝ F)❭) by eauto 20 with len.
    eapply shift_get; eauto. instantiate (1:=Some ⊝ (getAnn ⊝ als) \\ (fst ⊝ F)).
    eauto.
Qed.

(** The bisimulation is indeed a bisimulation *)

Require Import LivenessCorrect.

Lemma ZL_mapi_F F L E
  : F.block_Z ⊝ (mapi (F.mkBlock E) F ++ L) = fst ⊝ F ++ F.block_Z ⊝ L.
Proof.
  unfold mapi. generalize 0.
  general induction F; simpl; f_equal; eauto.
Qed.

(** ** Context coherence for IL/F contexts: [approxF] *)

(** Stability under restriction *)

Inductive approx Lv AL L f blv o b : Prop :=
| ApproxI lv
  : live_sound Imperative
               (drop (f - block_n b) (block_Z ⊝ L))
               (drop (f - block_n b) Lv) (F.block_s b) lv
    -> getAnn lv [=] blv
    ->  (forall G, o = Some G -> of_list (block_Z b) ∩ G [=] ∅ /\
                          getAnn lv [=] (G ∪ of_list (block_Z b))
                          /\ srd (restr G ⊝ (drop (f - block_n b) AL)) (F.block_s b) lv)
    -> approx Lv AL L f blv o b.

Lemma approx_restrict G Lv AL L f blv o b
  : approx Lv AL L f blv o b
    -> approx Lv (restr G ⊝ AL) L f blv (restr G o) b.
Proof.
  intros. invc H. econstructor; eauto with len.
  intros. eapply restr_iff in H; dcr; subst.
  specialize (H2 G0 eq_refl); eauto; dcr.
  rewrite drop_map in *. rewrite restrict_idem; eauto.
Qed.

Lemma approx_drop Lv AL L blv s g f fb gb
      (ST:sawtooth L) (Getg:get L f fb) (Getf:get L (f - F.block_n fb + g) gb)
  : approx Lv AL L (f - F.block_n fb + g) blv s gb
    -> approx (drop (f - F.block_n fb) Lv)
             (drop (f - F.block_n fb) AL)
             (drop (f - F.block_n fb) L) g blv s gb.
Proof.
  intros. invc H.
  econstructor; eauto.
  sawtooth; eauto.
  intros. specialize (H2 _ H). dcr; subst.
  split; eauto. split; eauto.
  sawtooth. rewrite <- drop_map. eauto.
Qed.

Lemma approx_extend Lv AL L f E F o b blv AL' Lv'
      (ST:sawtooth L) (GETf: get L (f - ❬F❭) b)
      (GE: f >= ❬F❭)
      (Len1:❬F❭ = ❬AL'❭)
      (Len2:❬F❭ = ❬Lv'❭)
  : approx Lv AL L (f - ❬F❭) blv o b
    -> approx (Lv' ++ Lv) (AL' ++ AL)
             (mapi (F.mkBlock E) F ++ L) f blv o b.
Proof.
  intros. invc H. econstructor; eauto.
  rewrite ZL_mapi_F.
  sawtooth. eauto.
  intros; subst. specialize (H2 _ eq_refl); dcr.
  split; eauto. split; eauto.
  sawtooth. rewrite map_app.
  sawtooth. rewrite drop_map in *. eauto.
Qed.

Lemma srdSim_sim AL Lv L
      (E:onv val) s lv
  (SRD:srd AL s lv)
  (RA:rd_agree AL L E)
  (ST:sawtooth L)
  (LA: forall f b blv o, get L f b ->
                  get Lv f blv ->
                  get AL f o ->
                  approx Lv AL L f blv o b)
  (LV:live_sound Imperative (block_Z ⊝ L) Lv s lv)
  (ER:PIR2 (ifFstR Equal) AL (Lv \\ (block_Z ⊝ L)))
  (Len: ❬Lv❭ = ❬AL❭)
  : simc bot3 Bisim (L, E, s) (strip ⊝ L, E, s).
Proof.
  unfold simc.
  revert_all. eapply Tower3.tower_ind3.
  hnf; intros. hnf; intros. eauto.
  intros.
  inv SRD; inv LV; simpl in *.
  - invt live_exp_sound.
    + eapply (@sim_let_op _ il_statetype_F _ il_statetype_I);
        intros; eauto.
      eapply H; eauto using rd_agree_update with len.
      -- intros. inv_get. eapply approx_restrict; eauto.
      -- eauto using restrict_ifFstR.
    + eapply (@sim_let_call _ il_statetype_F _ il_statetype_I);
        intros; eauto.
      eapply H; eauto using rd_agree_update, PIR2_length, restrict_ifFstR with len.
      ++ intros; inv_get. eapply approx_restrict; eauto.
  - eapply (@sim_cond _ il_statetype_F _ il_statetype_I); eauto.
  - pno_step.
  - decide (length Z = length Y).
    case_eq (omap (op_eval E) Y); intros.
    + inv_get. exploit LA; eauto. invc H2. simpl in *.
      specialize (H7 G' eq_refl). dcr. rewrite <- drop_map in *.
      pone_step; simpl. eauto with len.
      exploit RA; eauto; simpl in *.
      eapply simc_trans_r_left; swap 1 2.
      * eapply H; eauto with len.
        -- eapply rd_agree_update_list; eauto with len.
        -- intros. inv_get. eapply approx_restrict.
           exploit LA; try eapply H11; eauto using approx_drop.
        -- setoid_rewrite drop_map at 2.
           rewrite <- drop_zip.
           eapply restrict_ifFstR; eauto.
           eapply PIR2_drop; eauto.
      * eapply sim_lock_simc.
        rewrite drop_map in *.
        eapply liveSimI_sim; try rewrite !drop_map; try rewrite block_Z_strip; eauto.
        -- eapply (sawtooth_drop'); eauto.
        -- intros; inv_get. sawtooth.
           exploit LA; eauto. invc H16. eauto.
        -- rewrite H12. eapply update_with_list_agree; eauto with len.
           symmetry. eapply agree_on_incl; eauto.
           clear_all. cset_tac.
    + pno_step.
    + pno_step.
  - pone_step. erewrite mkBlock_strip.
    eapply H; try rewrite ZL_mapi; try rewrite ZL_mapi_F;
      eauto using agree_on_incl, PIR2_app, rd_agree_extend.
    * intros; inv_get. sawtooth.
      -- econstructor; simpl; eauto; try rewrite ZL_mapi_F; try reflexivity.
         sawtooth. eauto. intros. invc H4.
         split. clear_all; cset_tac; intuition.
         split.
         exploit H13; eauto; dcr; simpl in *; eauto with cset.
         exploit H1; eauto. sawtooth. eauto.
      -- eapply get_app_ge in H5; eauto; len_simpl; try omega.
         rewrite <- H0 in *. inv_get.
         exploit LA; eauto.
         eapply approx_extend; eauto with len.
    * rewrite zip_app; eauto with len.
      eapply PIR2_app; eauto using PIR2_ifFstR_refl.
    * eauto with len.
Qed.

(** ** Coherence implies invariance *)

Lemma srd_implies_invariance s a
: live_sound Imperative nil nil s a -> srd nil s a -> invariant s.
Proof.
  intros. hnf; intros.
  eapply simc_sim.
  eapply srdSim_sim with (L:=nil); eauto.
  isabsurd. econstructor. isabsurd. econstructor.
Qed.


(** * HSET is a univalent_category ([is_univalent_HSET]) *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.Foundations.UnivalenceAxiom.
Require Import UniMath.Foundations.HLevels.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.

Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso.

Local Open Scope cat.

(** ** HSET is a univalent_category. *)

Definition hset_id_weq_z_iso (A B : ob HSET) :
  (A = B) ≃ (z_iso A B) :=
  weqcomp (UA_for_HLevels 2 A B) (hset_equiv_weq_z_iso A B).

(** The map [precat_paths_to_iso]
    for which we need to show [isweq] is actually
    equal to the carrier of the weak equivalence we
    constructed above.
    We use this fact to show that that [precat_paths_to_iso]
    is an equivalence.
*)

Lemma hset_id_weq_iso_is (A B : ob HSET):
    @idtoiso _ A B = pr1 (hset_id_weq_z_iso A B).
Proof.
  apply funextfun.
  intro p; elim p.
  apply z_iso_eq; simpl.
  - apply funextfun;
    intro x;
    destruct A.
    apply idpath.
Defined.

Lemma is_weq_precat_paths_to_iso_hset (A B : ob HSET):
   isweq (@idtoiso _ A B).
Proof.
  rewrite hset_id_weq_iso_is.
  apply (pr2 (hset_id_weq_z_iso A B)).
Defined.

Definition category_HSET : category := make_category HSET has_homsets_HSET.

Lemma is_univalent_HSET : is_univalent category_HSET.
Proof.
  intros a b.
  apply (is_weq_precat_paths_to_iso_hset a b).
Defined.

Definition HSET_univalent_category : univalent_category := _ ,, is_univalent_HSET.


Require Import Leapfrog.Benchmarks.ProofHeader.
Require Import Leapfrog.Benchmarks.Timestamp.

Notation H := (TimestampRefSmall.header + TimestampSpecSmall.header).
Notation A := (Sum.sum TimestampRefSmall.aut TimestampSpecSmall.aut).
Notation conf := (P4automaton.configuration (P4A.interp A)).
Notation start_left := TimestampRefSmall.Start.
Notation start_right := TimestampSpecSmall.Start.

Definition r_states :=
  Eval vm_compute in (Reachability.reachable_states
                        A
                        200
                        start_left
                        start_right).

Declare ML Module "mirrorsolve".

(*
RegisterEnvCtors
  (TimestampRefSmall.Len, FirstOrderConfRelSimplified.Bits 2)
  (TimestampRefSmall.Pref1, FirstOrderConfRelSimplified.Bits 8)
  (TimestampRefSmall.Pref2, FirstOrderConfRelSimplified.Bits 16)
  (TimestampRefSmall.Timestamps, FirstOrderConfRelSimplified.Bits 24)
  (TimestampSpecSmall.Len, FirstOrderConfRelSimplified.Bits 2)
  (TimestampSpecSmall.T1, FirstOrderConfRelSimplified.Bits 8)
  (TimestampSpecSmall.T2, FirstOrderConfRelSimplified.Bits 8)
  (TimestampSpecSmall.T3, FirstOrderConfRelSimplified.Bits 8).
*)

  Lemma prebisim_incremental_sep:
  forall q1 q2,
    interp_conf_rel' {| cr_st := {|
                        cs_st1 := {|
                          st_state := inl (inl (start_left));
                          st_buf_len := 0;
                        |};
                        cs_st2 := {|
                          st_state := inl (inr (start_right));
                          st_buf_len := 0;
                        |};
                      |};
                      cr_ctx := BCEmp;
                      cr_rel := btrue;
                   |} q1 q2 ->
  pre_bisimulation A
                   (projT1 r_states)
                   (wp (a := A))
                   []
                   (mk_init _ _ _ _ A 200 start_left start_right)
                   q1 q2.
Proof.
  idtac "running small timestamp bisimulation".

  intros.
  set (a := A).
  set (rel0 := (mk_init _ _ _ _ _ _ _ _)).
  vm_compute in rel0.
  subst rel0.

  time "build phase" repeat (time "single step" run_bisim).
  time "close phase" close_bisim.
Time Admitted.


Require Import extraInv.
Require Import verif_cond_6.
Local Open Scope Z.

Theorem extra6: (commonStartnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1) /\
 cond6 -> (extraInv hands1 dryer1 ctrlState2 ctrlTimer2 timer1).

Proof.
intros.
inversion_clear H.
inversion_clear H1.
inversion_clear H2.
inversion_clear H3.
inversion_clear H4.
inversion_clear H5.
inversion_clear H0.
inversion_clear H7.
inversion_clear H8.
inversion_clear H9.
inversion_clear H10.
(*ctrlState0[i]=ctrlState2[i]*)
assert (HctrlState0_ctrlState2_same : (forall i, (0<=i /\ i<=timer0  -> ctrlState0.[of_Z i]=ctrlState2.[of_Z i]))).
intros.
replace ctrlState2.[of_Z i] with ctrlState1.[of_Z i].
apply arr_same_before_upd  with ctrlState0.[of_Z (timer1-1)] timer1.
split.
auto with zarith.
assumption.
apply arr_same_before_upd with ctrlWaiting timer1.
split.
auto with zarith.
assumption.
(*split extraInv in the hypothesis*)
inversion_clear H5.
inversion_clear H12.
inversion_clear H13.
inversion_clear H14.
inversion_clear H15.
inversion_clear H16.
inversion_clear H17.
inversion_clear H18.
inversion_clear H19.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
auto with zarith.
split.
auto with zarith.
split.
(*ctrlState[i]=ctrlWaiting \/ ctrlState[i]=ctrlDrying*)
intros.
elim Zle_lt_or_eq with i timer1.
(*case i<timer1*)
intros.
rewrite <- HctrlState0_ctrlState2_same.
repeat split.
auto with zarith.
auto with zarith.
(*ctrlState[i]=ctrlWaiting \/ ctrlState[i]=ctrlDrying*)
intros.
elim Zle_lt_or_eq with i timer1.
(*case i<timer1*)
intros.
rewrite <- HctrlState0_ctrlState2_same.
apply H18.
auto with zarith.
auto with zarith.
(*case i=timer1*)
intros.
rewrite H21.
left.
rewrite H6.
apply get_set_same.
rewrite H8.
rewrite length_set.
apply ctrlState_inf.
inversion_clear H19.
assumption.
inversion_clear H19.
assumption.
(*ctrlState[timer]=ctrlDrying ->...*)
intros.
rewrite H6 in H19.
rewrite get_set_same in H19.
contradict H19.
discriminate.
rewrite H8.
rewrite length_set.
apply ctrlState_inf.
Qed.


Require Export ZArith.
Require Export String.
Require Export List.
Require Export maps.

Global Open Scope Z_scope.
Global Open Scope string_scope.
Global Open Scope list_scope.

Set Implicit Arguments.

Inductive Defn : Set :=
   FunDef : string -> list string -> Stmt -> Defn
with Exp : Set :=
   BCon : bool -> Exp
 | EVar : string -> Exp
 | ECon : Z -> Exp
 | EValStruct : sval -> Exp
 | ExpUndef : Undef -> Exp
 | ENeg : Exp -> Exp
 | EMult : Exp -> Exp -> Exp
 | EPlus : Exp -> Exp -> Exp
 | EMinus : Exp -> Exp -> Exp
 | EProject : Exp -> string -> Exp
 | EDiv : Exp -> Exp -> Exp
 | BLe : Exp -> Exp -> Exp
 | BLt : Exp -> Exp -> Exp
 | BEq : Exp -> Exp -> Exp
 | BAnd : Exp -> Exp -> Exp
 | BOr : Exp -> Exp -> Exp
 | EAlloc : Exp
 | EBuild : Map k k -> Exp
 | ECall : string -> list Exp -> Exp
 | ELoad : Exp -> Exp
 | BNot : Exp -> Exp
 | HOLE_Exp : Exp
with Frame : Set :=
   frame : k -> Map k k -> Frame
with kitem : Set :=
   KBool : bool -> kitem
 | KDefn : Defn -> kitem
 | KExp : Exp -> kitem
 | KExps : list Exp -> kitem
 | KFrame : Frame -> kitem
 | KFrames : list Frame -> kitem
 | KId : string -> kitem
 | KIds : list string -> kitem
 | KInt : Z -> kitem
 | KMap : Map k k -> kitem
 | KPgm : list Defn -> kitem
 | KStmt : Stmt -> kitem
 | KStruct : sval -> kitem
 | KUndef : Undef -> kitem
 | KFreeze : kitem -> kitem
with KResult : Set :=
   Bool : bool -> KResult
 | Int : Z -> KResult
 | VStruct : sval -> KResult
 | VUndef : Undef -> KResult
with Stmt : Set :=
   HAssign : Exp -> Exp -> Stmt
 | SAssign : string -> Exp -> Stmt
 | Seq : Stmt -> Stmt -> Stmt
 | HDealloc : Exp -> Stmt
 | Decl : string -> Stmt
 | SIf : Exp -> Stmt -> Stmt -> Stmt
 | Jump : Exp -> Stmt
 | SReturnVoid : Stmt
 | SReturn : Exp -> Stmt
 | SCall : string -> list Exp -> Stmt
 | Skip : Stmt
 | SWhile : Exp -> Stmt -> Stmt
with sval : Set :=
   Struct : Map k k -> sval
with Undef : Set :=
   undef : Undef
with k : Set := kdot | kra : kitem -> k -> k
 .

Definition KResultToExp (x : KResult) : Exp :=
  match x with
  | Bool i => BCon i
  | Int i => ECon i
  | VStruct i => EValStruct i
  | VUndef i => ExpUndef i
  end.
Definition KResultFromExp (x : Exp) : option KResult :=
  match x with
  | BCon i => Some (Bool i)
  | ECon i => Some (Int i)
  | EValStruct i => Some (VStruct i)
  | ExpUndef i => Some (VUndef i)
  | _ => None
  end.
Definition KResultToK (x : KResult) : kitem :=
  match x with
  | Bool i => KBool i
  | Int i => KInt i
  | VStruct i => KStruct i
  | VUndef i => KUndef i
  end.
Definition KResultFromK (x : kitem) : option KResult :=
  match x with
  | KBool i => Some (Bool i)
  | KInt i => Some (Int i)
  | KStruct i => Some (VStruct i)
  | KUndef i => Some (VUndef i)
  | _ => None
  end.
Definition ExpToK (x : Exp) : kitem :=
  match x with
  | BCon i => KBool i
  | EVar i => KId i
  | ECon i => KInt i
  | EValStruct i => KStruct i
  | ExpUndef i => KUndef i
  | _ => KExp x
  end.
Definition ExpFromK (x : kitem) : option Exp :=
  match x with
  | KBool i => Some (BCon i)
  | KExp i => Some i
  | KId i => Some (EVar i)
  | KInt i => Some (ECon i)
  | KStruct i => Some (EValStruct i)
  | KUndef i => Some (ExpUndef i)
  | _ => None
  end.


Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Rewriter.Language.Wf.
Require Import Crypto.Language.WfExtra.
Require Import Crypto.Rewriter.AllTacticsExtra.
Require Import Crypto.Rewriter.TestRulesProofs.

Module Compilers.
  Import Language.Compilers.
  Import Language.API.Compilers.
  Import Language.Wf.Compilers.
  Import Language.WfExtra.Compilers.
  Import Rewriter.AllTacticsExtra.Compilers.RewriteRules.GoalType.
  Import Rewriter.AllTactics.Compilers.RewriteRules.Tactic.
  Import Compilers.Classes.

  Module Import RewriteRules.
    Section __.
      (* Passing [true] as the second argument makes [make_rewriter] significantly faster by disabling early reduction; the trade-off is that rewriting later on is a bit slower. *)
      Definition VerifiedRewriterTest : VerifiedRewriter_with_args false true true test_rewrite_rules_proofs.
      Proof using All. make_rewriter. Defined.

      Definition default_opts := Eval hnf in @default_opts VerifiedRewriterTest.
      Let optsT := Eval hnf in optsT VerifiedRewriterTest.

      Definition RewriteTest (opts : optsT) {t : API.type} := Eval hnf in @Rewrite VerifiedRewriterTest opts t.

      Lemma Wf_RewriteTest opts {t} e (Hwf : Wf e) : Wf (@RewriteTest opts t e).
      Proof. now apply VerifiedRewriterTest. Qed.

      Lemma Interp_RewriteTest opts {t} e (Hwf : Wf e) : API.Interp (@RewriteTest opts t e) == API.Interp e.
      Proof. now apply VerifiedRewriterTest. Qed.
    End __.
  End RewriteRules.

  Module Export Hints.
    Hint Resolve Wf_RewriteTest : wf wf_extra.
    Hint Opaque RewriteTest : wf wf_extra interp interp_extra rewrite.
    Hint Rewrite @Interp_RewriteTest : interp interp_extra.
  End Hints.
End Compilers.

Module Example.
  Import Coq.ZArith.ZArith.
  Import Compilers.RewriteRules.
  Import Crypto.Util.ZRange.
  Import Crypto.Language.PreExtra.
  Import Rewriter.Util.plugins.RewriterBuild.
  Local Notation cstZ r := (ident.cast (r%zrange)).
  Goal forall x y : Z, fst (x, y) = x.
  Proof.
    Rewrite_for VerifiedRewriterTest.
  Abort.
End Example.


From VST Require Import floyd.proofauto floyd.sublist.
From VSTArrayProgs Require Import binary_search_theory binary_search_range.

Ltac do_compute_expr_warning::=idtac.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition binary_search_range_spec :=
 DECLARE _binary_search_range
  WITH a: val, sh : share, contents : list Z, from : Z, to : Z, key : Z
  PRE [ tptr tint, tint, tint, tint ]
    PROP (readable_share sh;
          0 <= from <= to;
          to <= Zlength contents <= Int.max_signed;
          Int.min_signed <= key <= Int.max_signed;
          Forall (fun x => Int.min_signed <= x <= Int.max_signed) (sublist from to contents);
          sorted (sublist from to contents))
     PARAMS (a; Vint (Int.repr from); Vint (Int.repr to); Vint (Int.repr key))
     SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a)
  POST [ tint ]
    EX i:Z,
     PROP (if in_dec Z.eq_dec key (sublist from to contents) then Znth i (sublist from to contents) = key
           else insertion_point (-i - 1) (sublist from to contents) key from to)
     RETURN (Vint (Int.repr i))
     SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a).

Definition binary_search_range_while_spec a sh contents from to key :=
EX low : Z, EX high : Z,
 PROP (from <= low <= to;
       Int.min_signed <= high < to;
       In key (sublist from to contents) -> In key (sublist low (high + 1) contents);
       ~ In key (sublist from to contents) ->
        Forall (fun x => x < key) (sublist from low contents) /\
        Forall (fun x => key < x) (sublist (high + 1) to contents))
 LOCAL (temp _a a; temp _key (Vint (Int.repr key)); temp _low (Vint (Int.repr low)); temp _high (Vint (Int.repr high)))
 SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a).

Definition binary_search_spec :=
 DECLARE _binary_search
  WITH a: val, sh : share, contents : list Z, len : Z, key : Z
  PRE [ tptr tint, tint, tint ]
    PROP (readable_share sh;
          Zlength contents <= Int.max_signed;
          len = Zlength contents;
          Int.min_signed <= key <= Int.max_signed;
          Forall (fun x => Int.min_signed <= x <= Int.max_signed) contents;
          sorted contents)
    PARAMS (a; Vint (Int.repr len); Vint (Int.repr key))
    SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a)
  POST [ tint ]
    EX i:Z,
     PROP (if in_dec Z.eq_dec key contents then Znth i contents = key
           else insertion_point (-i - 1) contents key 0 (Zlength contents))
     RETURN (Vint (Int.repr i))
     SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs := ltac:(with_library prog [binary_search_range_spec; binary_search_spec; main_spec]).

Lemma In_sorted_gt_sublist : forall x i n l from to low high,
 0 <= from <= low ->
 high <= to <= Zlength l ->
 sorted (sublist from to l) ->
 In x (sublist low high l) ->
 low <= i < high ->
 Znth i l = n ->
 n < x ->
 In x (sublist (i + 1) high l).
Proof.
  intros.
  rewrite sublist_split with (mid := i + 1) in H2; try lia.
  rewrite in_app in H2; destruct H2; auto.
  Check In_sorted_range.
  (*generalize (In_sorted_range low (i + 1) x _ H1); intro X.
  repeat (lapply X; [clear X; intro X | lia]).
  replace (i + 1 - 1) with i in X by lia.
  autorewrite with sublist in *.
  assert (Hle: i + 1 <= to - from).
    enough (i + 1 <= high - low) by lia. *)
Admitted.

Lemma body_binary_search_range: semax_body Vprog Gprog f_binary_search_range binary_search_range_spec.
Proof.
start_function.
forward.
forward.
forward_while (binary_search_range_while_spec a sh contents from to key).
- unfold binary_search_range_while_spec.
  entailer!.
  Exists from; Exists (to - 1).
  entailer!.
  split; intros; [|split]; autorewrite with sublist in *.
  * assumption.
  * apply Forall_nil.
  * apply Forall_nil.
- entailer!.
- assert (Hle: low <= high) by lia.
  pose proof (mean_le _ _  Hle) as Hdle.
  assert (Heq: Int.signed (Int.divs (Int.repr (high - low)) (Int.repr 2)) = (high - low) / 2).
    unfold Int.divs; rewrite !Int.signed_repr; try rep_lia; [rewrite Zquot.Zquot_Zdiv_pos by lia; reflexivity|].
    rewrite !Int.signed_repr; try rep_lia.
    rewrite Zquot.Zquot_Zdiv_pos by lia.
    rep_lia.
  assert (Heq': Int.unsigned (Int.add (Int.repr low) (Int.divs (Int.repr (high - low)) (Int.repr 2))) = low + (high - low) / 2).
    unfold Int.divs; rewrite !Int.signed_repr; try rep_lia.
    rewrite Zquot.Zquot_Zdiv_pos by lia.
    rewrite add_repr.
    rewrite !Int.unsigned_repr; auto.
    rep_lia.
  assert (Heq'': Int.signed (Int.add (Int.repr low) (Int.divs (Int.repr (high - low)) (Int.repr 2))) = low + (high - low) / 2).
    unfold Int.divs; rewrite !Int.signed_repr; try rep_lia.
    rewrite add_repr.
    rewrite !Int.signed_repr; [rewrite Zquot.Zquot_Zdiv_pos by lia; reflexivity|].
    rewrite Zquot.Zquot_Zdiv_pos by lia.
    rep_lia.
  forward.
  * entailer!.
    destruct H11.
    unfold Int.mone in H12.
    apply repr_inj_signed in H12; [congruence|unfold repable_signed|unfold repable_signed]; rep_lia.
  * forward.
    forward_if.
    + forward.
      entailer!.
      Exists ((low + ((high - low)/2)) + 1,high).
      entailer!.
      split; [lia|]; split; [|split]; intros.
      -- specialize (H6 H12).
Admitted.

Lemma body_binary_search: semax_body Vprog Gprog f_binary_search binary_search_spec.
Proof.
start_function.
forward_call (a, sh, contents, 0, len, key).
- pose proof (Zlength_nonneg contents) as Hlen.
  rewrite H0.
  split; auto; split; [lia|]; split; [lia|]; split; auto; split.
  * autorewrite with sublist; assumption.
  * autorewrite with sublist; assumption.
- Intro res.
  forward.
  revert H4.
  autorewrite with sublist.
  case (in_dec _ _ _); intros; Exists res; entailer!.
Qed.

Definition four_contents := [1; 2; 3; 4].

Lemma body_main : semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  forward_call (gv _four,Ews,four_contents,4,3).
  { split. auto.
    change (Zlength four_contents) with 4.
    repeat constructor; computable.
  }
  Intro r; forward.
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_binary_search_range.
semax_func_cons body_binary_search.
semax_func_cons body_main.
Qed.


Require Export RecTypes.SpecTypes.
Require Export RecTypes.InstTy.
Require Export RecTypes.Contraction.
Require Export RecTypes.ValidTy.
Require Export RecTypes.LemmasTypes.

Require Import StlcFix.LemmasEvaluation.
Require Import StlcFix.LemmasTyping.
Require Import StlcFix.SpecEvaluation.
Require Import StlcFix.SpecEquivalent.
Require Import StlcFix.SpecSyntax.
Require Import StlcFix.SpecTyping.
Require Import StlcFix.SpecAnnot.
Require Import StlcEqui.LemmasEvaluation.
Require Import StlcEqui.SpecEvaluation.
Require Import StlcEqui.SpecEquivalent.
Require Import StlcEqui.SpecSyntax.
Require Import UValFE.UVal.

Module F.
  Include StlcFix.LemmasEvaluation.
  Include StlcFix.LemmasTyping.
  Include StlcFix.SpecEvaluation.
  Include StlcFix.SpecEquivalent.
  Include StlcFix.SpecSyntax.
  Include StlcFix.SpecTyping.
  Include StlcFix.SpecAnnot.
End F.

Module E.
  Include RecTypes.SpecTypes.
  Include RecTypes.InstTy.
  Include RecTypes.Contraction.
  Include RecTypes.ValidTy.
  Include RecTypes.LemmasTypes.
  Include StlcEqui.LemmasEvaluation.
  Include StlcEqui.LemmasTyping.
  Include StlcEqui.SpecEvaluation.
  Include StlcEqui.SpecEquivalent.
  Include StlcEqui.SpecAnnot.
  Include StlcEqui.SpecTyping.
  Include StlcEqui.SpecSyntax.
End E.

Inductive Prec : Set :=
| precise
| imprecise.

Inductive PTy : Set :=
| ptarr (τ₁ τ₂ : PTy)
| ptunit
| ptbool
| ptprod (τ₁ τ₂ : PTy)
| ptsum (τ₁ τ₂ : PTy)
| pEmulDV (n : nat) (p : Prec) (τ : E.Ty).

Fixpoint repEmul (τ : PTy) : F.Ty :=
  match τ with
    | ptarr τ₁ τ₂ => F.tarr (repEmul τ₁) (repEmul τ₂)
    | ptunit => F.tunit
    | ptbool => F.tbool
    | ptprod τ₁ τ₂ => F.tprod (repEmul τ₁) (repEmul τ₂)
    | ptsum τ₁ τ₂ => F.tsum (repEmul τ₁) (repEmul τ₂)
    | pEmulDV n p T => UValFE n T
  end.

Fixpoint fxToIs (τ : PTy) : E.Ty :=
  match τ with
    | ptunit => E.tunit
    | ptbool => E.tbool
    | ptprod τ₁ τ₂ => E.tprod (fxToIs τ₁) (fxToIs τ₂)
    | ptarr τ₁ τ₂ => E.tarr (fxToIs τ₁) (fxToIs τ₂)
    | ptsum τ₁ τ₂ => E.tsum (fxToIs τ₁) (fxToIs τ₂)
    | pEmulDV n p T => T
  end.

Definition OfTypeStlcFix (τ : PTy) (t : F.Tm) : Prop :=
  F.Value t ∧ (F.Typing F.empty t (repEmul τ) ).

(* Fixpoint OfTypeStlcEqui' (τ : PTy) (t : U.UTm) : Prop := *)
(*   match τ with *)
(*     | ptarr τ₁ τ₂ => *)
(*       match t with *)
(*         | U.abs _ => True *)
(*         | _       => False *)
(*       end *)
(*     | ptunit => t = U.unit *)
(*     (* | ptbool => t = U.true ∨ t = U.false *) *)
(*     (* | ptprod τ₁ τ₂ => *) *)
(*     (*   match t with *) *)
(*     (*     | U.pair t₁ t₂ => OfTypeStlcEqui' τ₁ t₁ ∧ OfTypeStlcEqui' τ₂ t₂ *) *)
(*     (*     | _            => False *) *)
(*     (*   end *) *)
(*     | ptsum τ₁ τ₂ => *)
(*       match t with *)
(*         | U.inl t₁ => OfTypeStlcEqui' τ₁ t₁ *)
(*         | U.inr t₂ => OfTypeStlcEqui' τ₂ t₂ *)
(*         | _        => False *)
(*       end *)
(*     | pEmulDV n p => U.Value t *)
(*   end. *)
(* Arguments OfTypeStlcEqui' !τ !t /. *)

Definition OfTypeStlcEqui (τ : PTy) (t : E.Tm) : Prop :=
  E.Value t ∧ E.Typing (E.empty) t (fxToIs τ).

Arguments OfTypeStlcEqui !τ !t /.

Definition OfType (τ : PTy) (t₁ : F.Tm) (t₂ : E.Tm) : Prop :=
  OfTypeStlcFix τ t₁ ∧ OfTypeStlcEqui τ t₂.

Inductive PEnv : Set :=
| pempty
| pevar (Γ : PEnv) (τ : PTy).

Notation "Γ p▻ T" := (pevar Γ T) (at level 55, left associativity).

Fixpoint pdom (Γ : PEnv) : Dom :=
  match Γ with
    | pempty => 0
    | pevar Γ _ => S (pdom Γ)
  end.

Reserved Notation "⟪  i : T p∈ Γ  ⟫"
  (at level 0, i at level 98, Γ at level 98).
Inductive GetEvarP : PEnv → Ix → PTy → Prop :=
  | GetEvarHere {Γ T} :
      ⟪   O : T p∈ Γ p▻ T  ⟫
  | GetEvarThere {Γ T T' i} :
      ⟪   i : T p∈ Γ      ⟫ →
      ⟪ S i : T p∈ Γ p▻ T' ⟫
where "⟪  i : T p∈ Γ  ⟫" := (GetEvarP Γ i T).

Lemma pdom_works {i T Γ} :
  ⟪ i : T p∈ Γ ⟫ → pdom Γ ∋ i.
Proof.
  induction 1; constructor; eauto.
Qed.

Lemma pdom_works_inv {i Γ} :
  pdom Γ ∋ i → ∃ τ, ⟪ i : τ p∈ Γ ⟫.
Proof.
  revert i. induction Γ; intros i.
  - inversion 1.
  - inversion 1.
    + subst. exists τ. constructor.
    + subst. destruct (IHΓ i0 H1) as (τ0 & iinΓ).
      exists τ0. constructor. assumption.
Qed.

Fixpoint repEmulCtx (Γ : PEnv) : F.Env :=
  match Γ with
    | pempty => F.empty
    | pevar Γ τ => F.evar (repEmulCtx Γ) (repEmul τ)
  end.

Lemma repEmulCtx_works {Γ i τ} :
  ⟪ i : τ p∈ Γ ⟫ →
  F.GetEvar (repEmulCtx Γ) i (repEmul τ).
Proof.
  induction 1; eauto using F.GetEvar.
Qed.

Fixpoint fxToIsCtx (Γ : PEnv) : E.Env :=
  match Γ with
  | pempty => E.empty
  | pevar Γ τ => E.evar (fxToIsCtx Γ) (fxToIs τ)
  end.

Lemma fxToIsCtx_works {Γ i τ} :
  ⟪ i : τ p∈ Γ ⟫ →
  E.GetEvar (fxToIsCtx Γ) i (fxToIs τ).
Proof.
  induction 1; eauto using E.GetEvar.
Qed.

Fixpoint embed (τ : F.Ty) : PTy :=
  match τ with
    | F.tunit => ptunit
    | F.tarr τ₁ τ₂ => ptarr (embed τ₁) (embed τ₂)
    | F.tbool => ptbool
    | F.tprod τ₁ τ₂ => ptprod (embed τ₁) (embed τ₂)
    | F.tsum τ₁ τ₂ => ptsum (embed τ₁) (embed τ₂)
  end.

Fixpoint embedCtx (Γ : F.Env) : PEnv :=
  match Γ with
    | F.empty => pempty
    | F.evar Γ τ => pevar (embedCtx Γ) (embed τ)
  end.

Lemma embedCtx_works {Γ i τ} :
  F.GetEvar Γ i τ →
  ⟪ i : embed τ p∈ embedCtx Γ ⟫.
Proof.
  induction 1; eauto using GetEvarP.
Qed.

Lemma embedCtx_works_inv {Γ i τ} :
  ⟪ i : τ p∈ embedCtx Γ ⟫ →
  exists τ', τ = embed τ' ∧ (F.GetEvar Γ i τ').
Proof.
  revert i τ. induction Γ; intros i τ' iτ; simpl in *; inversion iτ; subst.
  - exists τ; intuition.
  - destruct (IHΓ _ _ H3) as [τ'' [eq ty]].
    exists τ''; intuition; eauto using GetEvarP.
Qed.

Lemma OfTypeStlcEqui_fxToIs {vu τ τ'}:
  fxToIs τ = fxToIs τ' ->
  OfTypeStlcEqui τ vu ->
  OfTypeStlcEqui τ' vu.
Proof.
  intros eq [vvu tyu].
  split; [assumption|].
  now rewrite <-eq.
Qed.


From iris.bi Require Import bi.
From iris.proofmode Require Export classes.
From iris.prelude Require Import options.
Import bi.

Section modalities.
  Context {PROP : bi}.

  Lemma modality_persistently_mixin :
    modality_mixin (@bi_persistently PROP) MIEnvId MIEnvClear.
  Proof.
    split; simpl; eauto using equiv_entails_1_2, persistently_intro,
      persistently_mono, persistently_sep_2 with typeclass_instances.
  Qed.
  Definition modality_persistently :=
    Modality _ modality_persistently_mixin.

  Lemma modality_affinely_mixin :
    modality_mixin (@bi_affinely PROP) MIEnvId (MIEnvForall Affine).
  Proof.
    split; simpl; eauto using equiv_entails_1_2, affinely_intro, affinely_mono,
      affinely_sep_2 with typeclass_instances.
  Qed.
  Definition modality_affinely :=
    Modality _ modality_affinely_mixin.

  Lemma modality_intuitionistically_mixin :
    modality_mixin (@bi_intuitionistically PROP) MIEnvId MIEnvIsEmpty.
  Proof.
    split; simpl; eauto using equiv_entails_1_2, intuitionistically_emp,
      affinely_mono, persistently_mono, intuitionistically_idemp,
      intuitionistically_sep_2 with typeclass_instances.
  Qed.
  Definition modality_intuitionistically :=
    Modality _ modality_intuitionistically_mixin.

  Lemma modality_embed_mixin `{!BiEmbed PROP PROP'} :
    modality_mixin (@embed PROP PROP' _)
      (MIEnvTransform IntoEmbed) (MIEnvTransform IntoEmbed).
  Proof.
    split; simpl; split_and?;
      eauto using equiv_entails_1_2, embed_emp_2, embed_sep, embed_and.
    - intros P Q. rewrite /IntoEmbed=> ->. by rewrite embed_intuitionistically_2.
    - by intros P Q ->.
  Qed.
  Definition modality_embed `{!BiEmbed PROP PROP'} :=
    Modality _ modality_embed_mixin.

  Lemma modality_plainly_mixin `{!BiPlainly PROP} :
    modality_mixin (@plainly PROP _) (MIEnvForall Plain) MIEnvClear.
  Proof.
    split; simpl; split_and?; eauto using equiv_entails_1_2, plainly_intro,
      plainly_mono, plainly_and, plainly_sep_2 with typeclass_instances.
  Qed.
  Definition modality_plainly `{!BiPlainly PROP} :=
    Modality _ modality_plainly_mixin.

  Lemma modality_laterN_mixin n :
    modality_mixin (@bi_laterN PROP n)
      (MIEnvTransform (MaybeIntoLaterN false n)) (MIEnvTransform (MaybeIntoLaterN false n)).
  Proof.
    split; simpl; split_and?; eauto using equiv_entails_1_2, laterN_intro,
      laterN_mono, laterN_and, laterN_sep with typeclass_instances.
    rewrite /MaybeIntoLaterN=> P Q ->. by rewrite laterN_intuitionistically_2.
  Qed.
  Definition modality_laterN n :=
    Modality _ (modality_laterN_mixin n).
End modalities.


(** * Semantics by Head reductions in context *)

From Coq Require Import String Bool Datatypes Relations Program.Equality Classes.RelationClasses.
From Coq Require Import Logic.FunctionalExtensionality. (* for equality of substitutions *)

From SymEx Require Import Expr.
Import BasicExpr.

From SymEx Require Import Parallel.

From SymEx Require Import Traces.
Import TraceSemantics.

From SymEx Require Import Maps.
Import BasicMaps.

Open Scope com_scope.
Open Scope string_scope.
Open Scope trace_scope.

Ltac splits := repeat (try split).

(** Generalized context unfolding *)
(** idea from: https://xavierleroy.org/cdf-mech-sem/CDF.FUN.html *)
(** S is on the right because the associativity makes it simpler when X is a product type*)
Inductive context_red {X S:Type} (context: (S -> S) -> Prop) (head_red: relation (X * S)): relation (X * S) :=
| ctx_red_intro: forall C x x' s s',
    head_red (x, s) (x', s') -> context C ->
    context_red context head_red (x, C s) (x', C s').

Lemma under_C {X: Type} (r: relation (X * Stmt)): forall C s s' t t',
    context_red is_context r (t, s) (t', s') -> is_context C -> context_red is_context r (t, C s) (t', C s').
Proof.
  intros. dependent destruction H. apply ctx_red_intro with (C := fun s => C (C0 s)).
  - assumption.
  - apply context_comp; assumption.
Qed.

Lemma context_injective: forall C s s',
    is_context C -> C s = C s' -> s = s'.
Proof.
  intros. induction H;
    try (inversion H0; apply IHis_context);
    assumption.
Qed.

(** Symbolic Semantics *)
Inductive head_red__S: (trace__S * Stmt) -> (trace__S * Stmt) -> Prop :=
| head_red_asgn__S: forall t x e,
    head_red__S (t, <{ x := e }>) (t :: Asgn__S x e, SSkip)
| head_red_cond_true__S: forall t b s1 s2,
    head_red__S (t, <{ if b {s1} {s2} }>) (t :: Cond b, s1)
| head_red_cond_false__S: forall t b s1 s2,
    head_red__S (t, <{ if b {s1} {s2} }>) (t :: Cond (BNot b), s2)
| head_red_loop_true__S: forall t b s,
    head_red__S (t, <{ while b {s} }>) (t :: Cond b, <{s ; while b {s}}>)
| head_red_loop_false__S: forall t b s,
    head_red__S (t, <{ while b {s} }>) (t :: Cond (BNot b), SSkip)
(* I don't love these cases, they're a bit inelegant *)
| head_red_seq__S: forall s t,
    head_red__S (t, <{skip ; s}>) (t, s)
| head_red_par__S: forall t,
    head_red__S (t, <{skip || skip}>) (t, SSkip)
.

Definition red__S := context_red is_context head_red__S.
Definition red_star__S := clos_refl_trans_n1 _ red__S.

(** Concrete Semantics *)

Inductive head_red__C (V0:Valuation): (trace__C * Stmt) -> (trace__C * Stmt) -> Prop :=
| head_red_asgn__C: forall t x e,
    head_red__C V0 (t, <{ x := e }>) (t :: (x, e), SSkip)
| head_red_cond__C: forall t b s1 s2,
    head_red__C V0 (t, <{ if b {s1} {s2} }>) (t, if (Beval_t V0 t b) then s1 else s2)
| head_red_loop__C: forall t b s,
    head_red__C V0 (t, <{while b {s}}>) (t, if (Beval_t V0 t b) then <{s ; while b {s}}> else SSkip)
(* I don't love these cases, they're a bit inelegant *)
| head_red_skip_seq__C: forall s t,
    head_red__C V0 (t, <{skip ; s}>) (t, s)
| head_red_par__C: forall t,
    head_red__C V0 (t, <{skip || skip}>) (t, SSkip)
.

Definition red__C (V0:Valuation) := context_red is_context (head_red__C V0).
Definition red_star__C (V0:Valuation) := clos_refl_trans_n1 _ (red__C V0).

(** Properties *)
Lemma pc_monotone: forall V t x,
    Beval V (pc (t :: x)) = true -> Beval V (pc t) = true.
Proof. intros. destruct x; simpl in H; try (apply andb_true_iff in H; destruct H); assumption. Qed.

Lemma pc_monotone_step : forall V0 s1 s2 t1 t2,
    red__S (t1, s1) (t2, s2) -> Beval V0 (pc t2) = true -> Beval V0 (pc t1) = true.
Proof. intros. inversion H. inversion H4; subst;
         try (simpl in H0; assumption);
         try(eapply pc_monotone; apply H0).
Qed.

Lemma correctness_step : forall s s' t0 t t0' V0,
    red__S (t0, s) (t, s') ->
    Beval V0 (pc t) = true ->
    is_abstraction V0 t0' t0 ->
    exists t', red__C V0 (t0', s) (t', s') /\ acc_val V0 t' = Comp V0 (acc_subst id_sub t).
Proof.
  intros. destruct H1 as [_ H2]. symmetry in H2.
  dependent destruction H. dependent induction H;
    (* the skips*)
    try (exists t0'; splits; [constructor | assumption | assumption]).
  - eexists. splits.
    + apply head_red_asgn__C.
    + assumption.
    + unfold Aeval_t. simpl. rewrite asgn_sound. rewrite H2. reflexivity.
  - simpl in H1. apply andb_true_iff in H1. destruct H1.
    unfold Bapply_t in H. rewrite <- comp_subB in H. rewrite <- H2 in H.
    exists t0'. splits.
    (* there's got to be a better way to do this...*)
    + assert (head_red__C V0 (t0', <{ if b {s'0}{s2} }>) (t0', if Beval_t V0 t0' b then s'0 else s2)) by constructor.
      unfold Beval_t in H3. rewrite H in H3. apply H3.
    + assumption.
    + simpl. assumption.
  - simpl in H1. apply andb_true_iff in H1. destruct H1.
    apply negb_true_iff in H.
    unfold Bapply_t in H. rewrite <- comp_subB in H. rewrite <- H2 in H.
    exists t0'. splits.
    (* there's got to be a better way to do this...*)
    + assert (head_red__C V0 (t0', <{ if b {s1}{s'0} }>) (t0', if Beval_t V0 t0' b then s1 else s'0)) by constructor.
      unfold Beval_t in H3. rewrite H in H3. apply H3.
    + assumption.
    + simpl. assumption.
  - simpl in H1. apply andb_true_iff in H1. destruct H1.
    unfold Bapply_t in H. rewrite <- comp_subB in H. rewrite <- H2 in H.
    exists t0'. splits.
    (* there's got to be a better way to do this...*)
    + assert (head_red__C V0 (t0', <{ while b {s} }>) (t0', if Beval_t V0 t0' b then <{s ; while b {s}}> else SSkip)) by constructor.
      unfold Beval_t in H3. rewrite H in H3. apply H3.
    + assumption.
    + simpl. assumption.
  - simpl in H1. apply andb_true_iff in H1. destruct H1.
    apply negb_true_iff in H.
    unfold Bapply_t in H. rewrite <- comp_subB in H. rewrite <- H2 in H.
    exists t0'. splits.
    (* there's got to be a better way to do this...*)
    + assert (head_red__C V0 (t0', <{ while b {s} }>) (t0', if Beval_t V0 t0' b then <{s ; while b {s}}> else SSkip)) by constructor.
      unfold Beval_t in H3. rewrite H in H3. apply H3.
    + assumption.
    + simpl. assumption.
Qed.

Lemma completeness_step : forall s s' t0 t t0' V0,
    red__C V0 (t0, s) (t, s') ->
    is_abstraction V0 t0 t0' ->
    exists t', red__S (t0', s) (t', s')
          /\ is_abstraction V0 t t'.
Proof.
  intros. dependent destruction H. dependent induction H;
    destruct H1;
    (* the skips*)
    try (exists t0'; splits; [constructor | assumption | assumption | assumption]).
  - eexists. splits.
    + constructor.
    + assumption.
    + simpl. assumption.
    + unfold Aeval_t. simpl. rewrite asgn_sound. rewrite H1. reflexivity.
  - destruct (Beval_t V0 t b) eqn:Hbranch; unfold Beval_t in Hbranch.
    + eexists. splits.
      * apply head_red_cond_true__S.
      * assumption.
      * simpl. apply andb_true_iff. split.
        ** unfold Bapply_t. rewrite <- comp_subB. rewrite H1. assumption.
        ** assumption.
      * simpl. assumption.
    + eexists. splits.
      * apply head_red_cond_false__S.
      * assumption.
      * simpl. apply andb_true_iff. split.
        ** unfold Bapply_t. rewrite <- comp_subB. rewrite H1. apply negb_true_iff. assumption.
        ** assumption.
      * simpl. assumption.
  - destruct (Beval_t V0 t b) eqn:Hbranch; unfold Beval_t in Hbranch.
    + eexists. splits.
      * apply head_red_loop_true__S.
      * assumption.
      * simpl. apply andb_true_iff. split.
        ** unfold Bapply_t. rewrite <- comp_subB. rewrite H1. assumption.
        ** assumption.
      * simpl. assumption.
    + eexists. splits.
      * apply head_red_loop_false__S.
      * assumption.
      * simpl. apply andb_true_iff. split.
        ** unfold Bapply_t. rewrite <- comp_subB. rewrite H1. apply negb_true_iff. assumption.
        ** assumption.
      * simpl. assumption.
Qed.

Theorem bisimulation: forall V s s' t0 t0',
    is_abstraction V t0 t0' ->
    (forall t, red__C V (t0, s) (t, s') ->
          exists t', (red__S (t0', s) (t', s')) /\ is_abstraction V t t')
    /\ (forall t, red__S (t0', s) (t, s') /\ Beval V (pc t) = true ->
            (exists t', red__C V (t0, s) (t', s') /\ acc_val V t' = Comp V (acc_subst id_sub t))).
Proof.
  split.
  - intros. apply completeness_step with (t0 := t0); assumption.
  - intros. destruct H0. apply correctness_step with (t0 := t0'); assumption.
Qed.

Corollary correctness : forall s s' t0 t t0' V0,
    red_star__S (t0, s) (t, s') ->
    Beval V0 (pc t) = true ->
    is_abstraction V0 t0' t0 ->
    exists t', red_star__C V0 (t0', s) (t', s') /\ acc_val V0 t' = Comp V0 (acc_subst id_sub t).
Proof.
  intros. dependent induction H. destruct H1 as [_ H2]. symmetry in H2.
  - eexists. splits. apply rtn1_refl. assumption.
  - destruct y. remember (pc_monotone_step V0 _ _ _ _ H H1).
    edestruct IHclos_refl_trans_n1 as [t' [IHcomp IHabs]];
      try reflexivity; try assumption.
    destruct (bisimulation V0 s0 s' t' t1) as [_ bisim_correct].
    + split; [| symmetry]; assumption.
    + destruct (bisim_correct t) as [t_step [Hstep Habs_step]].
      * split; assumption.
      * eexists. splits.
        ** econstructor. apply Hstep. apply IHcomp.
        ** assumption.
Qed.

Corollary completeness : forall s s' t0 t t0' V0,
    red_star__C V0 (t0, s) (t, s') ->
    is_abstraction V0 t0 t0' ->
    exists t', red_star__S (t0', s) (t', s')
          /\ is_abstraction V0 t t'.
Proof.
  intros. dependent induction H.
  - eexists. splits; destruct H0; try (apply rtn1_refl); assumption.
  - destruct y. edestruct IHclos_refl_trans_n1 as [t' [IHcomp [IHpc IHabs]]];
      try reflexivity; try assumption.
    destruct (bisimulation V0 s0 s' t1 t') as [bisim_complete _].
    + split; assumption.
    + destruct (bisim_complete t) as [t_step [Hstep [Hpc Habs]]]; try assumption.
      eexists. splits.
      * econstructor. apply Hstep. apply IHcomp.
      * apply Hpc.
      * apply Habs.
Qed.


(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2020 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

Require Import Equations.Init Equations.CoreTactics.
From Coq Require Import Extraction Relation_Definitions.
Require Import Equations.Prop.Logic.

(** A class for well foundedness proofs.
   Instances can be derived automatically using [Derive Subterm for ind]. *)

Class WellFounded {A : Type} (R : relation A) :=
  wellfounded : well_founded R.

(** This class contains no-cyclicity proofs.
    They can be derived from well-foundedness proofs for example.
 *)

(** The proofs of [NoCycle] can be arbitrarily large, it doesn't
    actually matter in the sense that they are used to prove
    absurdity. *)

Class NoCyclePackage (A : Type) :=
  { NoCycle : A -> A -> Prop;
    noCycle : forall {a b}, NoCycle a b -> (a = b -> False) }.

(** These lemmas explains how to apply it during simplification. *)

(** We always generate a goal of the form [NoCycle x C[x]], using either
    the left or right versions of the following lemma. *)

Lemma apply_noCycle_left {A} {noconf : NoCyclePackage A}
      (p q : A) {B : p = q -> Type} :
  NoCycle p q -> (forall H : p = q, B H).
Proof.
  intros. destruct (noCycle H H0).
Defined.

Lemma apply_noCycle_right {A} {noconf : NoCyclePackage A}
      (p q : A) {B : p = q -> Type} :
  NoCycle q p -> (forall H : p = q, B H).
Proof.
  intros. destruct (noCycle H (eq_sym H0)).
Defined.
Extraction Inline apply_noCycle_left apply_noCycle_right.

(** The NoConfusionPackage class provides a method for solving injectivity and discrimination
    of constructors, represented by an equality on an inductive type [I]. The type of [noConfusion]
    should be of the form [ Π Δ, (x y : I Δ) (x = y) -> NoConfusion x y ], where
   [NoConfusion x y] for constructor-headed [x] and [y] will give equality of their arguments
   or the absurd proposition in case of conflict.
   This gives a general method for simplifying by discrimination or injectivity of constructors.

   Some actual instances are defined later in the file using the more primitive [discriminate] and
   [injection] tactics on which we can always fall back.
   *)

Class NoConfusionPackage (A : Type) := {
  NoConfusion : A -> A -> Prop;
  noConfusion : forall {a b}, NoConfusion a b -> a = b;
  noConfusion_inv : forall {a b}, a = b -> NoConfusion a b;
  noConfusion_sect : forall {a b} (e : NoConfusion a b), noConfusion_inv (noConfusion e) = e;
  noConfusion_retr : forall {a b} (e : a = b), noConfusion (noConfusion_inv e) = e;
}.

(** This lemma explains how to apply it during simplification. *)
Lemma apply_noConfusion {A} {noconf : NoConfusionPackage A}
      (p q : A) {B : p = q -> Type} :
  (forall H : NoConfusion p q, B (noConfusion H)) -> (forall H : p = q, B H).
Proof.
  intros. generalize (noConfusion_retr H).
  intros e. destruct e. apply X.
Defined.
Extraction Inline apply_noConfusion.

(** Classes for types with UIP or decidable equality.  *)

Class UIP (A : Type) := uip : forall {x y : A} (e e' : x = y), e = e'.

Definition dec_eq {A} (x y : A) := { x = y } + { x <> y }.

Class EqDec (A : Type) :=
  eq_dec : forall x y : A, { x = y } + { x <> y }.

Class EqDecPoint (A : Type) (x : A) :=
  eq_dec_point : forall y : A, { x = y } + { x <> y }.

#[export]
Instance EqDec_EqDecPoint A `(EqDec A) (x : A) : EqDecPoint A x := eq_dec x.

(** For treating impossible cases. Equations corresponding to impossible
   calls form instances of [ImpossibleCall (f args)]. *)

Class ImpossibleCall {A : Type} (a : A) : Type :=
  is_impossible_call : False.

(** We have a trivial elimination operator for impossible calls. *)

Definition elim_impossible_call {A} (a : A) {imp : ImpossibleCall a} (P : A -> Type) : P a :=
  match is_impossible_call with end.

(** The tactic tries to find a call of [f] and eliminate it. *)

Ltac impossible_call f := on_call f ltac:(fun t => apply (elim_impossible_call t)).

(** The [FunctionalInduction f] typeclass is meant to register functional induction
   principles associated to a function [f]. Such principles are automatically
   generated for definitions made using [Equations]. *)

Polymorphic
Class FunctionalInduction {A : Type} (f : A) :=
  { fun_ind_prf_ty : Type; fun_ind_prf : fun_ind_prf_ty }.

Register FunctionalInduction as equations.funind.class.

(** The [FunctionalElimination f] class declares elimination principles produced
   from the functional induction principle for [f] to be used directly to eliminate
   a call to [f]. This is the preferred method of proving results about a function.
   [n] is the number of binders for parameters, predicates and methods of the
   eliminator.
   *)

Polymorphic
Class FunctionalElimination {A : Type} (f : A) (fun_elim_ty : Type) (n : nat) :=
  fun_elim : fun_elim_ty.

Register FunctionalElimination as equations.funelim.class.


From Mtac2 Require Import Mtac2.
Import Mtac2.lib.List.ListNotations.

Example ex1 (x y: nat) (H: x>y) (z: nat) : True.
MProof.
  M.Cevar _ [m:ahyp H mNone | ahyp y mNone | ahyp x mNone].
  (* wrong order of variables *)
  Unshelve.
  Fail M.Cevar _ [m:ahyp x mNone| ahyp H mNone| ahyp y mNone].
  (* dup variable *)
  Fail M.Cevar _ [m:ahyp x mNone| ahyp x mNone| ahyp y mNone].
  M.Cevar _ [m:ahyp H mNone| ahyp y (mSome 0)| ahyp x mNone].
  Unshelve.
  T.exact I.
Qed.

Example ex2 : forall (x y: nat) (H: x>y) (z:nat), True.
MProof.
  cintros (x y: nat) (H: x>y) (z: nat) {-
    e <- M.Cevar _ [m:ahyp H mNone| ahyp y mNone| ahyp x mNone];
    T.exact e
  -}. (* misses z in the evar, but it still works, why? *)
  Unshelve.
  T.exact I.
Qed.

Example ex3 : forall (x y: nat) (H: x>y), True.
MProof.
  (* wrong order of variables *)
  Fail cintros (x y: nat) (H: x>y) {-
    e <- M.Cevar True [m:ahyp x mNone| ahyp H mNone| ahyp y mNone];
    T.exact e
  -}.
  (* dup variable *)
  Fail cintros (x y: nat) (H: x>y) {-
    e <- M.Cevar True [m:ahyp x mNone| ahyp x mNone| ahyp y mNone];
    T.exact e
  -}.
  cintros (x y: nat) (H: x>y) {-
    e <- M.Cevar _ [m:ahyp H mNone| ahyp y (mSome x)| ahyp x mNone];
    T.exact e
  -}.
  Unshelve.
    (* not a variable *)
  Fail M.Cevar _ [m:ahyp (x > y) mNone| ahyp y (mSome x)| ahyp x mNone].
  T.exact I.
Qed.


(** Register often used container types with helpful assumption and proof functions **)

Require Import helperGen.

Require Import MetaCoq.Template.All.

From MetaCoq.PCUIC Require Import
     PCUICAst PCUICAstUtils PCUICInduction
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

From MetaCoq.PCUIC Require Import PCUICToTemplate.
From MetaCoq.PCUIC Require Import TemplateToPCUIC.

Require Import List String.
Import ListNotations MonadNotation Nat.
Require Import MetaCoq.Template.Pretty.
Require Import MetaCoq.PCUIC.PCUICPretty.

From Equations Require Import Equations.
Require Import nested_datatypes.

Open Scope string_scope.

Print prod.
Print VectorDef.t.

(* list satisfy *)
Inductive is_list A (PA:A->Type) : list A -> Type :=
| is_nil : is_list A PA nil
| is_cons a (pa: PA a) l (pl:is_list A PA l): is_list A PA (a::l).

Definition listAssumption2 {X} (P:X->Type) (xs:list X) := is_list _ P xs.

Lemma is_list_in {X} (P:X->Prop) xs : is_list X P xs -> forall x, In x xs -> P x.
Proof.
  intros.
  induction X0.
  - now contradict H.
  - destruct H as [->|H].
    + apply pa.
    + apply IHX0, H.
Qed.

Definition listProof2 {X} (P:X->Type) (f:forall x, P x) (xs:list X) : listAssumption2 P xs.
Proof.
  unfold listAssumption2.
  induction xs.
  - constructor.
  - constructor.
    + apply f.
    + apply IHxs.
Defined.

Fixpoint F (n : nat) : nat := (fun _=> O)(F n).
Compute (F 2).

Definition prodAssumption X (Px:X->Type) Y (Py:Y->Type) (t:X*Y) : Type := let (x,y) := t in (Px x) * (Py y).
Definition prodProof X (Px:X->Type) (fx:forall x, Px x) Y (Py:Y->Type) (fy:forall y, Py y) (t:X*Y) : prodAssumption _ Px _ Py t.
Proof.
  destruct t.
  cbn. split;[apply fx | apply fy].
Defined.

Compute (forall T p pd t,prodAssumption T p nat pd t).

Definition listAssumption {X} (P:X->Prop) (xs:list X) := forall t, In t xs -> P t.

Definition listProof {X} (P:X->Prop) (f:forall x, P x) (xs:list X) : listAssumption P xs :=
(list_ind (fun xs0 : list X => listAssumption P xs0)
            (fun (t : X) (H0 : In t []) => match H0 return (P t) with
                                                  end)
            (fun (a : X) (xs0 : list X) (IHxs : listAssumption P xs0)
               (t : X) (H0 : In t (a :: xs0)) =>
             match H0 with
             | or_introl H1 => Coq.Init.Logic.eq_ind a (fun t0 : X => P t0) (f a) t H1
             | or_intror H1 => IHxs t H1
             end) xs).

(* invalid f only for smaller instances *)
(* Goal forall X (P:X->Prop) (f:forall x, P x) (xs:list X) , listAssumption P xs. *)
(* Proof. *)
(*   unfold listAssumption. *)
(*   intros. *)
(*   apply f. *)
(* Qed. *)

Inductive is_prod X Y (Px : X->Type) (Py: Y -> Type) : X*Y->Type :=
| is_pair x y (px:Px x) (py:Py y) : is_prod X Y Px Py (x,y).
Definition prodProof2 {X Y} (Px:X->Type) (Py:Y->Type) (fx:forall x, Px x) (fy:forall y, Py y) (t:X*Y) : is_prod _ _ Px Py t.
Proof.
  destruct t.
  cbn. split;[apply fx | apply fy].
Defined.

Definition vec:=Vector.t.

Inductive is_vec {X:Type} (Px: X->Type) : forall n, vec X n -> Type :=
| is_nilV : is_vec Px 0 (@Vector.nil _)
| is_consV (x:X) (px:Px x) n (xs:Vector.t X n) (pxs:is_vec Px n xs): is_vec Px (S n) (Vector.cons X x n xs).

Definition vecProof {X} (P:X->Type) (f:forall x, P x) n (xs:vec X n) : is_vec P n xs.
Proof.
  induction xs.
  - constructor.
  - constructor.
    + apply f.
    + apply IHxs.
Defined.

Definition rtree_ind_MC_Test
     : forall (A : Type) (p : rtree A -> Type),
       (forall a : A, p (Leaf A a)) ->
       (forall l : list (rtree A), is_list (rtree A) p l -> p (Node A l)) -> forall inst : rtree A, p inst :=
fun (A : Type) (p : rtree A -> Type) (H_Leaf : forall a : A, p (Leaf A a))
  (H_Node : forall l : list (rtree A), is_list (rtree A) p l -> p (Node A l)) =>
fix f (inst : rtree A) : p inst :=
  match inst as inst0 return (p inst0) with
  | @Leaf _ a => H_Leaf a
  | @Node _ l =>
      H_Node l
        ((fix F (l0 : list (rtree A)) : is_list (rtree A) p l0 :=
            match l0 as l1 return (is_list (rtree A) p l1) with
            | [] => is_nil (rtree A) p
            | y :: l1 => is_cons (rtree A) p y (f y) l1 (F l1)
            end) l)
  end.

Inductive is_rtree X (Px : X -> Type) : rtree X -> Type :=
| is_Leaf x (px: Px x) : is_rtree X Px (Leaf X x)
| is_Node xs (pxs: is_list (rtree X) (is_rtree X Px) xs) : is_rtree X Px (Node X xs).

Definition rtreeProof2 X (P:X->Type) (f:forall x, P x) (r:rtree X) : is_rtree X P r.
Proof.
  revert r.
  refine (fix IH r := _).
  destruct r.
  - constructor. apply f.
  - constructor.
    apply listProof2.
    apply IH.
Defined.

Definition rtreeProof X (P:X->Type) (f:forall x, P x) (r:rtree X) : is_rtree X P r.
Proof.
  induction r using rtree_ind_MC_Test.
  - constructor. apply f.
  - constructor. apply X0.
Defined.

Definition roseTreeO3_ind_MC :=
fun (X : Type) (p : roseTreeO3 X -> Prop)
  (H_treeO3 : forall (x : X) (xs : list X)
                (xxs : roseTreeO3 X),
              p xxs ->
              forall xsxs : list (roseTreeO3 X),
              is_list (roseTreeO3 X)
                (fun H : roseTreeO3 X => p H) xsxs ->
              p (treeO3 X x xs xxs xsxs)) =>
fix f (inst : roseTreeO3 X) : p inst :=
  match inst as inst0 return (p inst0) with
  | @treeO3 _ x xs xxs xsxs =>
      H_treeO3 x xs xxs (f xxs) xsxs
        ((fix F (l : list (roseTreeO3 X)) :
            is_list (roseTreeO3 X)
              (fun H : roseTreeO3 X => p H) l :=
            match
              l as l0
              return
                (is_list (roseTreeO3 X)
                   (fun H : roseTreeO3 X => p H) l0)
            with
            | [] =>
                is_nil (roseTreeO3 X)
                  (fun H : roseTreeO3 X => p H)
            | y :: l0 =>
                is_cons (roseTreeO3 X)
                  (fun H : roseTreeO3 X => p H) y
                  (f y) l0 (F l0)
            end) xsxs)
  end.

Inductive listᵗ (A : Type) (Aᵗ : A -> Type) : list A -> Type :=
    nilᵗ : listᵗ A Aᵗ [] | consᵗ : forall H : A, Aᵗ H -> forall H0 : list A, listᵗ A Aᵗ H0 -> listᵗ A Aᵗ (H :: H0).

Inductive roseTreeO3ᵗ (X : Type) (Xᵗ : X -> Type) : roseTreeO3 X -> Prop :=
    treeO3ᵗ : forall x : X,
               Xᵗ x ->
               forall xs : list X,
               is_list X Xᵗ xs ->
               forall xxs : roseTreeO3 X,
               roseTreeO3ᵗ X Xᵗ xxs ->
               forall xsxs : list (roseTreeO3 X),
               is_list (roseTreeO3 X) (roseTreeO3ᵗ X Xᵗ) xsxs ->
               roseTreeO3ᵗ X Xᵗ (treeO3 X x xs xxs xsxs).

Definition rtreeO3Proof X (P:X->Type) (f:forall x, P x) (r:roseTreeO3 X) : roseTreeO3ᵗ X P r.
Proof.
  induction r using roseTreeO3_ind_MC.
  - constructor.
    + apply f.
    + apply listProof2.
      apply f.
    + apply IHr.
    + apply X0. (* alternative: listProof2 & IH explizit with fix *)
Restart.
  revert r.
  refine (fix IH r := _).
  destruct r.
  - constructor.
    + apply f.
    + apply listProof2.
      apply f.
    + apply IH.
    + apply listProof2.
      apply IH.
Qed.

Inductive Accᵗ (A : Type) (Aᵗ : A -> Type) (R : A -> A -> Prop)
(Rᵗ : forall H : A,
      Aᵗ H -> forall H0 : A, Aᵗ H0 -> R H H0 -> Prop)
(x : A) (xᵗ : Aᵗ x) : Acc R x -> Prop :=
    Acc_introᵗ : forall
                   H : forall y : A, R y x -> Acc R y,
                 (forall (y : A) (yᵗ : Aᵗ y)
                    (H0 : R y x),
                  Rᵗ y yᵗ x xᵗ H0 ->
                  Accᵗ A Aᵗ R Rᵗ y yᵗ (H y H0)) ->
                 Accᵗ A Aᵗ R Rᵗ x xᵗ (Acc_intro x H).

Definition AccProof (A : Type) (Aᵗ : A -> Type) (R : A -> A -> Prop)
(Rᵗ : forall H : A,
      Aᵗ H -> forall H0 : A, Aᵗ H0 -> R H H0 -> Prop)
(x : A) (xᵗ : Aᵗ x) (r : Acc R x) : Accᵗ A Aᵗ R Rᵗ x xᵗ r.
Proof.
  intros.
  revert x xᵗ r.
  refine (fix IH x xᵗ r := _).
  destruct r.
  constructor.
  intros.
  apply IH.
Defined.

Inductive boolᵗ : bool -> Set :=
  trueᵗ : boolᵗ true | falseᵗ : boolᵗ false.
Inductive natᵗ : nat -> Set :=
    Oᵗ : natᵗ 0
  | Sᵗ : forall H : nat, natᵗ H -> natᵗ (S H).

Inductive
containerInd4ᵗ (b : bool) (bᵗ : boolᵗ b)
(X : Type) (Xᵗ : X -> Type) (n : nat)
(nᵗ : natᵗ n)
  : containerInd4 b X n -> Prop :=
  c4ᵗ : containerInd4ᵗ b bᵗ X Xᵗ n nᵗ (c4 b X n).

Definition containerInd4Proof (b : bool) (bᵗ : boolᵗ b)
(X : Type) (Xᵗ : X -> Type) (n : nat)
(nᵗ : natᵗ n) (a:containerInd4 b X n) :
  containerInd4ᵗ b bᵗ X Xᵗ n nᵗ a.
Proof.
  destruct a.
  constructor.
Defined.

Inductive
vecᵗ (A : Type) (Aᵗ : A -> Type)
  : forall H : nat, natᵗ H -> vec A H -> Type :=
    vecnilᵗ : vecᵗ A Aᵗ 0 Oᵗ (@Vector.nil A)
  | vecconsᵗ : forall H : A,
               Aᵗ H ->
               forall (n : nat) (nᵗ : natᵗ n)
                 (H0 : vec A n),
               vecᵗ A Aᵗ n nᵗ H0 ->
               vecᵗ A Aᵗ (S n) (Sᵗ n nᵗ)
                    (@Vector.cons A H n H0).

Definition vecProof2
           (A : Type) (Aᵗ : A -> Type) (fA: forall a, Aᵗ a)
           (n : nat) (H:natᵗ n) (fn: forall n, natᵗ n)
           (a:vec A n) :
  vecᵗ A Aᵗ n H a.
Proof.
  induction a in H, fn |- *.
  - depelim H.
    constructor.
  - depelim H.
    constructor.
    + apply fA.
    + apply IHa.
      apply fn.
Qed.

Inductive
vecᵗ' (A : Type) (Aᵗ : A -> Type)
  : forall H : nat, vec A H -> Type :=
    vecnilᵗ' : vecᵗ' A Aᵗ 0 (@Vector.nil A)
  | vecconsᵗ' : forall H : A,
               Aᵗ H ->
               forall (n : nat)
               (* (nᵗ : natᵗ n) *)
                 (H0 : vec A n),
               vecᵗ' A Aᵗ n H0 ->
               vecᵗ' A Aᵗ (S n)
                    (@Vector.cons A H n H0).

Definition vecProof2'
           (A : Type) (Aᵗ : A -> Type) (fA: forall a, Aᵗ a)
           (n : nat)
           (* (fn: forall n, natᵗ n) *)
           (a:vec A n) :
  vecᵗ' A Aᵗ n a.
Proof.
  induction a.
  - constructor.
  - constructor.
    + apply fA.
    + apply IHa.
Qed.

Print mfixpoint.
Check list.

Print def.

Definition defAssumption {X} (P:X->Type) (x:def X) :=
  prod
    (P (dtype x))
    (P (dbody x)).
Definition defProof {X} (P:X->Type) (f:forall x, P x) (x:def X) : defAssumption P x.
  now constructor.
Defined.

Definition mfixpointAssumption {X} (P:X->Type) (x:mfixpoint X) := is_list _ (defAssumption P) x.
Definition mfixpointProof {X} (P:X->Type) (f:forall x, P x) (x:mfixpoint X) : mfixpointAssumption P x.
  now apply listProof2, defProof.
Defined.

Print All_Forall.All.
Print is_list.
Print listProof2.

Instance listInst : registered list :=
{|
    assumption := @listAssumption2;
    proof := @listProof2
|}.

Instance prodInst : registered prod :=
{|
    assumption := @prodAssumption;
    proof := @prodProof
|}.

Instance vecInst : registered VectorDef.t :=
{|
    assumption := @is_vec;
    proof := @vecProof
|}.

Instance rtreeInst : registered rtree :=
{|
    assumption := @is_rtree;
    proof := @rtreeProof
|}.

Instance containerInd4Inst : registered containerInd4 :=
{|
    assumption := @containerInd4ᵗ;
    proof := @containerInd4Proof
|}.

Instance defInst : registered def :=
{|
    assumption := @defAssumption;
    proof := @defProof
|}.

Instance mfixpointInst : registered mfixpoint :=
{|
    assumption := @mfixpointAssumption;
    proof := @mfixpointProof
|}.


(** An effect is a type of command and a dependent type of answer. *)
Record t := New {
  command : Type;
  answer : command -> Type }.

(** The composition of two effects. *)
Definition compose (E1 E2 : t) : t :=
  New (command E1 + command E2) (fun c =>
    match c with
    | inl c1 => answer E1 c1
    | inr c2 => answer E2 c2
    end).


#[global]
Set Primitive Projections.
#[global]
Unset Printing Primitive Projection Parameters.

#[global]
Set Universe Polymorphism.

#[global]
Set Default Goal Selector "!".

Require Import Coq.Unicode.Utf8.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.
Require Psatz.
Require Import Recdef.

Import IfNotations.
Import ListNotations.

Close Scope nat.

Definition valof {C} (P: C → bool) y := {
  val: C | Is_true (implb (P val) y) }.

#[program]
Definition app {C} (P: C → bool) (x: valof P false): valof P true := x.

Next Obligation.
Proof.
  destruct (P (proj1_sig x)).
  - cbn.
    apply I.
  - cbn.
    apply I.
Defined.

Record fiber {C} (P: C → bool) y := {
  tag: valof P true ;
  field: { x: valof P false | proj1_sig (app P x) = proj1_sig tag } → y ;
}.

Arguments tag {C P y}.
Arguments field {C P y}.

Record Poly := {
  pos: Type ;
  dir: pos → bool ;
}.

Definition X := {| dir (_: unit) := false |}.

Definition K A := {| dir (_: A) := true |}.

Definition sum (P Q: Poly) :=
  {|
  dir (x: pos P + pos Q) :=
    match x with
    | inl x' => dir P x'
    | inr x' => dir Q x'
    end ;
  |}.

Definition K_in {A B} (x: A): fiber (dir (K A)) B.
Proof.
  cbn.
  eexists (exist _ x _).
  Unshelve.
  2: {
    cbn.
    apply I.
  }
  intros [[?] ?].
  cbn in *.
  contradiction.
Defined.

Definition K_out {A B}: fiber (dir (K A)) B → A.
Proof.
  intros [a ?].
  cbn in *.
  apply a.
Defined.

Definition X_in {A} (x: A): fiber (dir X) A.
Proof.
  cbn.
  eexists (exist _ tt _).
  Unshelve.
  2: {
    cbn.
    apply I.
  }
  intro.
  apply x.
Defined.

Definition X_out {A}: fiber (dir X) A → A.
Proof.
  intros [? p].
  cbn in *.
  apply p.
  eexists (exist _ tt _).
  Unshelve.
  2: {
    cbn.
    apply I.
  }
  cbn.
  destruct tag0.
  cbn.
  destruct x.
  reflexivity.
Defined.

Definition inl_intro {A B C}: fiber (dir A) C → fiber (dir (sum A B)) C.
Proof.
  intros [[a j] p].
  cbn in *.
  exists (exist _ (inl a) j).
  cbn.
  intros [[? ?] ?].
  cbn in *.
  subst.
  apply p.
  eexists.
  Unshelve.
  2: {
    exists a.
    apply i.
  }
  cbn.
  reflexivity.
Defined.

Definition inr_intro {A B C}: fiber (dir B) C → fiber (dir (sum A B)) C.
Proof.
  intros [[b j] p].
  cbn in *.
  exists (exist _ (inr b) j).
  cbn.
  intros [[? ?] ?].
  cbn in *.
  subst.
  apply p.
  eexists.
  Unshelve.
  2: {
    exists b.
    apply i.
  }
  cbn.
  reflexivity.
Defined.

Definition sum_out {A B C}: fiber (dir (sum A B)) C → fiber (dir A) C + fiber (dir B) C.
Proof.
  intros [[[a|b] i] p].
  all: cbn in *.
  - left.
    exists (exist _ a i).
    intros [[? j] ?].
    cbn in *.
    subst.
    apply p.
    exists (exist _ (inl a) j).
    cbn.
    reflexivity.
  - right.
    exists (exist _ b i).
    intros [[? j] ?].
    cbn in *.
    subst.
    apply p.
    exists (exist _ (inr b) j).
    cbn.
    reflexivity.
Defined.

(* How bizarre it's a kind of pullback *)
Definition prod (P Q: Poly) :=
  {|
  dir (x: pos P * pos Q) := eqb (dir P (fst x)) (dir Q (snd x)) ;
  |}.

Definition prod_intro {A B C}: fiber (dir A) C → fiber (dir B) C → fiber (dir (prod A B)) C.
Proof.
  intros [[a j] p] [[b k] q].
  eexists (exist _ (a, b) _).
  Unshelve.
  2: {
    cbn in *.
    destruct (dir A a) eqn:r, (dir B b) eqn:s.
    all: cbn in *.
    all: apply I.
  }
  intros [[[? ?] ?] ?].
  cbn in *.
  inversion e.
  subst.
  destruct (dir A a) eqn:r, (dir B b) eqn:s.
  all: cbn in *.
  - contradiction.
  - apply q.
    eexists (exist _ b _).
    Unshelve.
    2: {
      cbn.
      rewrite s.
      cbn.
      apply I.
    }
    cbn.
    reflexivity.
  - apply p.
    eexists (exist _ a _).
    Unshelve.
    2: {
      cbn.
      rewrite r.
      cbn.
      apply I.
    }
    cbn.
    reflexivity.
  - contradiction.
Defined.