Require Import Chart.Semantics.Config.

(**
  This is the idealized version of the machine semantics that
  corresponds closely to the (currently closed-source) Haskell
  implementation. When a step is taken, requires the child agrees with
  [initial] and [terminal].

  A few notes: In the tool (QFramework), we basically synthesize the
  nesting by assuming you have the maximally disjunctive nesting. You
  can also give the inner machine's behavior explicitly.

  - [Record Machine] has the following:

    + initial states

    + terminal states

    + machine step.

    + inner state: if something going on in the nested state, restrict
      it. We don't model skip steps anywhere here, but instead at the
      top level.

  - S is a State. What part of the data is observable is not described
    here. The S is a "flat" notion of configuration, the name
    for the flat machine.

  - E is the collection of Environment variables (model variables); both
    those in the parent and in the child. E are not observables, since E
    are not labeled. Since it is not observed, we do not care about the
    trace preservation property. Env is externally shared, and so has
    a meaningful refinement proof about it. Env contains lots of other
    data.

  - [chart_step]. Chart is the statechart, [(Config * E)] is where you
    currently are. Think of Config as a "fancy" (read: nested) version
    of S.

    + [CS_Unit] is the chaos chart (can do anything).

    + [CS_Par] both child charts take child steps, and update the
      configurations accordingly. [P] is the parallel config. Note that
      this step is synchronous, since both take a step at once. The TLA
      notion of refinement requires invariance under an arbitrary number
      of stutter steps, and so this may cause concern here.
      There is no notion of fairness if you require some asynchronicity.
      Which is to say, if you add asynchronicity by adding either the
      left or right transition with a self-transition (stutter) step,
      there is no notion of fairness.

    + [CS_Nest_outer] move from state x to x'. To get out of x, you have
      to be in a terminal state in the nested chart x, (it's OK to leave
      x.) To move into x', you have to be in an initial step in x'.

    + [CS_Nest_inner]. For a particular state x, we require for any
      transition: if the child of x can make the transition, then then
      x can make the transition too.

*)

Module ConfigEnvSemantics (Cfg : ConfigType).
  Import Cfg.

  Record Machine :=
    { machine_initial : (S * E) -> Prop;
      machine_terminal : (S * E) -> Prop;
      machine_inner : S -> E -> E -> Prop;
      machine_step : (S * E) -> (S * E) -> Prop
    }.

  Inductive Chart :=
  | Unit : Chart
  | Par : Chart -> Chart -> Chart
  | Nest : Machine -> (S -> Chart) -> Chart.

  Inductive chart_config : Chart -> Config -> Prop :=
  | CC_Unit : chart_config Unit U
  | CC_Par : forall chl chr sl sr,
      chart_config chl sl ->
      chart_config chr sr ->
      chart_config (Par chl chr) (P sl sr)
  | CC_Nest : forall x m cs s,
      chart_config (cs x) s ->
      chart_config (Nest m cs) (N x s).

  Inductive chart_initial : Chart -> (Config * E) -> Prop :=
  | CI_Unit : forall env,
      chart_initial Unit (U, env)
  | CI_Par : forall ch1 cfg1 ch2 cfg2 env,
      chart_initial ch1 (cfg1, env) ->
      chart_initial ch2 (cfg2, env) ->
      chart_initial (Par ch1 ch2) (P cfg1 cfg2, env)
  | CI_Nest : forall m cs x cfg env,
      machine_initial m (x, env) ->
      chart_initial (cs x) (cfg, env) ->
      chart_initial (Nest m cs) (N x cfg, env).

  Inductive chart_terminal : Chart -> (Config * E) -> Prop :=
  | CT_Unit : forall env,
      chart_terminal Unit (U, env)
  | CT_Par : forall ch1 cfg1 ch2 cfg2 env,
      chart_terminal ch1 (cfg1, env) ->
      chart_terminal ch2 (cfg2, env) ->
      chart_terminal (Par ch1 ch2) (P cfg1 cfg2, env)
  | CT_Nest : forall m x cs cfg env,
      machine_terminal m (x, env) ->
      chart_terminal (cs x) (cfg, env) ->
      chart_terminal (Nest m cs) (N x cfg, env).

  Inductive chart_step : Chart -> (Config * E) -> (Config * E) -> Prop :=
  | CS_Unit : forall env env',
      chart_step Unit (U, env) (U, env')
  | CS_Par : forall ch1 cfg1 cfg1' ch2 cfg2 cfg2' env env',
      chart_step ch1 (cfg1, env) (cfg1', env') ->
      chart_step ch2 (cfg2, env) (cfg2', env') ->
      chart_step (Par ch1 ch2) (P cfg1 cfg2, env) (P cfg1' cfg2', env')
  | CS_Nest_outer : forall m cs x cfg env x' cfg' env',
      machine_step m (x, env) (x', env') ->
      chart_terminal (cs x) (cfg, env) ->
      chart_initial (cs x') (cfg', env') ->
      chart_step (Nest m cs) (N x cfg, env) (N x' cfg', env')
  | CS_Nest_inner : forall m cs x cfg env cfg' env',
      machine_inner m x env env' ->
      chart_step (cs x) (cfg, env) (cfg', env') ->
      chart_step (Nest m cs) (N x cfg, env) (N x cfg', env').

  Inductive chart_refines : Chart -> Chart -> Prop :=
  | CR_Unit : forall ch, chart_refines Unit ch
  | CR_Par : forall chl1 chr1 chl2 chr2,
      chart_refines chl1 chl2 ->
      chart_refines chr1 chr2 ->
      chart_refines (Par chl1 chr1) (Par chl2 chr2)
  | CR_Nest : forall m cs1 cs2,
      (forall x, chart_refines (cs1 x) (cs2 x)) ->
      chart_refines (Nest m cs1) (Nest m cs2).

    Lemma chart_initial_config :
    forall ch cfg env, chart_initial ch (cfg,env) -> chart_config ch cfg.
  Proof.
    intros ch cfg env.
    generalize dependent cfg.
    induction ch; intros cfg Hi; inversion Hi; subst; clear Hi; constructor.
    apply IHch1; assumption.
    apply IHch2; assumption.
    apply H; assumption.
  Qed.

  Lemma chart_terminal_config :
    forall ch cfg env, chart_terminal ch (cfg,env) -> chart_config ch cfg.
  Proof.
    intros ch cfg env.
    generalize dependent cfg.
    induction ch; intros cfg Ht; inversion Ht; subst; clear Ht; constructor.
    apply IHch1; assumption.
    apply IHch2; assumption.
    apply H; assumption.
  Qed.

  Lemma chart_step_config :
    forall ch cfg1 env1 cfg2 env2,
      chart_step ch (cfg1,env1) (cfg2,env2) -> chart_config ch cfg1 /\ chart_config ch cfg2.
  Proof.
    intros ch cfg1 env1 cfg2 env2 Ht.
    split;
      generalize dependent cfg2;
      generalize dependent cfg1;
      induction ch; intros cfg1 cfg2 Ht;
        inversion Ht; subst; clear Ht; constructor.
    specialize (IHch1 _ _ H2); assumption.
    specialize (IHch2 _ _ H6); assumption.
    apply chart_terminal_config with env1; assumption.
    specialize (H _ _ _ H7); assumption.
    specialize (IHch1 _ _ H2); assumption.
    specialize (IHch2 _ _ H6); assumption.
    apply chart_initial_config with env2; assumption.
    specialize (H _ _ _ H7); assumption.
  Qed.
End ConfigEnvSemantics.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main Functor.Representable.Hom_Func.
Require Import Basic_Cons.Terminal.
Require Import Ext_Cons.Arrow.
Require Import Coq_Cats.Type_Cat.Card_Restriction.
Require Import Limits.Limit.
Require Import KanExt.Pointwise.
Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import NatTrans.Main.
Require Import Cat.Cat_Terminal.
Require Import Functor.Representable.Representable.

Local Open Scope functor_scope.

Local Notation NID := NatTrans_id (only parsing).
Local Notation FCAT := Func_Cat (only parsing).

(** Limits – as local kan extensions – are pointwise. *)
Section Rep_Preserve_Limits.
  Context {J C : Category} (D : J –≻ C) (x : C).

  Local Notation REPx := (@Fix_Bi_Func_1 (C^op) _ _ x (Hom_Func C)) (only parsing).

  Local Notation REPxComp U := (REPx ∘ U)%functor (only parsing).

  Section Rep_Preserve_Limits_Cone_Cov.
    Context (Cn : Cone D).

    Definition Rep_Preserve_Limits_Cone_Cov : Cone (REPxComp D) :=
      {|
        cone_apex := (REPxComp Cn);
        cone_edge := (((NID REPx) ∘_h (cone_edge Cn)) ∘ (NatTrans_Functor_assoc _ _ _))%nattrans
      |}.

  End Rep_Preserve_Limits_Cone_Cov.

  Local Notation LPCC := Rep_Preserve_Limits_Cone_Cov.

  Section Rep_Preserve_Limits_Cone_Cov_Back.
    Context (Cn : Cone (REPxComp D)) (w : (Cn _o tt)%object).

    Program Definition Rep_Preserve_Limits_Cone_Cov_Back : Cone D :=
      {|
        cone_apex := Const_Func Discr.SingletonCat x;
        cone_edge :=  {|Trans := fun c => Trans (cone_edge Cn) c w |}
      |}.

    Next Obligation.
    Proof.
      set (W := equal_f (@Trans_com _ _ _ _ Cn c c' h) w); cbn in W; rewrite From_Term_Cat in W.
      auto.
    Qed.

    Next Obligation.
    Proof.
      symmetry.
      apply Rep_Preserve_Limits_Cone_Cov_Back_obligation_1.
    Qed.

  End Rep_Preserve_Limits_Cone_Cov_Back.

  Local Notation LPCCB := Rep_Preserve_Limits_Cone_Cov_Back.

  Section Rep_Preserve_Limits_Cone_Morph_Cov.
    Context {Cn Cn' : Cone D} (h : Cone_Morph D Cn Cn').

    Program Definition Rep_Preserve_Limits_Cone_Morph_Cov :
      Cone_Morph (REPxComp D) (LPCC Cn) (LPCC Cn') :=
      {|
        cone_morph := ((NID REPx) ∘_h (cone_morph h))%nattrans
      |}.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify; extensionality f; extensionality y.
      cbn in *.
      cbn_rewrite (
          f_equal
            (fun w : ((Cn ∘ (Functor_To_1_Cat J)) –≻ D)%nattrans => Trans w f)
            (cone_morph_com h)
        ).
      auto.
    Qed.

  End Rep_Preserve_Limits_Cone_Morph_Cov.

  Local Notation LPCHC := Rep_Preserve_Limits_Cone_Morph_Cov.

  Context (L : Limit D).

  Section Rep_Preserve_Limits_Cone_Morph_to_LPCC_Limit.
    Context (Cn : Cone (REPxComp D)).

    Program Definition Rep_Preserve_Limits_Cone_Morph_to_LPCC_Limit
      : Cone_Morph (REPxComp D) Cn (LPCC L) :=
      {|
        cone_morph :=
          {|
            Trans :=
              fun c w =>
                match c as u return (Cn _o u)%object → (x –≻ (L _o u))%object%morphism with
                  tt => fun w => Trans (LRKE_morph_ex L (LPCCB Cn w)) tt
                end w
          |}
      |}.

    Next Obligation.
    Proof.
      extensionality z.
      destruct c.
      destruct c'.
      destruct h.
      repeat rewrite From_Term_Cat; auto.
    Qed.

    Next Obligation.
    Proof.
      symmetry.
      apply Rep_Preserve_Limits_Cone_Morph_to_LPCC_Limit_obligation_1.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify; extensionality c; extensionality w.
      set (W :=
             f_equal
               (fun m : (((LPCCB Cn w) ∘ (Functor_To_1_Cat J)) –≻ D)%nattrans => Trans m c)
               (cone_morph_com (LRKE_morph_ex L (LPCCB Cn w)))
          ).
      cbn in *.
      auto.
    Qed.

  End Rep_Preserve_Limits_Cone_Morph_to_LPCC_Limit.

  Local Notation LPCMTL := Rep_Preserve_Limits_Cone_Morph_to_LPCC_Limit.

  Section Rep_Preserve_Limits_Cone_Morph_to_LPCC_Limit_TO_Cone_Morph_to_Limit.
    Context {Cn : Cone (REPxComp D)}
            (h : Cone_Morph (REPxComp D) Cn (LPCC L))
            (w : (Cn _o tt)%object)
    .

    Program Definition Rep_Preserve_Limits_Cone_Morph_to_LPCC_Limit_TO_Cone_Morph_to_Limit
      : Cone_Morph D (LPCCB Cn w) L :=
      {|
        cone_morph :=
          {|
            Trans :=
              fun c =>
                match c as u return (x –≻ (L _o u))%object%morphism with
                  tt => Trans h tt w
                end
          |}
      |}.

    Next Obligation.
    Proof.
      destruct c; destruct c'.
      repeat rewrite From_Term_Cat; auto.
    Qed.

    Next Obligation.
    Proof.
      symmetry.
      apply Rep_Preserve_Limits_Cone_Morph_to_LPCC_Limit_TO_Cone_Morph_to_Limit_obligation_1.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify; extensionality c.
      set (W :=
             f_equal
               (fun m : ((Cn ∘ (Functor_To_1_Cat J)) –≻ (REPxComp D))%nattrans => Trans m c w)
               (cone_morph_com h)
          ).
      cbn in *.
      auto.
    Qed.

  End Rep_Preserve_Limits_Cone_Morph_to_LPCC_Limit_TO_Cone_Morph_to_Limit.

  Local Notation LPCMTLTL := Rep_Preserve_Limits_Cone_Morph_to_LPCC_Limit_TO_Cone_Morph_to_Limit.

  Program Definition Rep_Preserve_Limits : Limit (REPxComp D) :=
    {|
      LRKE := LPCC L;
      LRKE_morph_ex := fun Cn => LPCMTL Cn
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality z; extensionality w; destruct z; cbn in *.
    apply
      (
        f_equal
          (fun m :  ((LPCCB Cn w) –≻ L)%nattrans => Trans m tt)
          (LRKE_morph_unique L _ (LPCMTLTL h w)(LPCMTLTL h' w))
      ).
  Qed.

End Rep_Preserve_Limits.

Section Limits_Pointwise.
  Context {J C : Category} {D : J –≻ C} (L : Limit D).

  Definition Limits_Pointwise : Pointwise_LRKE L :=
    fun G GR =>
      (
        Iso_Local_Right_KanExt
          ((representation_Iso GR)⁻¹ ∘_h (NatTrans_id_Iso L))%natiso
          (
            Local_Right_KanExt_is_Local_Right_KanExt
              (Functor_To_1_Cat J)
              (Functor_compose D G)
              (
                @Local_Right_KanExt_Iso
                  _
                  _
                  (Functor_To_1_Cat J)
                  _
                  _
                  _
                  ((representation_Iso GR) ∘_h (NatTrans_id_Iso D))%natiso
                  (Rep_Preserve_Limits D (representer GR) L)
              )
          )
      ).

End Limits_Pointwise.

Section CoLimits_Pointwise.
  Context {J C : Category} {D : J –≻ C} (L : CoLimit D).

  Definition CoLimits_Pointwise : Pointwise_LRKE L := fun G GR => Limits_Pointwise L G GR.

End CoLimits_Pointwise.


Require Import Kami.AllNotations FpuKami.Definitions.

Section Definitions.
  Open Scope nat.
  Variable intWidthMinus2 expWidthMinus2 sigWidthMinus2: nat.
  Local Notation intWidthMinus1  := (intWidthMinus2 + 1).
  Local Notation intWidth := (intWidthMinus1 + 1).
  Local Notation expWidthMinus1 := (expWidthMinus2 + 1).
  Local Notation expWidth := (expWidthMinus1 + 1).
  Local Notation sigWidthMinus1 := (sigWidthMinus2 + 1).
  Local Notation sigWidth := (sigWidthMinus1 + 1).
  Variable expWidth_prop: expWidthMinus2 >= 2.
  Variable expWidthMinus2_plus4_gt_sigWidth: 2 ^ expWidthMinus2 + 4 > sigWidth.

  Section Ty.
    Variable ty: Kind -> Type.
    Section Convert.

      Definition NFToINInput := STRUCT_TYPE {
                                "inNF" :: NF expWidthMinus2 sigWidthMinus2;
                                "roundingMode" :: Bit 3;
                                "signedOut" :: Bool
                              }.

      Definition NFToINOutput := STRUCT_TYPE {
                                     "outIN" :: Bit intWidth;
                                     "flags" :: ExceptionFlags
                                   }.

      Open Scope kami_expr.
      Variable input: NFToINInput  @# ty.

      Definition roundingMode_near_even := input @% "roundingMode" == $$ round_near_even.
      Definition roundingMode_minMag := input @% "roundingMode" == $$ round_minMag.
      Definition roundingMode_min := input @% "roundingMode" == $$ round_min.
      Definition roundingMode_max := input @% "roundingMode" == $$ round_max.
      Definition roundingMode_odd := input @% "roundingMode" == $$ round_odd.
      Definition roundingMode_near_maxMag := input @% "roundingMode" == $$ round_near_maxMag.

      Definition signedOut := input @% "signedOut" .
      Definition inNF  := input @% "inNF".
      Definition inExp := inNF @% "sExp".
      Definition inSig := inNF @% "sig".
      Definition inSign := inNF @% "sign".

      Definition bigIntSz: nat :=(2 ^ expWidthMinus1).

      Definition ZeroExpand n sz `(i: Expr ty (SyntaxKind (Bit n)))
        :Expr ty (SyntaxKind (Bit (n + sz))).
      Proof.
        refine (castBits _ ({< i, $$(wzero sz) >})); abstract intuition.
      Defined.

      Lemma expWidth_ge_sigWidth_local:
        (2 ^ expWidthMinus1 > sigWidth)%nat.
      Proof.
        rewrite ?Nat.pow_add_r; simpl.
        assert (sth: (2 ^ expWidthMinus2 >= 4)%nat). {
          pose proof (@Nat.pow_le_mono_r 2 _ _ ltac:(lia) expWidth_prop).
          assumption.
        }
        lia.
      Qed.

      Open Scope kami_action.

      Definition NFToIN_expr
      :  NFToINOutput ## ty.
      Proof.
        refine (
          LETC isExpPositive <- (inExp >=s $0);

          LETC leadingOneSig: Bit sigWidth <- {< $$ WO~1, inSig >};
          LETC bigSig: Bit bigIntSz <- castBits _ (ZeroExpand (bigIntSz - sigWidth) #leadingOneSig);
          LETC tailSig: Bit sigWidth <- (IF #isExpPositive || inNF @% "isZero"
                                        then #leadingOneSig << (inExp+$1)
                                        else (IF inExp == ($0 - $1)
                                              then #leadingOneSig
                                              else #leadingOneSig >> $$WO~1));

          LETC isTailMiddle : Bool <- (#tailSig == {< $$WO~1, $$ (wzero sigWidthMinus1)>});
          LETC isTailGtMiddle : Bool <- (#tailSig > {< $$WO~1, $$ (wzero sigWidthMinus1)>});

          LETC correctSig: Bit bigIntSz <- #bigSig >> ($bigIntSz - inExp - $1);

          LETC truncSig <- match Compare_dec.lt_dec intWidth bigIntSz with
                          | left _ => UniBit (TruncLsb (intWidth) (bigIntSz - intWidth)) (castBits _ #correctSig)
                          | _ => castBits _ (ZeroExtend (intWidth - bigIntSz) #correctSig)
                          end;

          LETC truncSigHead <- match Compare_dec.lt_dec intWidth bigIntSz with
                          | left _ => UniBit (TruncMsb (intWidth) (bigIntSz - intWidth)) (castBits _ #correctSig)
                          | _ => $ 0
                          end;

          LETC isTruncSigOdd: Bool <- UniBit (TruncLsb 1 intWidthMinus1) (castBits _ #truncSig) == $1 ;
          LETC roundIncr <-
              ((roundingMode_min && inSign && #tailSig != $0)
               || (roundingMode_max && !inSign && #tailSig != $0)
               || (roundingMode_near_even && ((#isTailMiddle && #isTruncSigOdd)
                                                ||#isTailGtMiddle))
               || (roundingMode_near_maxMag && (#isTailMiddle || #isTailGtMiddle)));

          LETC roundIN : Bit intWidth <- (IF #roundIncr then #truncSig + $1 else #truncSig);
          LETC roundOrJammIN: (Bit intWidth) <-
                                                (IF (roundingMode_odd && #tailSig != $0)
                                                 then castBits _ ({< UniBit (TruncMsb 1 intWidthMinus1) (castBits _ #roundIN), Const ty WO~1 >})
                                                 else #roundIN);
          LETC signedIN <-
              IF inSign
          then $0 - #roundOrJammIN
          else #roundOrJammIN;

          LETC overflowBiasOut: Bit (expWidth + 1) <-
                                ZeroExtend _ (IF signedOut
                                              then $1
                                              else $0);

          LETC overflowBiasSign: Bit (expWidth + 1) <-
                                ZeroExtend _ (IF inSign
                                              then $1
                                              else $0);

          LETC overflow_afterRound <- !inSign
                                       && (((#signedIN <s $0) && signedOut)
                                           || (!signedOut
                                                && #roundIncr
                                                && (#truncSig == $$(wones intWidth))));

          LETC overflow_exp <- ((inExp >s $intWidthMinus1 - #overflowBiasOut)
                           && !(inSign
                                 && (#signedIN == {<$$WO~1, $$(wzero intWidthMinus1)>})
                                 && inExp == $intWidthMinus1));

          LETC roundsToZero <- (#signedIN == $0) && (inExp <=s $0);

          LETC invalidExec <-
              (inNF @% "isNaN"
               || inNF @% "isInf"
               || #overflow_exp
               || #overflow_afterRound
               || (inSign && !signedOut && !#roundsToZero));

          LETC finalIN <-
              (IF !#invalidExec
               then #signedIN
               else (IF signedOut
                     then (IF inSign && !(inNF @% "isNaN")
                           then {<$$ WO~1, $$(wzero intWidthMinus1)>}
                           else {<$$ WO~0, $$(wones intWidthMinus1)>})
                     else (IF inSign && !(inNF @% "isNaN")
                           then $0
                           else $$(wones intWidth))));

          LETC outFlags: ExceptionFlags <- STRUCT {
                                         "invalid" ::= (#invalidExec);
                                         "infinite" ::= $$false;
                                         "overflow" ::= $$false;
                                         "underflow" ::= $$false;
                                         "inexact" ::= !#invalidExec && (#tailSig != $0)
                                       };

          LETC output: NFToINOutput <- STRUCT {
                                     "outIN" ::= #finalIN;
                                     "flags" ::= #outFlags
                                   };
          RetE #output);
          abstract (unfold bigIntSz in *; pose proof expWidth_ge_sigWidth_local; simpl; lia).
      Defined.

      Definition NFToIN_action: ActionT ty (NFToINOutput)
        := convertLetExprSyntax_ActionT NFToIN_expr.

    End Convert.

  End Ty.
End Definitions.


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 A1 A2 B1 B2 C1 C2 P : Universe, ((wd_ A1 A2 /\ (wd_ B1 B2 /\ (wd_ C1 C2 /\ (wd_ A1 B1 /\ (wd_ A1 B2 /\ (col_ A1 A2 B1 /\ (col_ A1 A2 B2 /\ (col_ P B1 B2 /\ (col_ A1 A2 C1 /\ (col_ A1 A2 C2 /\ col_ P C1 C2)))))))))) -> col_ C1 B1 B2)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Bishop.Mt.
Require Import Blech.Category.
Require Import Blech.Category.Op.
Require Import Blech.Category.Prod.
Require Import Blech.Category.Bsh.
Require Import Blech.Functor.
Require Import Blech.Type.Some.
Require Blech.Reflect.

Import CategoryNotations.
Import BishopNotations.
Import FunctorNotations.
Import OpNotations.
Import ProdNotations.
Import SomeNotations.

Open Scope category_scope.
Open Scope bishop_scope.

Close Scope nat.

#[local]
Obligation Tactic := Reflect.category_simpl.

Section sum.
  Context {C D E: Category}.

  Definition cograph (F: Functor C E) (G: Functor D E) (A B: C + D) :=
    match (A, B) with
    | (inl A', inr B') => F A' ~> G B'
    | (inl A', inl B') => A' ~> B'
    | (inr A', inr B') => A' ~> B'
    | _ => mt
    end.
End sum.

#[program]
Definition Cograph {C D E: Category} (F: Functor C E) (G: Functor D E): Category := {|
  Obj := C + D ;
  Mor A B := cograph F G A B ;
|}.

Next Obligation.
Proof.
  destruct A, B.
  all: cbn.
  1,2,4: apply Mor_Setoid.
  apply (@Bishop_Setoid mt).
Defined.

Next Obligation.
Proof.
  destruct A.
  all: cbn.
  all: apply id.
Defined.

Next Obligation.
Proof.
  destruct A, B, C0.
  all: cbn in *.
  all: try contradiction.
  1,4: apply (X ∘ X0).
  - apply (X ∘ map F X0).
  - apply (map G X ∘ X0).
Defined.

Next Obligation.
Proof.
  destruct A, B, C0, D0.
  all: cbn in *.
  all: try contradiction.
  1,5: apply compose_assoc.
  - rewrite <- map_composes.
    rewrite compose_assoc.
    reflexivity.
  - rewrite compose_assoc.
    reflexivity.
  - rewrite <- map_composes.
    rewrite compose_assoc.
    reflexivity.
Qed.

Next Obligation.
Proof.
  destruct A, B.
  all: cbn in *.
  all: try contradiction.
  2: rewrite map_id.
  all: apply compose_id_left.
Qed.

Next Obligation.
Proof.
  destruct A, B.
  all: cbn in *.
  all: try contradiction.
  2: rewrite map_id.
  all: apply compose_id_right.
Qed.

Next Obligation.
Proof.
  intros ? ? p ? ? q.
  destruct A, B, C0.
  all: cbn in *.
  all: try contradiction.
  all: rewrite p, q.
  all: reflexivity.
Qed.


Require Import Heaps.
Require Import SepExpr.
Require Import EquivDec.
Require Import List.

Set Implicit Arguments.

Module SepExprTests (B : Heap) (ST : SepTheoryX.SepTheoryXType B).
  Module Sep := SepExpr.SepExpr B ST.

  (** Just a test separation logic predicate **)
  Section Tests.
    Variable f : forall a b, nat -> ST.hprop a b nil.
    Variable h : forall a b, nat -> ST.hprop a b nil.
    Variable i : forall a b, nat -> ST.hprop a b nil.
    Variable g : bool -> nat -> nat -> nat.

    Ltac isConst e :=
      match e with
        | true => true
        | false => true
        | O => true
        | S ?e => isConst e
        | _ => false
      end.

    Definition nat_type : type :=
      {| Impl := nat
       ; Eq := fun x y => match equiv_dec x y with
                            | left pf => Some pf
                            | _ => None
                          end
       |}.

    Fixpoint all a b (f : nat -> ST.hprop a b nil) (n : nat) : ST.hprop a b nil :=
      match n with
        | 0 => f 0
        | S n => ST.star (f (S n)) (all f n)
      end.

    Fixpoint allb a b (f : nat -> ST.hprop a b nil) (n m : nat) : ST.hprop a b nil :=
      match n with
        | 0 => f m
        | S n => ST.star (f (m - S n)) (allb f n m)
      end.

    Opaque ST.himp ST.star ST.emp ST.inj ST.ex.

    Ltac go := Sep.sep isConst (nat_type :: nil) ltac:(vm_compute).

    Goal let N := 1 in
      forall a b c, @ST.himp a b c
      (ST.star (allb (@h a b) N N) (allb (@f a b) N N))
      (ST.star (all (@f a b) N) (all (@h a b) N)).
    Proof.
      simpl; intros.
      Time go. reflexivity.
    Time Qed.

    Goal let N := 5 in
      forall a b c, @ST.himp a b c
      (ST.star (allb (@h a b) N N) (allb (@f a b) N N))
      (ST.star (all (@f a b) N) (all (@h a b) N)).
    Proof.
      simpl; intros.
      Time go. reflexivity.
    Time Qed.

    Goal let N := 10 in
      forall a b c, @ST.himp a b c
      (ST.star (allb (@h a b) N N) (allb (@f a b) N N))
      (ST.star (all (@f a b) N) (all (@h a b) N)).
    Proof.
      simpl; intros.
      Time go. reflexivity.
    Time Qed.

    Goal let N := 15 in
      forall a b c, @ST.himp a b c
      (ST.star (allb (@h a b) N N) (allb (@f a b) N N))
      (ST.star (all (@f a b) N) (all (@h a b) N)).
    Proof.
      simpl; intros.
      Time go. reflexivity.
    Time Qed.

    Goal let N := 20 in
      forall a b c, @ST.himp a b c
      (ST.star (allb (@h a b) N N) (allb (@f a b) N N))
      (ST.star (all (@f a b) N) (all (@h a b) N)).
    Proof.
      simpl; intros.
      Time go. reflexivity.
    Time Qed.

(*
  Goal forall a b c, @ST.himp a b c
    (ST.star (all (@h a b) N) (allb (@f a b) M M))
    (ST.star (all (@f a b) M) (all (@h a b) N)).
  Proof.
    simpl all. simpl allb. unfold N, M.
    intros.
    Time Sep.sep isConst (nat_type :: nil). reflexivity.
  Time Qed.

  Goal forall a b c, @ST.himp a b c
    (ST.star (all (@h a b) N) (all (@f a b) M))
    (ST.star (all (@f a b) M) (all (@h a b) N)).
  Proof.
    simpl all. simpl allb. unfold N, M.
    intros.
    Time Sep.sep isConst (nat_type :: nil). reflexivity.
  Time Qed.

  Goal forall a b c, @ST.himp a b c
    (ST.star (all (@f a b) M) (all (@h a b) N))
    (ST.star (all (@f a b) M) (all (@h a b) N)).
  Proof.
    simpl all. simpl allb. unfold N, M.
    intros.
    Time Sep.sep isConst (nat_type :: nil). reflexivity.
  Time Qed.
*)

(*
    Goal forall a b c, @ST.himp a b c (ST.star (allb (@h a b) 15 15) (allb (@f a b) 15 15)) (ST.star (all (@f a b) 15) (all (@h a b) 15)).
      simpl all. simpl allb.
      intros. Time Sep.sep isConst (nat_type :: nil). reflexivity.
    Qed.

    Goal forall a b c x y, @ST.himp a b c (f _ _ (g y (x + x) 1)) (f _ _ 1).
      intros. Time Sep.sep isConst (nat_type :: nil).
    Abort.

    Goal forall a b c, @ST.himp a b c
      (ST.star (f _ _ 2) (f _ _ 1))
      (f _ _ 1).
      intros. Time Sep.sep isConst (nat_type :: nil).
    Abort.

    Goal forall a b c, @ST.himp a b c
      (ST.ex (fun y : nat => ST.ex (fun x : bool => ST.star (f _ _ (g x 1 2)) (f _ _ 1) )))
      (f _ _ 1).
      intros. Time Sep.sep isConst (nat_type :: nil).
    Abort.

    Goal forall a b c, @ST.himp a b c
      (ST.ex (fun y : nat => f _ _ y))
      (f _ _ 1).
      intros. Time Sep.sep isConst (nat_type :: nil).
    Abort.
*)
  End Tests.

End SepExprTests.


Require Export SystemFR.ReducibilityEquivalent.

Opaque reducible_values.

Lemma reducibility_is_candidate:
  forall ρ T,
    valid_interpretation ρ ->
    is_erased_type T ->
    wf T 0 ->
    pfv T term_var = nil ->
    reducibility_candidate (fun v => [ ρ ⊨ v : T ]v).
Proof.
  unfold reducibility_candidate; steps;
    eauto with erased fv wf values;
    eauto using reducibility_equivalent.
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 O E Eprime A B C D U Bu Xu Du : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ D O /\ (wd_ U Eprime /\ (wd_ A Eprime /\ (wd_ D Du /\ (wd_ Bu Xu /\ (wd_ B Bu /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E U /\ (col_ O Eprime Bu /\ (col_ O E Xu /\ col_ O Eprime Du)))))))))))))))))))) -> col_ O U D)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 O E Eprime A B C D U Bu Xu Du : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ D O /\ (wd_ U Eprime /\ (wd_ A Eprime /\ (wd_ D Du /\ (wd_ Bu Xu /\ (wd_ B Bu /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E U /\ (col_ O Eprime Bu /\ (col_ O E Xu /\ col_ O Eprime Du)))))))))))))))))))) -> col_ O U Xu)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** * Definition of a univalent/saturated precategory, or just "category" *)
Require Import Category.Core Category.Morphisms.
Require Import HoTT.Basics HoTT.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.

(** A category is a precategory for which [idtoiso] is an equivalence. *)

Notation IsCategory C := (forall s d : object C, IsEquiv (@idtoiso C s d)).

Notation isotoid C s d := (@equiv_inv _ _ (@idtoiso C s d) _).

(** *** The objects of a category are a 1-type *)

Global Instance trunc_category `{IsCategory C} : IsTrunc 1 C | 10000.
Proof.
  intros ? ?.
  eapply istrunc_equiv_istrunc;
  [ symmetry;
    esplit;
    apply_hyp
  | ].
  typeclasses eauto.
Qed.

Record Category :=
  {
    precategory_of_category :> PreCategory;
    iscategory_precategory_of_category :> IsCategory precategory_of_category
  }.

Global Existing Instance iscategory_precategory_of_category.


Require Import
        Fiat.Computation
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Common.Notations
        Fiat.BinEncoders.Env.Common.Compose.

Definition composeIf E B
           (transformer : Transformer B)
           (iComp : Comp bool)
           (encodeT : E -> Comp (B * E))
           (encodeE : E -> Comp (B * E))
           (e : E)
  := b <- iComp;
       If b Then encodeT e
          Else encodeE e.

Notation "'Either' t 'Or' e " :=
  (composeIf _ _ _ { _ : bool | True} t e) : binencoders_scope.

Lemma composeIf_encode_correct
      {A B}
      {cache : Cache}
      {P  : CacheDecode -> Prop}
      {P_invT P_invE : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_invT P /\ P_invE P))
      (transformer : Transformer B)
      (predicate : A -> Prop)
      (predicate_rest : A -> B -> Prop)
      (ICompb : B -> bool)
      (encodeT : A -> CacheEncode -> Comp (B * CacheEncode))
      (decodeT : B -> CacheDecode -> option (A * B * CacheDecode))
      (encodeE : A -> CacheEncode -> Comp (B * CacheEncode))
      (decodeE : B -> CacheDecode -> option (A * B * CacheDecode))
      (decodeT_pf :
         cache_inv_Property P P_invT
         -> encode_decode_correct_f
              cache transformer predicate predicate_rest
              encodeT decodeT P)
      (decodeE_pf :
         cache_inv_Property P P_invE
         -> encode_decode_correct_f
              cache transformer predicate predicate_rest
              encodeE decodeE P)
      (ICompb_OKT : forall data bin env xenv ext,
          predicate data
          -> encodeT data env ↝ (bin, xenv)
          -> ICompb (transform bin ext) = true)
      (ICompb_OKE : forall data bin env xenv ext,
          predicate data
          -> encodeE data env ↝ (bin, xenv)
          -> ICompb (transform bin ext) = false)
  : encode_decode_correct_f
      cache transformer
      (fun a => predicate a)
      predicate_rest
      (fun (data : A) =>
         composeIf _ _ _ {b : bool | True }
                   (encodeT data)
                   (encodeE data)
      )%comp
      (fun (b : B) (env : CacheDecode) =>
         If ICompb b Then
            decodeT b env
            Else
            decodeE b env
      ) P.
Proof.
  unfold cache_inv_Property in *; split.
  { intros env env' xenv data bin ext ? env_pm pred_pm pred_pm_rest com_pf.
    unfold composeIf, Bind2 in com_pf; computes_to_inv; destruct v;
      simpl in com_pf'; computes_to_inv.
    - erewrite ICompb_OKT; eauto.
      simpl; eapply decodeT_pf; intuition eauto.
    - erewrite ICompb_OKE; eauto.
      simpl; eapply decodeE_pf; intuition eauto.
  }
  { intros.
    destruct (ICompb bin) eqn : IComp_v ; simpl in *.
    - eapply decodeT_pf in H1; intuition eauto.
      destruct_ex; intuition; eexists; eexists;
        unfold composeIf; intuition eauto.
      refine pick val true; eauto.
    - eapply decodeE_pf in H1; intuition eauto.
      destruct_ex; intuition; eexists; eexists;
        unfold composeIf; intuition eauto.
      refine pick val false; eauto. }
Qed.

Definition composeIf' E B
           (transformer : Transformer B)
           (encode1 : E -> Comp (B * E))
           (encode2 : E -> Comp (B * E))
           (iComp : Comp bool)
           (encodeT : E -> Comp (B * E))
           (encodeE : E -> Comp (B * E))
  :=
    (fun e0 =>
         b <- iComp;
           If b Then
              `(p, e1) <- encode1 e0;
            `(q, e2) <- encodeT e1;
            ret (transform p q, e2)
                Else (`(p, e1) <- encode2 e0;
                      `(q, e2) <- encodeE e1;
                      ret (transform p q, e2))
    )%comp.

Lemma composeIf'_encode_correct
      {A A' B}
      {cache : Cache}
      {P  : CacheDecode -> Prop}
      {P_inv1 P_invT P_invE : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_inv1 P /\ P_invT P /\ P_invE P))
      (transformer : Transformer B)
      (projectT : A -> A')
      (projectE : A -> A')
      (predicate : A -> Prop)
      (predicate_rest : A' -> B -> Prop)
      (predicate_rest' : A -> B -> Prop)
      (predicate' : A' -> Prop)
      (encode1 : A' -> CacheEncode -> Comp (B * CacheEncode))
      (decode1 : B -> CacheDecode -> option (A' * B * CacheDecode))
      (ICompb : A' -> bool)
      (encodeT : A -> CacheEncode -> Comp (B * CacheEncode))
      (decodeT : A' -> B -> CacheDecode -> option (A * B * CacheDecode))
      (encodeE : A -> CacheEncode -> Comp (B * CacheEncode))
      (decodeE : A' -> B -> CacheDecode -> option (A * B * CacheDecode))
      (decode1_pf :
         cache_inv_Property P P_inv1
         -> encode_decode_correct_f
              cache transformer predicate' predicate_rest
              encode1 decode1 P)
      (decodeT_pf : forall proj,
          ICompb proj = true ->
          predicate' proj ->
          cache_inv_Property P P_invT ->
          encode_decode_correct_f
            cache transformer
            (fun data => predicate data /\ projectT data = proj)
            predicate_rest'
            encodeT
            (decodeT proj) P)
      (decodeE_pf : forall proj,
          ICompb proj = false ->
          predicate' proj ->
          cache_inv_Property P P_invE ->
          encode_decode_correct_f
            cache transformer
            (fun data => predicate data /\ projectE data = proj)
            predicate_rest'
            encodeE
            (decodeE proj) P)
      (predicate_rest_implT : forall a' b b'',
          (ICompb a' = true /\
           exists a ce ce' ce'' b' b'',
             computes_to (encode1 a' ce) (b', ce')
             /\ projectT a = a'
             /\ predicate a
             /\ computes_to (encodeT a ce') (b'', ce'')
             /\ predicate_rest' a b)
          -> predicate_rest a' (transform b'' b))
      (predicate_rest_implE : forall a' b b'',
          (ICompb a' = false /\
           exists a ce ce' ce'' b',
             computes_to (encode1 a' ce) (b', ce')
             /\ projectE a = a'
             /\ predicate a
             /\ computes_to (encodeE a ce') (b'', ce'')
             /\ predicate_rest' a b)
          -> predicate_rest a' (transform b'' b))
      (pred_pf : forall data, predicate data -> predicate' (projectT data))
      (pred_pf' : forall data, predicate data -> predicate' (projectE data))
      (ICombT_OK : forall data, ICompb (projectT data) = true)
      (ICombE_OK : forall data, ICompb (projectE data) = false)
  : encode_decode_correct_f
      cache transformer
      (fun a => predicate a)
      predicate_rest'
      (fun (data : A) (ctx : CacheEncode) =>
         composeIf' _ _ _ (encode1 (projectT data))
                   (encode1 (projectE data)) {b : bool | True } (encodeT data) (encodeE data)  ctx
      )%comp
      (fun (bin : B) (env : CacheDecode) =>
         `(proj, rest, env') <- decode1 bin env;
           If ICompb proj Then
              decodeT proj rest env'
              Else
              decodeE proj rest env'
      ) P.
Proof.
  unfold cache_inv_Property in *; split.
  { intros env env' xenv data bin ext ? env_pm pred_pm pred_pm_rest com_pf.
    unfold composeIf', Bind2 in com_pf; computes_to_inv; destruct v;
      simpl in com_pf'; computes_to_inv; destruct v; destruct v0;
        simpl in com_pf'', com_pf'''.
    - injections.
      destruct (fun H => proj1 (decode1_pf (proj1 P_inv_pf)) _ _ _ _ _ (transform b0 ext) env_OK env_pm (pred_pf _ pred_pm) H com_pf'); intuition; simpl in *; injections.
      eapply predicate_rest_implT; repeat eexists; intuition eauto.
      destruct (fun H' => proj1 (decodeT_pf (projectT data) (ICombT_OK data) (pred_pf _ pred_pm)
                                            H)
                                _ _ _ _ _ ext H5 H1 (conj pred_pm (eq_refl _)) H' com_pf'');
        intuition; simpl in *; injections.
      setoid_rewrite <- transform_assoc; rewrite H2.
      intuition; simpl in *; injections.
      rewrite ICombT_OK, H7; simpl; eauto.
    - injections.
      destruct (fun H' => proj1 (decode1_pf (proj1 P_inv_pf)) _ _ _ _ _ (transform b0 ext) env_OK env_pm (pred_pf' _ pred_pm) H' com_pf'); intuition; simpl in *; injections.
      eapply predicate_rest_implE; intuition; repeat eexists; intuition eauto.
      destruct (fun H' => proj1 (decodeE_pf (projectE data) (ICombE_OK data) (pred_pf' _ pred_pm)
                                            H4)
                                _ _ _ _ _ ext H5 H1 (conj pred_pm (eq_refl _)) H' com_pf'');
        intuition; simpl in *; injections.
      setoid_rewrite <- transform_assoc; rewrite H2.
      intuition; simpl in *; injections.
      rewrite ICombE_OK, H7; simpl; eauto.
  }
  { intros.
    destruct (decode1 bin env') as [ [ [? ?] ? ] | ] eqn : ? ;
      simpl in *; try discriminate.
    destruct (ICompb a) eqn: ?; simpl in *.
    - eapply (proj2 (decode1_pf (proj1 P_inv_pf))) in Heqo; eauto;
        destruct Heqo; destruct_ex; intuition;
          eapply (proj2 (decodeT_pf a Heqb0 H7 H3)) in H1; eauto;
            destruct H1; destruct_ex; intuition; subst.
      eexists; eexists; repeat split.
      unfold composeIf'; refine pick val true.
      repeat computes_to_econstructor; eauto.
      eauto.
      simpl; rewrite transform_assoc; reflexivity.
      eassumption.
      eassumption.
    - eapply (proj2 (decode1_pf (proj1 P_inv_pf))) in Heqo; eauto;
        destruct Heqo; destruct_ex; intuition;
          eapply (proj2 (decodeE_pf a Heqb0 H7 H8)) in H1; eauto;
            destruct H1; destruct_ex; intuition; subst.
      eexists; eexists; repeat split.
      unfold composeIf'; refine pick val false.
      repeat computes_to_econstructor; eauto.
      eauto.
      simpl; repeat computes_to_econstructor; eauto.
      simpl; rewrite transform_assoc; reflexivity.
      eassumption.
      eassumption.
  }
Qed.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

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

This library 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
COPYING file for more details.
*)

Require Import Reals mathcomp.ssreflect.ssreflect.
Require Import Rcomplements.
Require Import List Omega.
Require Import mathcomp.ssreflect.seq mathcomp.ssreflect.ssrbool mathcomp.ssreflect.eqtype.

(** This file describes iterators on lists. This is mainly used for
Riemannn sums. *)

Section Iter.

Context {I T : Type}.

Context (op : T -> T -> T).
Context (x0 : T).
Context (neutral_l : forall x, op x0 x = x).
Context (neutral_r : forall x, op x x0 = x).
Context (assoc : forall x y z, op x (op y z) = op (op x y) z).

Fixpoint iter (l : list I) (f : I -> T) :=
  match l with
  | nil => x0
  | cons h l' => op (f h) (iter l' f)
  end.

Definition iter' (l : list I) (f : I -> T) :=
  fold_right (fun i acc => op (f i) acc) x0 l.

Lemma iter_iter' l f :
  iter l f = iter' l f.
Proof.
  elim: l => [ | h l IH] //=.
  by rewrite IH.
Qed.

Lemma iter_cat l1 l2 f :
  iter (l1 ++ l2) f = op (iter l1 f) (iter l2 f).
Proof.
  elim: l1 => [ | h1 l1 IH] /=.
  by rewrite neutral_l.
  by rewrite IH assoc.
Qed.
Lemma iter_ext l f1 f2 :
  (forall x, In x l -> f1 x = f2 x) ->
  iter l f1 = iter l f2.
Proof.
  elim: l => [ | h l IH] /= Heq.
  by [].
  rewrite IH.
  rewrite Heq //.
  by left.
  intros x Hx.
  apply Heq.
  by right.
Qed.

Lemma iter_comp (l : list I) f (g : I -> I) :
  iter l (fun x => f (g x)) = iter (map g l) f.
Proof.
  elim: l => [ | s l IH] //=.
  by rewrite IH.
Qed.

End Iter.

Lemma iter_const {I} (l : list I) (a : R) :
  iter Rplus 0 l (fun _ => a) = INR (length l) * a.
Proof.
  elim: l => /= [ | h l ->].
  by rewrite /= Rmult_0_l.
  case: (length l) => [ | n] ; simpl ; ring.
Qed.

Lemma In_mem {T : eqType} (x : T) l :
  reflect (In x l) (in_mem x (mem l)).
Proof.
apply iffP with (P := x \in l).
by case: (x \in l) => // ; constructor.

elim: l => [ | h l IH] //= E.
rewrite in_cons in E.
case/orP: E => E.
now left ; apply sym_eq ; apply / eqP.
right ; by apply IH.

elim: l => [ | h l IH] E //=.
simpl in E.
case : E => E.
rewrite E ; apply mem_head.
rewrite in_cons.
rewrite IH.
apply orbT.
by [].
Qed.

Lemma In_iota (n m k : nat) :
  (n <= m <= k)%nat <-> In m (iota n (S k - n)).
Proof.
  generalize (mem_iota n (S k - n) m).
  case: In_mem => // H H0.
  apply sym_eq in H0.
  case/andP: H0 => H0 H1.
  apply Rcomplements.SSR_leq in H0.
  apply SSR_leq in H1.
  change ssrnat.addn with Peano.plus in H1.
  split => // _.
  split => //.
  case: (le_dec n (S m)).
  intro ; omega.
  intro H2.
  rewrite not_le_minus_0 in H1 => //.
  contradict H2.
  by eapply le_trans, le_n_Sn.
  contradict H2.
  by eapply le_trans, le_n_Sn.
  change ssrnat.addn with Peano.plus in H0.
  split => // H1.
  case: H1 => /= H1 H2.
  apply sym_eq in H0.
  apply Bool.andb_false_iff in H0.
  case: H0 => //.
  move/SSR_leq: H1 ; by case: ssrnat.leq.
  rewrite -le_plus_minus ; try omega.
  move/le_n_S/SSR_leq: H2 ; by case: ssrnat.leq.
Qed.

Section Iter_nat.

Context {T : Type}.

Context (op : T -> T -> T).
Context (x0 : T).
Context (neutral_l : forall x, op x0 x = x).
Context (neutral_r : forall x, op x x0 = x).
Context (assoc : forall x y z, op x (op y z) = op (op x y) z).

Definition iter_nat (a : nat -> T) n m :=
  iter op x0 (iota n (S m - n)) a.

Lemma iter_nat_ext_loc (a b : nat -> T) (n m : nat) :
  (forall k, (n <= k <= m)%nat -> a k = b k) ->
  iter_nat a n m = iter_nat b n m.
Proof.
  intros Heq.
  apply iter_ext.
  intros k Hk.
  apply Heq.
  by apply In_iota.
Qed.

Lemma iter_nat_point a n :
  iter_nat a n n = a n.
Proof.
  unfold iter_nat.
  rewrite -minus_Sn_m // minus_diag /=.
  by apply neutral_r.
Qed.

Lemma iter_nat_Chasles a n m k :
  (n <= S m)%nat -> (m <= k)%nat ->
  iter_nat a n k = op (iter_nat a n m) (iter_nat a (S m) k).
Proof.
  intros Hnm Hmk.
  rewrite -iter_cat //.
  pattern (S m) at 2 ;
  replace (S m) with (ssrnat.addn n (S m - n)).
  rewrite -(iota_add n (S m - n)).
  apply (f_equal (fun k => iter _ _ (iota n k) _)).
  change ssrnat.addn with Peano.plus.
  omega.
  change ssrnat.addn with Peano.plus.
  omega.
Qed.

Lemma iter_nat_S a n m :
  iter_nat (fun n => a (S n)) n m = iter_nat a (S n) (S m).
Proof.
  rewrite /iter_nat iter_comp.
  apply (f_equal (fun l => iter _ _ l _)).
  rewrite MyNat.sub_succ.
  elim: (S m - n)%nat {1 3}(n) => {n m} [ | n IH] m //=.
  by rewrite IH.
Qed.

End Iter_nat.


Require Import Hask.Prelude.
Require Import Hask.Control.Monad.
Require Import P.Pipes.

Generalizable All Variables.

(* [Sproxy] is a Boehm-Berarducci encoding of pipes' [Proxy] type. In Haskell
   it could be optimized further as follows:

     forall s.
          (a' -> (a  -> m s) -> m s)
       -> (b  -> (b' -> m s) -> m s)
       -> (r -> m s)
       -> m s)

   However, this will not work in Coq until use of Universe Polymorphism is
   applied throughout the coq-haskell library. *)

Definition SProxy (a' a b' b : Type) (m : Type -> Type) (r : Type) : Type :=
  forall s : Type,
       (a' -> (a  -> s) -> s)           (* SRequest *)
    -> (b  -> (b' -> s) -> s)           (* SRespond *)
    -> (forall x, (x -> s) -> m x -> s) (* SM *)
    -> (r -> s)                         (* SPure *)
    -> s.

Definition toProxy `(s : SProxy a' a b' b m r) : Proxy a' a b' b m r :=
  s _ Request Respond (fun _ => M) Pure.

Definition fromProxy `(p : Proxy a' a b' b m r) : SProxy a' a b' b m r :=
  fun _ req res mon pur =>
    let fix go p := match p with
    | Request a' fa  => req a' (go \o fa)
    | Respond b  fb' => res b  (go \o fb')
    | M _     g  h   => mon _  (go \o g) h
    | Pure    x      => pur x
    end in
    go p.

Module SProxyLaws.

Include PipesLaws.

Require Import FunctionalExtensionality.

Lemma SProxy_to_from : forall `(x : Proxy a' a b' b m r),
  toProxy (fromProxy x) = x.
Proof.
  move=> a' a b' b m r.
  by reduce_proxy IHx
    (rewrite /toProxy;
     first [ congr (Request _)
           | congr (Respond _)
           | congr (M _)
           | congr (Pure _) ]).
Qed.

Axiom f_const : forall `(f : a -> (b -> s) -> s) (x : a) (y : s),
  f x (const y) = y.

Definition const_f `(f : (b -> s) -> a -> s) (x : a) (y : s) :
  f (const y) x = y := f_const (flip f) x y.

(* As [pur] is the only function that can produce an [s], it must be equal to
   reducing the [SProxy]. *)
Axiom SProxy_parametricity : forall `(sp : SProxy a' a b' b m r) (s : Type)
  (req : a' -> (a  -> s) -> s)
  (res : b  -> (b' -> s) -> s)
  (mon : forall x, (x -> s) -> m x -> s)
  (pur : r -> s) (z : r),
  pur z = sp s req res mon pur.

Lemma SProxy_from_to : forall `(x : SProxy a' a b' b m r),
  fromProxy (toProxy x) = x.
Proof.
  move=> ? ? ? ? ? ? x.
  extensionality s.
  extensionality req.
  extensionality res.
  extensionality mon.
  extensionality pur.
  move: (toProxy x).
  reduce_proxy IHx
    (rewrite /fromProxy /funcomp /=;
     try (move/functional_extensionality in IHx;
          rewrite IHx ?f_const ?const_f)).
  exact: SProxy_parametricity.
Qed.

(* Induction hypothesis for the [SProxy] type. *)
Theorem sproxy_ind :
  forall (a' a b' b : Type) (m : Type -> Type) (r : Type)
         (P : SProxy a' a b' b m r -> Prop),
   (forall (x : a') (f : a -> SProxy a' a b' b m r),
      P (fun s req res mon pur => req x (fun a => f a s req res mon pur))) ->
   (forall (x : b) (f : b' -> SProxy a' a b' b m r),
      P (fun s req res mon pur => res x (fun b' => f b' s req res mon pur))) ->
   (forall t (f : t -> SProxy a' a b' b m r) (x : m t),
      P (fun s req res mon pur => mon _ (fun x => f x s req res mon pur) x)) ->
   (forall (x : r), P (fun s _ _ _ pur => pur x)) ->
   forall p : SProxy a' a b' b m r, P p.
Proof.
  move=> ? ? ? ? ? ? ? Hreq Hres Hmon Hpure p.
  rewrite -(SProxy_from_to p).
  by elim: (toProxy p) => [*|*|*|*];
  [ exact: Hreq
  | exact: Hres
  | exact: Hmon
  | exact: Hpure ].
Qed.

End SProxyLaws.


From Mtac2 Require Import Base Logic Datatypes MFixDef MTele MTeleMatch.
Import M.notations.
Import Sorts.S.

Set Universe Polymorphism.
Unset Universe Minimization ToSet.

Local Definition MFA {n} (T : MTele_Ty n) := (MTele_val (MTele_C Typeₛ Propₛ M T)).

(* Less specific version of MTele_of in MTeleMatch.v *)
Definition MTele_of' :=
  (mfix1 f (T : Prop) : M { m : MTele & { mT : MTele_Ty m & T =m= MFA mT } } :=
     mmatch T as T0 return M { m : MTele & { mT : MTele_Ty m & T =m= MFA mT } } with
     | [?X : Type] M X =u> [H]
                        M.ret (existT (fun m => {mT : MTele_Ty m & T =m= MFA mT}) (mBase)
                                      (existT (fun mT : MTele_Ty mBase => T =m= MFA mT) _ H)
                              )
     | [?(X : Type) (F : forall x:X, Prop)] (forall x:X, F x) =c> [H]
       M.nu (FreshFrom F) mNone (fun x =>
                       '(existT _ m (existT _ mT E)) <- f (F x);
                       m' <- M.abs_fun x m;
                       mT' <- (M.coerce mT >>=
                               M.abs_fun (P:=fun x => MTele_Ty (m' x)) x);
                       (* E' <- (M.abs_fun x E >>= M.coerce (B:=_ =m= MFA mT')); *)
                       E' <- M.coerce (@meq_refl _ (MFA (n:=mTele m') mT'));
                       M.ret (existT _ (mTele m') (existT _ mT' E'))
                       (* mf <- M.abs_fun (P:=fun x => {m : _ & F x =m= MFA m}) x mf; *)
                       (* let g := (fun x => projT1 (mf x)) in *)
                       (* let h := (fun x => projT2 (mf x)) in *)
                       (* e <- M.evar ((forall x, F x) =m= MFA (mTele g)); *)
                       (* er <- M.coerce (meq_refl (forall x, F x)); *)
                       (* M.unify e er UniEvarconv;; *)
                       (* M.ret (existT (fun m => (forall x:X, F x) =m= MFA m) (mTele g) e) *)
                    )
   end
  ).

Definition MTele_of : Prop -> M (sigT MTele_Ty) :=
  mfix1 f (T : Prop) : M (sigT MTele_Ty) :=
     mmatch T return M (sigT MTele_Ty) with
     | [?X : Type] M X =u> M.ret (existT _ mBase X)
     | [?(X : Type) (F : forall x:X, Prop)] (forall x:X, F x) =c>
       M.nu (FreshFrom F) mNone (fun x =>
                       '(existT _ n T) <- f (F x);
                       n' <- M.abs_fun (P:=fun _ => MTele) x n;
                       T' <- M.abs_fun x T;
                       T' <- M.coerce T';
                       M.ret (existT _ (mTele n') T')
                    )
   end
.

Class MT_OF (T : Prop) :=
  {
    mt_of_tele : MTele;
    mt_of_type: MTele_Ty mt_of_tele;
    mt_of_eq : T =m= MFA mt_of_type
  }.
(* Arguments mt_of _ {_}. *)
Definition tc_helper (t : Prop)  :=
                                '(existT _ m (existT _ mT eq)) <- MTele_of' t;
                                M.ret (Build_MT_OF _ m mT eq).
#[global] Hint Extern 0 (MT_OF ?t) => mrun (tc_helper t
                              ) : typeclass_instances.

Definition mfix_tc' {A : Prop} {mt : MT_OF A} :
  forall (F : (A -> A)),
    A :=
  match meq_sym (@mt_of_eq _ mt) in _ =m= R return (R -> R ) -> (R) with
  | meq_refl => MFixDef.mfix' _
  end.

Arguments mfix_tc' {_} {_} _.

Notation "'mfix' f x .. y : T := b" :=
  (
    @mfix_tc' (forall x, .. (forall y, T) ..) _ (fun f => fun x  => .. (fun y => b)..)
  )
    (only parsing,
     no associativity,
     at level 85,
     f ident,
     x binder,
     y binder,
     format "mfix  f  x  ..  y  :  T  :=  b"
    ).

(* The above notation does not work for printing since [T] cannot be derived
   from an application of `mfix_tc'`. Thus, we define a printing notation that
   omits [T]. *)
Notation "'mfix' f x .. y := b" :=
  (
    mfix_tc' (fun f => fun x  => .. (fun y => b)..)
  )
    (only printing,
     no associativity,
     at level 85,
     f ident,
     x binder,
     y binder,
     format "mfix  f  x  ..  y  :=  b"
    ).


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^196 - 15
Base: 24.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 24 + 1/2;
    bitwidth := 32;
    s := 2^196;
    c := [(1, 15)];
    carry_chains := Some [seq 0 (pred 8); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Export Equations.Equations.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Setoids.Setoid.
Require Export Coq.micromega.Lia.
Require Export Coq.ZArith.ZArith.
Require Export Coq.Vectors.Vector. (** Does not open [vector_scope]. *)
Require Export Coq.Bool.Bvector.
Require Export Coq.Lists.List. (** Opens [list_scope]. *)
Require Export Coq.Program.Basics.
Require Export Coq.Program.Tactics.

Export EqNotations.

Unset Suggest Proof Using.

(** ** Tactics *)

Tactic Notation "by_lia" constr(P) "as" ident(H) := assert P as H; [lia|].

Ltac lia_rewrite P :=
  let H := fresh in
  by_lia P as H;
  setoid_rewrite H;
  clear H.

(* TODO: Replace with [apply ... in ...]. *)
Ltac derive name term :=
  let H := fresh in
  let A := type of term in
  assert A as H;
  [ exact term | ];
  clear name;
  rename H into name.

(** From http://ropas.snu.ac.kr/gmeta/source/html/LibTactics.html. *)
Ltac destructs H :=
  let X := fresh in
  let Y := fresh in
  first [ destruct H as [X Y]; destructs X; destructs Y | idtac ].

Ltac idestructs := repeat (let X := fresh in intro X; destructs X).

(** Introduce abstract provable assumption. *)
Tactic Notation "given" constr(P) "as" ident(H) :=
  let T := type of P in
  cut T; [intro H|exact P].

(** From https://github.com/tchajed/coq-tricks. *)
Local Tactic Notation "unfolded_eq" constr(pf) :=
  let x := (eval red in pf) in
  exact (eq_refl : (pf = x)).
Notation unfolded_eq pf := ltac:(unfolded_eq pf) (only parsing).

(** ** Booleans *)

Derive NoConfusion for bool.

Goal true <> false.
Proof.
  intro H.
  exact (noConfusion_inv H).
Qed.

Coercion Is_true : bool >-> Sortclass.

Proposition bool_extensionality (x y : bool) (H: x <-> y) : x = y.
Proof.
  unfold Is_true in H.
  destruct x, y; tauto.
Qed.

Proposition true_is_true : true.
Proof. exact I. Qed.

Proposition false_is_false : not false.
Proof. exact id. Qed.

Proposition false_if_not_true {b: bool} : not b -> b = false.
Proof.
  destruct b.
  - intros H. contradict H. exact true_is_true.
  - intros _. reflexivity.
Qed.

Proposition negb_not (b: bool) : negb b <-> not b.
Proof.
  destruct b; now cbn.
Qed.

Proposition is_true_unique {b: bool} (H H': b) : H = H'.
Proof.
  destruct b.
  - destruct H, H'. reflexivity.
  - contradict H.
Qed.

(** See also [Is_true_eq_left], [Is_true_eq_right] and [Is_true_eq_true]. *)

Notation as_bool x := (if x then true else false).

(** ** Decidable propositions *)

(** We are not interested in Vector.eq_dec. *)
Notation eq_dec := (Classes.eq_dec).

Instance Z_EqDec: EqDec Z := Z.eq_dec.
Instance N_EqDec: EqDec N := N.eq_dec.

Class Decidable (P: Prop) : Type :=
  decide : { P } + { not P }.

Arguments decide P {_}.
#[global]
Hint Mode Decidable ! : typeclass_instances.

Instance True_decidable : Decidable True := left I.
Instance False_decidable : Decidable False := right (@id False).
Instance equality_decidable {A} `{dec: EqDec A} (x y: A) : Decidable (x = y) := dec x y.
Instance is_true_decidable (x: bool) : Decidable (x) :=
  if x return (Decidable x)
  then left true_is_true
  else right false_is_false.

Proposition asBool_decide P {DP: Decidable P} : Is_true (as_bool (decide P)) <-> P.
Proof.
  destruct (decide P) as [H|H]; now cbn.
Qed.

(** Eliminate [decide P] when we already know [P]. *)
Ltac decided H :=
  let P := type of H in
  let HH := fresh in
  destruct (decide P) as [HH|HH];
  [ try (clear HH
         || let HHH := fresh in
           set (HHH := is_true_unique HH H);
           subst HH)
  | exfalso; exact (HH H) ].

Ltac undecided H :=
  match type of H with
  | ~ ?P =>
    let HH := fresh in
    destruct (decide P) as [HH|HH];
    [ contradict H; exact HH
    | try (clear HH
      || let HHH := fresh in
         set (HHH := is_true_unique HH H);
         subst HH) ]
  end.

Section decidable_connectives.

  Context {P} {DP: Decidable P}.

  Global Instance not_decidable : Decidable (not P) :=
    match DP with
    | left H => right (fun f => f H)
    | right H => left H
    end.

  Proposition decidable_raa : ~ ~ P <-> P.
  Proof.
    split.
    - destruct (decide P) as [H|H]; tauto.
    - tauto.
  Qed.

  Context {Q} {DQ: Decidable Q}.

  Notation cases := ltac:(destruct DP; destruct DQ; constructor; tauto)
                           (only parsing).

  Global Instance and_decidable : Decidable (P /\ Q) := cases.
  Global Instance or_decidable : Decidable (P \/ Q) := cases.
  Global Instance impl_decidable : Decidable (P -> Q) := cases.

End decidable_connectives.

(** Making this an instance confuses the proof search. *)
Proposition decidable_transfer {P} {D: Decidable P} {Q} (H: Q <-> P) : Decidable Q.
Proof.
  destruct D; [left|right]; tauto.
Defined.

(** Presumably, in coq-hott this could be an actual instance of Proper. *)
Proposition decide_proper
            {P Q}
            {DP: Decidable P}
            {DQ: Decidable Q}
            (H: P <-> Q)
            {X} (x x':X) :
  (if decide P then x else x') = (if decide Q then x else x').
Proof.
  destruct (decide P) as [Hp|Hp];
    destruct (decide Q) as [Hq|Hq];
    reflexivity || tauto.
Qed.

Proposition decide_true
          {P} {DP: Decidable P} (H: P) {X} (x x':X) :
  (if decide P then x else x') = x.
Proof.
  decided H. reflexivity.
Qed.

Instance exists_true_decidable
    (b: bool) (P: Is_true b -> Prop) {DP: forall Hb: b, Decidable (P Hb)} :
    Decidable (exists Hb, P Hb).
Proof.
  destruct b.
  - specialize (DP I).
    destruct (decide (P I)) as [H|H].
    + left. exists I. exact H.
    + right. intros [Hb Hp]. destruct Hb. exact (H Hp).
  - right. intros [Hb _]. exact Hb.
Qed.

Proposition eqdec_eqrefl {X} {HED: EqDec X} (x:X) : HED x x = left eq_refl.
Proof.
  destruct (HED x x) as [H|H].
  - f_equal. apply uip.
  - congruence.
Qed.

(** ** Options *)

Derive NoConfusion for option.

Goal forall {X} (x y: X) (H: Some x = Some y), x = y.
Proof. intros ? ? ?. exact noConfusion_inv. Qed.

Instance option_eqdec {A} {Ha: EqDec A} : EqDec (option A).
Proof.
  eqdec_proof. (* Tactic in Coq-Equations *)
Defined.

Definition is_some {X} (ox: option X) : bool := as_bool ox.

Coercion is_some : option >-> bool.

Instance is_some_decidable {X} (ox: option X) : Decidable ox.
Proof. apply is_true_decidable. Defined.

Instance is_none_decidable {X} (ox: option X) : Decidable (ox = None).
Proof. destruct ox as [x|]; [right|left]; congruence. Defined.

Proposition some_is_some {X} (x: X) : Some x.
Proof. exact true_is_true. Qed.

Proposition none_is_false {X} : @None X -> False.
Proof. exact false_is_false. Qed.

(** Shortcut *)
Definition none_rect {X Y} (H: @None X) : Y :=
  False_rect Y (none_is_false H).

Definition extract {X} {ox: option X} : ox -> X :=
  match ox return ox -> X with
  | Some x => fun _ => x
  | None => fun H => none_rect H
  end.

Proposition extract_some {X} (x: X) : extract (some_is_some x) = x.
Proof. reflexivity. Qed.

Lemma some_extract {X} {ox: option X} (H: ox) : Some (extract H) = ox.
Proof.
  destruct ox as [x|].
  - simpl. reflexivity.
  - exact (none_rect H).
Qed.

Proposition is_some_eq {X} {ox: option X} {x: X} : ox = Some x -> ox.
Proof. intro H. rewrite H. reflexivity. Qed.

Proposition extract_is_some_eq {X} {ox: option X} {x: X} (H: ox = Some x) : extract (is_some_eq H) = x.
Proof. subst ox. reflexivity. Qed.

Proposition extract_unique {X} {ox: option X} (H H': ox) : extract H = extract H'.
Proof.
  destruct ox as [x|].
  - reflexivity.
  - exact (none_rect H).
Qed.

(* ** Decidable match statements *)

Instance match_decide_decidable {P: Prop} {DP: Decidable P}
         (f: P -> Prop) {Df: forall H, Decidable (f H)}
         (g: not P -> Prop) {Dg: forall H, Decidable (g H)}:
  Decidable match decide P with
            | left H => f H
            | right H => g H
            end.
Proof.
  destruct (decide P) as [H|H].
  - apply Df.
  - apply Dg.
Defined.

Instance match_option_decidable {X}
         (f: X -> Prop) {Df: forall x, Decidable (f x)}
         (Q: Prop) {DQ: Decidable Q}
         {ox: option X} :
  Decidable match ox with
            | Some x => f x
            | None => Q
            end.
Proof.
  destruct ox as [x|].
  - apply Df.
  - exact DQ.
Defined.

(* ** Decidable predicates on integers *)

Instance nat_lt_decidable (x y: nat) : Decidable (x < y) := lt_dec x y.
Instance nat_le_decidable (x y: nat) : Decidable (x <= y) := le_dec x y.

Derive NoConfusion EqDec for comparison.

(** It follows that the comparison operators are decidable for [Z] and [N]. *)

Lemma bounded_decidable0 (P: nat -> Prop) {DP: forall x, Decidable (P x)} (n: nat) :
  {forall x, x < n -> P x} + {exists x, x < n /\ ~ P x}.
Proof.
  induction n as [|n IH].
  - left. lia.
  - destruct IH as [IH|IH].
    + destruct (DP n) as [H|H].
      * left.
        intros x H'.
        -- by_lia (x < n \/ x = n) as H''.
           destruct H'' as [H''|H''].
           ++ exact (IH x H'').
           ++ subst x. exact H.
      * right. exists n. split; [lia | exact H].
    + right. destruct IH as [x [Hx Hp]]. exists x. split; [lia | exact Hp].
Defined.

Instance bounded_all_decidable0 (P: nat -> Prop) {DP: forall x, Decidable (P x)} (n: nat) :
  Decidable (forall x, x < n -> P x).
Proof.
  destruct (bounded_decidable0 P n) as [H|H].
  - left. exact H.
  - right. intro H'. destruct H as [x [Hx Hp]].
    exact (Hp (H' x Hx)).
Qed.

Instance bounded_ex_decidable0 (P: nat -> Prop) {DP: forall x, Decidable (P x)} (n: nat) :
  Decidable (exists x, x < n /\ P x).
Proof.
  destruct (bounded_decidable0 (fun x => ~ P x) n) as [H|H].
  - right. intros [x [Hx Hp]]. exact (H x Hx Hp).
  - left.
    setoid_rewrite decidable_raa in H.
    exact H.
Qed.

Lemma bounded_ex_succ (P: nat -> Prop) n :
  (exists i, i < S n /\ P i) <-> P n \/ (exists i, i < n /\ P i).
Proof.
  split.
  - intros [i [Hi Hp]].
    by_lia (i = n \/ i < n) as H.
    destruct H.
    + destruct H. left. exact Hp.
    + right. exists i. split; assumption.
  - intros [H | [i [Hi Hp]]].
    + exists n. split.
      * lia.
      * exact H.
    + exists i. split.
      * lia.
      * exact Hp.
Qed.

(** Clearly, [N] has the same properties. *)

Local Open Scope N.

Instance bounded_all_decidable0' (P: forall (x:N), Prop) {DP: forall x, Decidable (P x)} (n: N) :
  Decidable (forall x, x < n -> P x).
Proof.
  (* TODO: Derive from results above instead. *)
  destruct (decide (forall y, (y < N.to_nat n)%nat -> P (N.of_nat y))) as [H|H]; [left|right].
  - intros x Hx. specialize (H (N.to_nat x)).
    rewrite Nnat.N2Nat.id in H.
    apply H, nat_compare_lt.
    rewrite <- Nnat.N2Nat.inj_compare.
    exact Hx.
  - intro H'. apply H. clear H.
    intros y Hy.
    apply H'.
    unfold N.lt.
    rewrite Nnat.N2Nat.inj_compare, Nnat.Nat2N.id.
    apply nat_compare_lt.
    exact Hy.
Defined.

(** We also have a slightly stronger property. *)

Instance bounded_all_decidable1
           (n: N) (P: forall (x: N), x < n -> Prop)
           {DP: forall x (H: x < n), Decidable (P x H)} : Decidable (forall x (H: x < n), P x H).
Proof. (* TODO: simplify? *)
  assert (forall x, Decidable (forall (H: x < n), P x H)) as D.
  - intros x.
    destruct (decide (x < n)) as [H|H].
    + destruct (DP x H) as [Hd|Hd].
      * left. intros H'. rewrite (uip H' H). assumption.
      * right. contradict Hd. apply (Hd H).
    + left. intros H'. contradict H. exact H'.
  - destruct (bounded_all_decidable0' (fun x => forall (H: x < n), P x H) n) as [H|H];
      [left|right]; firstorder.
Qed.

(** In order to prove the corresponding property for [nat], we seem to need
an axiom or a different definition of [nat.le] than the one in the current
standard library, cf. "Definitional Proof-Irrelevance without K" (2019). *)

Close Scope N.

(* TODO: Reformulate? *)
Lemma bounded_all_neg P {DP: forall (x:nat), Decidable (P x)} n :
  ~ (forall x, x < n -> P x) -> (exists x, x < n /\ ~ P x).
Proof.
  induction n; intro H.
  - exfalso. apply H. intros x Hx. exfalso. lia.
  - destruct (decide (P n)) as [Hd|Hd].
    + assert (~ forall x : nat, x < n -> P x) as Hnot.
      * intros Hno.
        apply H.
        intros x Hx.
        by_lia (x < n \/ x = n) as H0.
        destruct H0 as [H1|H2].
        -- apply Hno. exact H1.
        -- destruct H2. exact Hd.
      * specialize (IHn Hnot).
        destruct IHn as [x [Hx Hp]].
        exists x. split.
        -- lia.
        -- exact Hp.
    + exists n. split.
      * lia.
      * exact Hd.
Qed.

(* TODO: Are there better ways to do this? *)
Definition bounded_evidence
    P {DP: forall (x:nat), Decidable (P x)}
    n (H: exists x, x < n /\ P x) :
  { x: nat | x < n /\ P x }.
Proof.
  induction n.
  - exfalso. destruct H as [x [H1 H2]]. lia.
  - specialize (DP n). destruct DP as [H1|H2].
    + refine (exist _ n _). split; [lia | exact H1].
    + assert (exists (x: nat), x < n /\ P x) as He.
      * destruct H as [x [Hsn Hx]].
        exists x. split; [ | exact Hx ].
        by_lia (x < n \/ x = n) as Hn.
        destruct Hn as [Hn|Hn]; [ exact Hn | ].
        destruct Hn. exfalso. exact (H2 Hx).
      * specialize (IHn He).
        destruct IHn as [x [IH1 IH2]].
        refine (exist _ x _).
        split; [lia | exact IH2].
Defined.

Section LastWitness_section.

  Context
    (P: nat -> Prop)
    {DP: forall i, Decidable (P i)}.

  Inductive LastWitness n :=
  | SomeWitness
    {i:nat} (Hi: i<n) (Hp: P i)
    (Ho: forall (j: nat), i<j<n -> ~ P j)
  | NoWitness
    (Ho: forall i, i<n -> ~ P i).

  Equations? findLast n : LastWitness n :=
    findLast 0 := NoWitness 0 _;
    findLast (S n) :=
      match decide (P n) with
      | left Hp => @SomeWitness _ n (Nat.lt_succ_diag_r n) Hp _
      | right Hp' =>
        match findLast n with
        | SomeWitness _ Hi Hp Ho => @SomeWitness _ _ _ Hp _
        | NoWitness _ _ => @NoWitness _ _
        end
      end.
  Proof.
    1,2: lia.
    - by_lia (j < n \/ j = n) as Hjn. destruct Hjn as [Hjn|Hjn].
      + apply Ho. lia.
      + subst j. exact Hp'.
    - by_lia (i < n \/ i = n) as Hin. destruct Hin as [Hin|Hin].
      + apply n0. exact Hin.
      + subst i. exact Hp'.
  Qed.

End LastWitness_section.

(** ** Vectors and lists *)

Close Scope list_scope.

(** This opens [vector_scope]. *)
Export VectorNotations.

Notation vector := (Vector.t).

Proposition vector_map_equation_1 {A B} (f: A -> B) : Vector.map f [] = [].
Proof.
  reflexivity.
Qed.

Proposition vector_map_equation_2 {A B} (f: A -> B) (x: A) {n} (u: vector A n) : Vector.map f (x :: u) = f x :: Vector.map f u.
Proof.
  reflexivity.
Qed.

Hint Rewrite @vector_map_equation_1 : map.
Hint Rewrite @vector_map_equation_2 : map.

Global Opaque Vector.map.

Proposition rew_cons [X m n x] [u: vector X m] [HS: S m = S n] (H: m = n) :
  rew HS in (x :: u) = x :: rew H in u.
Proof.
  destruct H. revert HS. apply EqDec.UIP_K. reflexivity.
Qed.

Export ListNotations.
Open Scope list_scope. (* Partly shadows vector_scope. *)

Derive Signature NoConfusion NoConfusionHom for vector.

Instance vector_eqdec {A} {Ha: EqDec A} {n} : EqDec (vector A n).
Proof. eqdec_proof. Defined.

Arguments Vector.nil {A}.
Arguments Vector.cons : default implicits.

Lemma to_list_equation_1 {A} : to_list []%vector = [] :> list A.
Proof. reflexivity. Qed.

Lemma to_list_equation_2 {A n} (x: A) (u: vector A n) : to_list (x :: u)%vector = x :: (to_list u).
Proof. reflexivity. Qed.

Hint Rewrite
     @to_list_equation_1
     @to_list_equation_2 : to_list.

Lemma to_list_injective {A n} (u v: vector A n) : to_list u = to_list v -> u = v.
Proof.
  induction n.
  - dependent elimination u.
    dependent elimination v.
    reflexivity.
  - dependent elimination u as [(x :: u)%vector].
    dependent elimination v as [(y :: v)%vector].
    simp to_list. intro Heq.
    f_equal; [|apply (IHn u v)]; congruence.
Qed.

Lemma length_to_list {A n} (v: vector A n) : length (to_list v) = n.
Proof.
  depind v.
  - reflexivity.
  - simp to_list. simpl length. rewrite IHv. reflexivity.
Qed.

Lemma to_list_action {X m n} (u: vector X m) (v: vector X n) :
  to_list (u ++ v)%vector = ((to_list u) ++ (to_list v))%list.
Proof.
  induction m.
  - now dependent elimination u.
  - dependent elimination u as [Vector.cons(n:=m) x u].
    simp to_list.
    rewrite <- append_comm_cons.
    setoid_rewrite to_list_equation_2. (* ! *)
    rewrite IHm.
    rewrite <- app_comm_cons.
    reflexivity.
Qed.

(* Coercion Vector.to_list : vector >-> list. *)

(** ** Relations *)

#[global] Hint Mode Reflexive ! - : typeclass_instances.
#[global] Hint Mode Symmetric ! - : typeclass_instances.
#[global] Hint Mode Transitive ! - : typeclass_instances.
#[global] Hint Mode Equivalence ! - : typeclass_instances.

Section relation_section.

  Context {X} {R: relation X}.

  (* Making this global would likely ruin proof search. *)
  Instance eq_subrelation {HR: Reflexive R} : subrelation eq R.
  Proof. intros x x' Hx. subst x. reflexivity. Qed.

End relation_section.

(** *** Inverse image **)

Section irel_section.

  Context {X Y} (f: X -> Y) (R: relation Y).

  Definition irel : relation X := fun x x' => R (f x) (f x').

  Instance irel_reflexive {HR: Reflexive R} : Reflexive irel.
  Proof. unfold irel. intros x. reflexivity. Qed.

  Instance irel_symmetric {HR: Symmetric R} : Symmetric irel.
  Proof. unfold irel. intros x y H. symmetry. exact H. Qed.

  Instance irel_transitive {HR: Transitive R} : Transitive irel.
  Proof. unfold irel. intros x y z Hxy Hyz. transitivity (f y); assumption. Qed.

  Instance irel_equivalence {HR: Equivalence R} : Equivalence irel.
  Proof. split; typeclasses eauto. Qed.

End irel_section.

(** ** Various *)

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

Proposition Nat2N_inj_pow (m n : nat) : (m ^ n)%nat = (m ^ n)%N :> N.
Proof.
  induction n; [ reflexivity | ].
  rewrite
    Nnat.Nat2N.inj_succ,
    N.pow_succ_r',
    Nat.pow_succ_r',
    Nnat.Nat2N.inj_mul,
    IHn.
  reflexivity.
Qed.

Proposition inj_succ (n: nat) : S n = Z.succ n :> Z.
Proof.
  now rewrite Nnat.Nat2N.inj_succ, N2Z.inj_succ.
Qed.

Proposition Nat2N_inj_lt {m n: nat}: (m < n)%N <-> (m < n)%nat.
Proof.
  setoid_rewrite N2Z.inj_lt.
  setoid_rewrite nat_N_Z.
  symmetry.
  apply Nat2Z.inj_lt.
Qed.

Corollary N2Nat_inj_lt {m n: N} :
  (N.to_nat m < N.to_nat n)%nat <-> (m < n)%N.
Proof.
  setoid_rewrite <- Nnat.N2Nat.id at 3 4.
  setoid_rewrite Nat2N_inj_lt.
  reflexivity.
Qed.

(** Defines [∘] *)
Open Scope program_scope.

#[global] Hint Mode Proper ! ! - : typeclass_instances.
#[global] Hint Mode Proper ! - ! : typeclass_instances.

(* TODO: Why is this needed? *)
Instance not_proper_impl : Proper (iff ==> impl) not.
Proof.
  intros p p' Hp H. tauto.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 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/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export chalts.
Require Export sequents_tacs2.
Require Export cequiv_props.
Require Export subst_tacs.
Require Export per_props_equality.
Require Export per_can.
Require Export computation_apply.
Require Export cequiv_props2.
Require Export list. (* why? *)

(* [18] ============ APPLY EXCEPTION CASES ============ *)

(*   H |- a = b in T

     By applyExceptionCases

     H |- isexc(t u)
     H, x : halts(t) |- a = b in T
     H, x : isexc(t) |- a = b in T
     H |- t in Base

        ( note: we don't need  H |- u in Base )
 *)
Definition rule_apply_exception_cases {o}
           (H : barehypotheses)
           (a b T t u: @NTerm o)
           (x: NVar) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality a b T)))
    [ mk_baresequent H (mk_conclax (mk_isexc (mk_apply t u))),
      mk_baresequent (snoc H (mk_hyp x (mk_halts t)))
                     (mk_conclax (mk_equality a b T)),
      mk_baresequent (snoc H (mk_hyp x (mk_isexc t)))
                     (mk_conclax (mk_equality a b T)),
      mk_baresequent H (mk_conclax (mk_member t mk_base))
    ]
    [].

Lemma rule_apply_exception_cases_true {o} :
  forall lib  (a b T t u : NTerm),
  forall x : NVar,
  forall H : @barehypotheses o,
    rule_true lib (rule_apply_exception_cases H  a b T t u x).
Proof.
  unfold rule_apply_exception_cases, rule_true, closed_type_baresequent,
                closed_extract_baresequent; simpl.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  rename Hyp3 into hyp4.
  destseq; allsimpl; proof_irr; GC.

  assert (closed_extract H (mk_conclax (mk_equality a b T))) as cs.
  clear hyp1 hyp2 hyp3 hyp4.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars u)
          # !LIn x (free_vars T)
          # !LIn x (free_vars b)
          # !LIn x (free_vars a)
          # !LIn x (vars_hyps H)) as vhyps.

  clear hyp1 hyp2 hyp3 hyp4.
   dwfseq.
  sp; GC;
  try (complete (discover; allapply @subset_hs_vars_hyps; sp)).

  destruct vhyps as [ nxu vhyps ].
  destruct vhyps as [ nxT vhyps ].
  destruct vhyps as [ nxb vhyps ].
  destruct vhyps as [ nxa nxH ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  exrepnd.

  lsubst_tac.
  allrw @tequality_mkc_isexc.
  allrw <- @member_isexc_iff.
  applydup hyp0 in hyp1.
  clear hyp0.
  rw <- @member_equality_iff.
  rw @tequality_mkc_equality.

  apply apply_raises_exceptionc_two_cases in hyp1.
  repndors; exrepnd.

  - (* t raises exception *)
    vr_seq_true in hyp3.
    pose proof (hyp3 (snoc s1 (x,mkc_axiom)) (snoc s2 (x,mkc_axiom))) as hyp.
    clear hyp3.
    repeat (autodimp hyp hyp').

    { apply hyps_functionality_snoc2; simpl; auto;[].
      introv equ' sim'.
      lsubst_tac.
      apply tequality_mkc_isexc.
      split; intro h; auto. GC;[].

      vr_seq_true in hyp4.

      pose proof (hyp4 s1 s') as hyp; clear hyp4.
      repeat (autodimp hyp hyp');[].
      exrepnd.
      lsubst_tac.
      apply tequality_mkc_member_base in hyp0.
      apply cequiv_stable in hyp0.
     eapply raises_exceptionc_preserves_cequivc;[exact hyp0|]; auto.
    }

    { assert (wf_term (mk_isexc t))as wit.
      { apply wf_isexc; auto. }
      assert (cover_vars (mk_isexc t) s1) as cvit.
      { apply cover_vars_isexc; auto. }
      sim_snoc.
      dands; auto.
      lsubst_tac.
      apply member_isexc_iff; auto.
    }

    exrepnd.
    lsubst_tac.
    rw <- @member_equality_iff in hyp3.
    rw @tequality_mkc_equality in hyp0; repnd.
    sp.

  - (* t has a value,  so we use hyp2 *)
    vr_seq_true in hyp2.
     pose proof (hyp2 (snoc s1 (x,mkc_axiom)) (snoc s2 (x,mkc_axiom))) as hyp.
    clear hyp2.
    repeat (autodimp hyp hyp').
     { (* Hyp Functionality *)
      apply hyps_functionality_snoc2; simpl; auto.
      -  introv equ' sim'.
        lsubst_tac.
     (* because by hyp4, t in Base,  halts(t) is well formed *)

      vr_seq_true in hyp4.

      pose proof (hyp4 s1 s') as hyp; clear hyp4.
      repeat (autodimp hyp hyp');[].
      exrepnd.
      lsubst_tac.
      apply tequality_mkc_member_base in hyp0.
      apply cequiv_stable in hyp0.
      generalize_lsubstc_terms t1.
      generalize_lsubstc_terms t2.
       apply tequality_mkc_halts.
      split; introv hlts.
      apply cequivc_preserves_chaltsc in hyp0; auto.
      apply cequivc_sym in hyp0.
      apply cequivc_preserves_chaltsc in hyp0; auto.
      }
    { (* Similarity *)
      assert (wf_term (mk_halts t)) as wit. apply wf_halts; auto.
      assert (cover_vars (mk_halts t) s1) as cvit.
      { apply cover_vars_halts; dands; auto.
      }
      sim_snoc.
      dands; auto.
      lsubst_tac.
      apply equality_in_halts.
      sp; spcast; try (apply computes_to_valc_refl); eauto 3 with slow.
    }

   { (* Functionality and Truth *)
    exrepnd.
    lsubst_tac.
    rw <- @member_equality_iff in hyp2.
    rw @tequality_mkc_equality in hyp0; repnd.
    sp.
   }
Qed.


Require Import Fiat.Common Fiat.Computation Fiat.ADT Coq.Sets.Ensembles Fiat.ADTRefinement Fiat.ADTRefinement.Refinements.ADTRepInv.

Generalizable All Variables.
Set Implicit Arguments.

Open Scope comp_scope.

Section addCache.

  (* A cache simply adds a new value to an ADT's representation [rep]. *)

  Variable rep : Type.
  Variable cacheTyp : Type.

  Record cachedRep :=
    { origRep : rep;
      cachedVal : cacheTyp
    }.

  Variable cacheSpec : rep -> cacheTyp -> Prop.

  (* A representation with an added value [nr] is related to any representation [or]
     when the cached value [cachedVal] satisfies the original [cacheSpec] and
     the original representation of [nr] is equal to [or]. *)

  Definition cachedRep_AbsR (or : rep) (nr : cachedRep) :=
    or = origRep nr /\ cacheSpec or (cachedVal nr).

  (* To add a cache, we update an ADT's methods to include cached values.
       We first run the old method to obtain the original result [or],
       then we add a Pick implementation of a [cacheVal]
       that satisfies our specification [cacheSpec] to the result. *)

  Fixpoint addCacheToMethod'
    (Dom : list Type)
    (Cod : option Type)
    (oldMethod : methodType' rep Dom Cod)
    : methodType' cachedRep Dom Cod :=
    match Dom return methodType' rep Dom Cod
                     -> methodType' cachedRep Dom Cod with
    | nil => match Cod return methodType' rep nil Cod
                                -> methodType' cachedRep nil Cod with
             | Some C => fun oldMethod =>
                           or <- oldMethod;
                           cv <- {cv | cacheSpec (fst or) cv};
                           ret ({| origRep := (fst or);
                                   cachedVal := cv |}, snd or)
               | None => fun oldMethod =>
                           or <- oldMethod;
                           cv <- {cv | cacheSpec or cv};
                           ret {| origRep := or;
                                  cachedVal := cv |}
               end
    | cons D Dom' => fun oldMethod (d : D) => addCacheToMethod' Dom' Cod (oldMethod d)
    end oldMethod.

  Definition addCacheToMethod
             {Dom : list Type}
             {Cod : option Type}
             (oldMethod : methodType rep Dom Cod)
             (nr : cachedRep)
    : methodType' cachedRep Dom Cod :=
    addCacheToMethod' Dom Cod (oldMethod (origRep nr)).

  Lemma refine_addCacheToMethod
        {Dom : list Type}
        {Cod : option Type}
        (oldMethod : methodType rep Dom Cod)
  : @refineMethod rep cachedRep cachedRep_AbsR _ _
                  oldMethod
                  (addCacheToMethod oldMethod).
  Proof.
    unfold refineMethod, addCacheToMethod, methodType,
    cachedRep_AbsR, refine in *; intros; intuition; subst.
    induction Dom; simpl.
    - destruct Cod.
      + unfold cachedRep_AbsR in *; intuition; subst.
        repeat (f_equiv; intro).
        computes_to_inv; subst.
        repeat computes_to_econstructor.
        simpl; split; eauto.
      + unfold cachedRep_AbsR in *; intuition; subst.
        repeat (f_equiv; intro).
        computes_to_inv; subst.
        repeat computes_to_econstructor.
        simpl; split; eauto.
    - intros; eapply (IHDom (fun r_n => oldMethod r_n d)).
  Qed.

  (* For use in honing tactics. *)
  Lemma refine_addCacheToMethod_step
        {Dom : list Type}
        {Cod : option Type}
        (oldMethod : methodType rep Dom Cod)
        (newMethod : methodType cachedRep Dom Cod)
    : @refineMethod_eq cachedRep _ _
                     (addCacheToMethod oldMethod)
                     newMethod ->
      @refineMethod rep cachedRep cachedRep_AbsR _ _
                    oldMethod
                    newMethod.
  Proof.
    intros; eapply refineMethod_eq_trans;
    eauto using refine_addCacheToMethod.
  Qed.

  (* A similar approach works for constructors. *)
  Fixpoint addCacheToConstructor
           {Dom : list Type}
    (oldConstructor : constructorType rep Dom)
    : constructorType cachedRep Dom :=
    match Dom return constructorType rep Dom
                     -> constructorType cachedRep Dom with
    | nil => fun oldConstructor =>
               or <- oldConstructor;
               cv <- {cv | cacheSpec or cv};
               ret {| origRep := or;
                      cachedVal := cv |}
    | cons D Dom' => fun oldConstructor (d : D) => @addCacheToConstructor Dom' (oldConstructor d)
    end oldConstructor.

  Lemma refine_addCacheToConstructor
        (Dom : list Type)
        (oldConstr : constructorType rep Dom)
  : @refineConstructor rep cachedRep cachedRep_AbsR _
                  oldConstr
                  (addCacheToConstructor oldConstr).
  Proof.
    unfold cachedRep_AbsR, refine in *; intros; intuition; subst.
    induction Dom; simpl.
    - repeat (f_equiv; intro).
      computes_to_inv; subst.
      repeat computes_to_econstructor; eauto.
    - intros; eapply IHDom.
  Qed.

  (* For use in honing tactics. *)
  Lemma refine_addCacheToConstructor_step
        (Dom : list Type)
        (oldConstr : constructorType rep Dom)
        (newConstr : constructorType cachedRep Dom)
    : refineConstructor_eq _ (addCacheToConstructor oldConstr) newConstr
      -> @refineConstructor rep cachedRep cachedRep_AbsR _
                  oldConstr newConstr.
  Proof.
    eapply refineConstructor_eq_trans;
    eauto using refine_addCacheToConstructor.
  Qed.

  (* We can refine an ADT using the default caching implementations
     provided by [absMutatorMethod] and [absObserverMethod]. *)
  Lemma refine_addCacheToADT
        Sig
        oldConstrs oldMeths :
    refineADT
      (@Build_ADT Sig rep oldConstrs oldMeths)
      (@Build_ADT Sig cachedRep
                  (fun idx => addCacheToConstructor (oldConstrs idx))
                  (fun idx => addCacheToMethod (oldMeths idx))).
  Proof.
    eapply refineADT_Build_ADT_Rep;
    eauto using refine_addCacheToConstructor,
    refine_addCacheToMethod.
  Qed.

  (* After caching, we can resolve [Pick]s of the new
   representation by showing how to build the cache. *)
  Lemma refine_pick_cachedRep
  : forall or,
      refine {nr | cachedRep_AbsR or nr}
             (cv <- {cv | cacheSpec or cv};
              ret {| origRep := or;
                     cachedVal := cv |}).
  Proof.
    unfold refine; intros or v ComputesTo_v;
    computes_to_inv; subst; econstructor;
    unfold cachedRep_AbsR; simpl; intuition.
  Qed.

End addCache.


Require Import Coq.Lists.List.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.Notations.

Inductive LetInM : Type -> Type :=
| ret {T} (v : T) : LetInM T
| let_in {A B} (v : A) (f : A -> LetInM B) : LetInM B.

Bind Scope letinm_scope with LetInM.
Delimit Scope letinm_scope with letinm.
Notation "'mlet' x := y 'in' f" := (let_in y (fun x => f%letinm)) : letinm_scope.

Fixpoint denote {A} (x : LetInM A) : A :=
  match x with
  | ret _ v => v
  | let_in T A v f => dlet x := v in @denote A (f x)
  end.

Fixpoint bind {A B} (v : LetInM A) : forall (f : A -> LetInM B), LetInM B
  := match v in LetInM A return (A -> _) -> _ with
     | ret T v => fun f => f v
     | let_in A B v g => fun f => let_in v (fun x => bind (g x) f)
     end.
Notation "x <- y ; z" := (bind y%letinm (fun x => z%letinm)) : letinm_scope.

Definition under_lets {A B} (v : LetInM A) : forall (f : A -> LetInM B), LetInM B
  := match v in LetInM A return (A -> _) -> _ with
     | ret T v => fun f => f v
     | let_in A B v g => fun f => let_in v (fun x => bind (g x) f)
     end.

Definition lift {A B} (f : A -> B) : LetInM A -> LetInM B
  := fun x => under_lets x (fun y => ret (f y)).
Definition lift2 {A B C} (f : A -> B -> C) : LetInM A -> LetInM B -> LetInM C
  := fun x y => under_lets x (fun x' => under_lets y (fun y' => ret (f x' y'))).

Create HintDb push_denote discriminated.
Global Hint Extern 1 => progress autorewrite with push_denote in * : push_denote.

Ltac push_denote_step :=
  first [ progress simpl @denote in *
        | progress autorewrite with push_denote in *
        | progress autounfold with push_denote in * ].
Ltac push_denote := repeat push_denote_step.

Local Ltac t_step :=
  first [ push_denote_step
        | reflexivity
        | progress simpl in *
        | progress unfold Let_In in *
        | solve [ auto ]
        | congruence ].
Local Ltac t := repeat t_step.

Lemma denote_bind A B v f : denote (@bind A B v f) = denote (f (denote v)).
Proof. induction v; t. Qed.
Hint Rewrite denote_bind : push_denote.

Lemma denote_under_lets A B v f : denote (@under_lets A B v f) = denote (f (denote v)).
Proof. induction v; t. Qed.
Hint Rewrite denote_under_lets : push_denote.

Lemma denote_lift A B (f : A -> B) v : denote (lift f v) = f (denote v).
Proof. unfold lift; t. Qed.
Hint Rewrite denote_lift : push_denote.

Lemma denote_lift2 A B C (f : A -> B -> C) x y : denote (lift2 f x y) = f (denote x) (denote y).
Proof. unfold lift2; t. Qed.
Hint Rewrite denote_lift2 : push_denote.

Module Import List.
  Definition app {A} := lift2 (@List.app A).
  Definition nil {A} := ret (@nil A).
  Definition cons {A} x := lift (@cons A x).
  Hint Unfold app nil cons : push_denote.

  Definition flat_map {A B} (f : A -> LetInM (list B)) (ls : LetInM (list A))
    := under_lets
         ls
         (fix flat_map (l : list A) : LetInM (list B)
          := match l with
             | Lists.List.nil => nil
             | x :: t => app (f x) (flat_map t)
             end).

  Lemma denote_flat_map A B f ls : denote (@flat_map A B f ls) = Lists.List.flat_map (fun x => denote (f x)) (denote ls).
  Proof. unfold flat_map; t; induction (denote ls); t. Qed.
  Hint Rewrite denote_flat_map : push_denote.
End List.

Infix "++" := List.app : letinm_scope.
Infix "::" := List.cons : letinm_scope.


(*|
######################################################################
Coq: Recursive Smart Constructors and Sigma types, how to avoid axioms
######################################################################

:Link: https://proofassistants.stackexchange.com/q/1048
|*)

(*|
Question
********

I am using a recursive smart constructor to return a sigma type, which
includes the property that the type was constructed in a smart way.
This is very basic compared to the smart constructors and number of
properties I tend to have, but I am already running into problems. I
was wondering if there is a better way to work with smart constructors
and sigma properties. Here is my current example with the problem I
ran into.

We want to represent some nested function calls for a very restricted
language, for example:

::

    and(lt(3, 5), contains("abcd", "bc"))

We represent the parsed ast, like so:
|*)

Inductive Func : Type :=
  mkFunc :
    forall
      (name : nat)
      (params : list Func)
      (hash : nat),
      Func.

(*|
We are still using ``nat`` instead of string to represent the names,
please ignore this, this is just for temporary simplicity. The
``hash`` field is important, because it is used to efficiently compare
functions calls, so that we can reorder and simplify. For example:

- ::

      and(lt(3, 5), contains("abcd", "bc")) => and(contains("abcd",
      "bc"), lt(3, 5))

- ::

      and(lt(3, 5), lt(3, 5)) => lt(3, 5)

- ::

      or(and(lt(3, 5), contains("abcd", "bc")), and(contains("abcd",
      "bc"), lt(3, 5))) => and(contains("abcd", "bc"), lt(3, 5))

For this hash field to mean anything, it needs an associated property
that it was constructed using a smart constructor:
|*)

Require Import List. (* .none *)
Import ListNotations. (* .none *)
Definition get_params (x : Func) : list Func :=
  match x with
  | mkFunc _ params _ => params
  end.

Definition get_hash (x : Func) : nat :=
  match x with
  | mkFunc _ _ hash => hash
  end.

Definition hash_per_elem (state : nat) (x : nat) : nat :=
  31 * state + x.

Fixpoint hash_from_func (f : Func) : nat :=
  match f with
  | mkFunc name params _ =>
      let name_hashed := 31 * 17 * name in
      let param_hashes := map hash_from_func params in
      fold_left hash_per_elem param_hashes name_hashed
  end.

Inductive IsSmart (f : Func) : Prop :=
| isSmart : forall
    (name : nat)
    (params : list Func)
    (hash : nat)
  , f = mkFunc name params hash
    -> hash = hash_from_func f
    -> Forall IsSmart params
    -> IsSmart f.

Ltac destructIsSmart S :=
  let Name := fresh "name" in
  let Params := fresh "params" in
  let Hash := fresh "hash" in
  let Feq := fresh "feq" in
  let Heq := fresh "heq" in
  let HSmarts := fresh "Hsmarts" in
  destruct S as [Name Params Hash Feq Heq HSmarts].

Definition SmartFunc := { func | IsSmart func }.

Ltac destructSmartFunc SF :=
  let F := fresh "f" in
  let S := fresh "s" in
  destruct SF as [F S];
  destructIsSmart S.

Definition get_func (x : SmartFunc) : Func :=
  match x with
  | exist _ f p => f
  end.

Definition get_shash (x : SmartFunc) : nat :=
  match x with
  | exist _ f p => get_hash f
  end.

Definition hash_from_params (hname : nat) (params : list Func): nat :=
  let param_hashes := map hash_from_func params in
  fold_left hash_per_elem param_hashes hname.

Definition hash_from_sparams (hname : nat) (sparams : list SmartFunc): nat :=
  let param_hashes := map get_shash sparams in
  fold_left hash_per_elem param_hashes hname.

Lemma hash_from_params_is_hash_from_sparams:
  forall (hname : nat) (sparams : list SmartFunc),
    hash_from_sparams hname sparams
    =
      hash_from_params hname (map get_func sparams).
Proof.
  (* For the actual proof see https://github.com/katydid/proofs/issues/10 *)
Admitted.

Definition forall_smart_from_sparams (sparams : list SmartFunc) :
  Forall IsSmart (map get_func sparams).
  (* For the actual proof see https://github.com/katydid/proofs/issues/10 *)
Admitted.

Definition smart_from_sparam (s : SmartFunc) : IsSmart (get_func s).
  (* For the actual proof see https://github.com/katydid/proofs/issues/10 *)
Admitted.

Definition mkIsSmart (name : nat) (sparams : list SmartFunc):
  IsSmart
    (mkFunc
       name
       (map get_func sparams)
       (hash_from_sparams (31 * 17 * name) sparams)
    ).
  (* For the actual proof see https://github.com/katydid/proofs/issues/10 *)
Admitted.

Definition mkSmartFunc (name : nat) (sparams : list SmartFunc) : SmartFunc :=
  exist
    _
    (mkFunc
       name
       (map get_func sparams)
       (hash_from_sparams
          (31 * 17 * name)
          sparams
       )
    )
    (mkIsSmart
       name
       sparams
    ).

(*
We can reconstruct our list of SmartFunc again from our list of params
and the Forall property.
*)

Fixpoint get_smart_params'
         (params : list Func)
         (smarts : Forall IsSmart params)
  : list SmartFunc.
  destruct params as [|p ps].
  - exact [].
  - pose proof (Forall_inv smarts) as smart.
    apply Forall_inv_tail in smarts.
    exact (
        (exist _ p smart)
          :: (get_smart_params' ps smarts)
      ).
Defined.

(* But when we try to retreive our forall property about params from
our SmartFunc then we get the error. *)

Theorem get_smart_params (s : SmartFunc) : { params | Forall IsSmart params }.
  destruct s as [f is].
  Fail destruct is. (* .fails .unfold .in .messages *)

(*|
I have seen that it is possible to use
``constructive_indefinite_description``, but this uses an axiom. I was
wondering if there was a way to better work with recursive smart
constructors and sigma types to avoid needing axioms?

Note in `this GitHub issue
<https://github.com/katydid/proofs/issues/10>`__ you will find copy
and paste-able code, that you can play around with, if that helps.
|*)

(*|
Answer (Li-yao Xia)
*******************

You can first instantiate the proof-relevant part of the goal using
``exists``, leaving you with a goal in ``Prop`` so you can then
destruct hypotheses in ``Prop``.
|*)

  exists (get_params f). (* or: apply (exist _ (get_params f)). *)
  destruct is.
Abort. (* .none *)

(*|
Answer
******

Some simpler examples to show when we can and cannot destruct a ``Prop``.
=========================================================================

We can't destruct a ``Prop``, when our goal contains something in ``Set``:
--------------------------------------------------------------------------
|*)

Theorem case_and_point_1 : forall (m : nat), m > 0 -> { n | n > 0 }.
Proof.
  intros m H.
  Fail induction H.
  (*
    We can't destruct a Prop, when our goal contains something in Set.
   *)
  exists 1.
  (*
    Now we only need to return a Prop (1 > 0), which means we can
    destruct a Prop.
   *)
  induction H.
Abort.

(*|
We can't destruct a ``Prop``, when our goal is in ``Set``:
----------------------------------------------------------
|*)

Theorem case_and_point_2 : 3 > 2 -> nat.
Proof.
  intros H.
  Fail induction H.
  (*
    We can't destruct a Prop, when our goal is in Set.
   *)
  exact 1.
Qed.

(*|
We can destruct a ``Prop``, when our goal does not contain something in ``Set``, even if it is in ``Type``:
-----------------------------------------------------------------------------------------------------------
|*)

Inductive myType : Type :=
  mkMyType: myType.

Inductive myPropOnType (t : myType) : Prop :=
  isMyPropOnType: myPropOnType t.

Theorem case_and_point_3:
  3 > 2 -> { t | myPropOnType t }.
Proof.
  intros H.
  (*
    We can destruct a Prop, when our goal does not contain something
    in Set, even if it is in Type.
   *)
  induction H.
Abort.

(*|
We can't destruct a ``Prop``, when our goal contains something in ``Set``:
--------------------------------------------------------------------------
|*)

Inductive mySet : Set :=
  mkMySet : mySet.

Inductive myPropOnSet (s : mySet) : Prop :=
  isMyPropOnSet: myPropOnSet s.

Theorem case_and_point_4 : 3 > 2 -> { s | myPropOnSet s }.
Proof.
  intros H.
  (*
    We can't destruct a Prop, when our goal contains something in Set:
   *)
  Fail induction H.
Abort.

(*|
We can destruct a ``Prop``, if it is guaranteed to only return a ``Prop``.
--------------------------------------------------------------------------
|*)

Theorem case_and_point_6 : 3 > 2 /\ 1 > 0 -> nat.
Proof.
  intros H.
  (*
    We can destruct a Prop, if it is guaranteed to only return a Prop.
    This works for conjunction, which is made up of two props, but
    will fail for Forall, which can possibly destruct to the empty
    list, which is in Set.
   *)
  destruct H as [H0 H1].
  Fail destruct H0.
  exact 1.
Qed.

(*|
We can use theorems to destruct a ``Prop`` other ``Prop``\ s.
-------------------------------------------------------------
|*)

Lemma seven : 3 > 2 /\ 1 > 0 -> 7 = 7.
Admitted.

Theorem case_and_point_7 : 3 > 2 /\ 1 > 0 -> nat.
Proof.
  intros H.
  (*
    We can use theorems to destruct a Prop other Props.
   *)
  apply seven in H.
Abort.