Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.
(** TODO(mario): After the fixes below, none of these
 ** imports will be necessary.
 **)
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Lambda.ExprD.

(** Interface for semi-deciders (that use the RelDec typeclass)
**)
Section SemiDec.

  Variable T : Type.
  Variable equ : T -> T -> Prop.
  Variable SD : RelDec equ.

  Class RelDecSemiOk (SD : RelDec equ) : Prop :=
  { semi_dec_ok : forall (x y : T), rel_dec x y = true -> equ x y
  }.

  Section RelDec.

    Variable RD : RelDec equ.
    Variable RDC : RelDec_Correct RD.

    Instance RelDecSemiOk_RelDec : RelDecSemiOk RD :=
    { semi_dec_ok :=
        fun x y => proj1 (@rel_dec_correct T equ RD RDC x y) }.
  End RelDec.
End SemiDec.

(** TODO(mario): This should be moved to SymI.v
 **)
Section SemiDec_RSym.

  (* need to have a typ *)
  Variable typ : Set.
  Variable typ_Rt : RType typ.
  Variable func : Set.
  Variable Rs : @RSym typ typ_Rt func.
  Variable RsOk : RSymOk Rs.

  Instance RelDecSemi_RSym : @RelDec func eq :=
  { rel_dec x y :=
      match @sym_eqb _ _ _ Rs x y with
      | Some b => b
      | _ => false
      end
  }.

  Instance RelDecSemiOk_Rsym : RelDecSemiOk func _ RelDecSemi_RSym.
  Proof.
    destruct RsOk.
    constructor. intros.
    specialize (sym_eqbOk x y).
    unfold rel_dec in H. simpl in H.
    destruct (sym_eqb x y); subst; auto; congruence.
  Qed.
End SemiDec_RSym.

(** TODO(mario): This should be moved to somewhere in Lambda, probably
 ** Lambda/ExprCore.v
 **)
Section SemiDec_expr.

  Variable typ : Set.
  Variable typ_Rt : RType typ.
  Variable typ_RtOk : @RTypeOk typ typ_Rt.
  Variable func : Set.
  Variable func_Rs : @RSym typ typ_Rt func.
  Variable func_RsOk : RSymOk func_Rs.

  (* put SemiDec typeclass in util for now.
     in the longer run,
     Lambda/ExprCore.v should change to use SemiDec *)
  Instance RelDecSemi_expr : RelDec (@eq (expr typ func)) :=
  { rel_dec :=
      expr_eq_dec (@ExprFacts.RelDec_eq_typ typ typ_Rt)
                  (@RelDecSemi_RSym typ typ_Rt func func_Rs)
  }.

  Lemma expr_semi_dec_eq :
    forall x y, expr_eq_dec ExprFacts.RelDec_eq_typ (RelDecSemi_RSym typ _ func func_Rs) x y = true ->
           x = y.
  Proof.
    induction x; destruct y; try solve [intros; simpl in *; congruence].
    { intros. simpl in *.
      apply EqNat.beq_nat_true in H. subst. reflexivity. }
    { intros. simpl in *.
      unfold rel_dec in H. simpl in H.
      eapply sym_eqbOk with (a := f) (b := f0) in func_RsOk.
      destruct (sym_eqb f f0) eqn:Heqb.
      { subst; subst; reflexivity. }
      { congruence. } }
    { simpl.
      specialize (IHx1 y1).
      specialize (IHx2 y2).
      destruct (expr_eq_dec ExprFacts.RelDec_eq_typ
       (RelDecSemi_RSym typ typ_Rt func func_Rs) x1 y1); try congruence.
      intros; f_equal; eauto. }
    { simpl.
      match goal with
      | |- context [ match ?X with true => _ | _ => _ end ] =>
        consider X
      end; intros.
      subst.
      f_equal; eauto. }
    { intros. simpl in *. apply EqNat.beq_nat_true in H. subst. reflexivity. }
  Qed.

  Instance SemiDecOk_expr : RelDecSemiOk (expr typ func) _ RelDecSemi_expr.
  Proof.
    constructor. intros.
    unfold rel_dec in H. simpl in H.
    apply expr_semi_dec_eq in H; auto.
  Qed.
End SemiDec_expr.

Lemma RelDec_semidec {T} (rT : T -> T -> Prop)
      (RDT : RelDec rT) (RDOT : RelDec_Correct RDT)
: forall a b : T, a ?[ rT ] b = true -> rT a b.
Proof. intros. consider (a ?[ rT ] b); auto. Qed.


Require Import CoqPerformanceTests.typeclass_reification_common.
Time Definition foo290 : goal 290. Time solve_P. Time Qed.


Require Import DataTypes Omega.

Module Type Channel (dt: DataTypes).
  Import dt.

  Section local.
    Context {s: ChannelType}.
    Context {p c : Cache}.
    Axiom uniqMark1: forall {m n t}, mark s p c t m -> mark s p c t n -> m = n.
    Axiom uniqMark2: forall {m t1 t2}, mark s p c t1 m -> mark s p c t2 m -> t1 = t2.
    Axiom uniqSend1: forall {m n t}, send s p c t m -> send s p c t n -> m = n.
    Axiom uniqSend2: forall {m t1 t2}, send s p c t1 m -> send s p c t2 m -> t1 = t2.
    Axiom uniqRecv1: forall {m n t}, recv s p c t m -> recv s p c t n -> m = n.
    Axiom uniqRecv2: forall {m t1 t2}, recv s p c t1 m -> recv s p c t2 m -> t1 = t2.
    Axiom uniqProc1: forall {m n t}, proc s p c t m -> proc s p c t n -> m = n.
    Axiom uniqProc2: forall {m t1 t2}, proc s p c t1 m -> proc s p c t2 m -> t1 = t2.
    Axiom uniqDeq1: forall {m n t}, deq s p c t m -> deq s p c t n -> m = n.
    Axiom uniqDeq2: forall {m t1 t2}, deq s p c t1 m -> deq s p c t2 m -> t1 = t2.
    Axiom sendImpMark: forall {m t}, send s p c t m -> exists t', t' <= t /\ mark s p c t' m.
    Axiom recvImpSend: forall {m t}, recv s p c t m -> exists t', t' <= t /\ send s p c t' m.
    Axiom procImpRecv: forall {m t}, proc s p c t m -> exists t', t' <= t /\ recv s p c t' m.
    Axiom deqImpProc: forall {m t}, deq s p c t m -> exists t', t' <= t /\ proc s p c t' m.
  End local.
End Channel.

Module mkChannelThms (dt: DataTypes) (ch: Channel dt).
  Import dt ch.
  Section local.
    Context {s: ChannelType}.
    Context {p c: Cache}.
    Theorem deqImpRecv: forall {m t}, deq s p c t m -> exists t', t' <= t /\ recv s p c t' m.
    Proof.
      intros m t deqm.
      pose proof (deqImpProc deqm) as [t' [t'LeT procm]].
      pose proof (procImpRecv procm) as [t'' [t''LeT' recvm]].
      assert (t''LeT: t'' <= t) by omega.
      firstorder.
    Qed.
    Theorem deqImpSend: forall {m t}, deq s p c t m -> exists t', t' <= t /\ send s p c t' m.
    Proof.
      intros m t deqm.
      pose proof (deqImpRecv deqm) as [t' [t'LeT recvm]].
      pose proof (recvImpSend recvm) as [t'' [t''LeT' sendm]].
      assert (t''LeT: t'' <= t) by omega.
      firstorder.
    Qed.
    Theorem deqImpMark: forall {m t}, deq s p c t m -> exists t', t' <= t /\ mark s p c t' m.
    Proof.
      intros m t deqm.
      pose proof (deqImpSend deqm) as [t' [t'LeT sendm]].
      pose proof (sendImpMark sendm) as [t'' [t''LeT' markm]].
      assert (t''LeT: t'' <= t) by omega.
      firstorder.
    Qed.
    Theorem procImpSend: forall {m t}, proc s p c t m -> exists t', t' <= t /\ send s p c t' m.
    Proof.
      intros m t procm.
      pose proof (procImpRecv procm) as [t' [t'LeT recvm]].
      pose proof (recvImpSend recvm) as [t'' [t''LeT' sendm]].
      assert (t''LeT: t'' <= t) by omega.
      firstorder.
    Qed.
    Theorem procImpMark: forall {m t}, proc s p c t m -> exists t', t' <= t /\ mark s p c t' m.
    Proof.
      intros m t procm.
      pose proof (procImpSend procm) as [t' [t'LeT sendm]].
      pose proof (sendImpMark sendm) as [t'' [t''LeT' markm]].
      assert (t''LeT: t'' <= t) by omega.
      firstorder.
    Qed.
    Theorem recvImpMark: forall {m t}, recv s p c t m -> exists t', t' <= t /\ mark s p c t' m.
    Proof.
      intros m t recvm.
      pose proof (recvImpSend recvm) as [t' [t'LeT sendm]].
      pose proof (sendImpMark sendm) as [t'' [t''LeT' markm]].
      assert (t''LeT: t'' <= t) by omega.
      firstorder.
    Qed.
    Theorem procImpMarkBefore: forall {m ts tr}, proc s p c tr m -> mark s p c ts m -> ts <= tr.
    Proof.
      intros m ts tr procm markm.
      pose proof (procImpMark procm) as [t' [t'_le_tr markm']].
      pose proof uniqMark2 markm markm' as ts_eq_t'.
      omega.
    Qed.
    Theorem recvImpMarkBefore: forall {m ts tr}, recv s p c tr m -> mark s p c ts m -> ts <= tr.
    Proof.
      intros m ts tr recvm markm.
      pose proof (recvImpMark recvm) as [t' [t'_le_tr markm']].
      pose proof uniqMark2 markm markm' as ts_eq_t'.
      omega.
    Qed.
  End local.
End mkChannelThms.

Module Type ChannelPerAddr (dt: DataTypes).

  Definition mark ch p c a t m := dt.mark ch p c t m /\ addr m = a.
  Definition send ch p c a t m := dt.send ch p c t m /\ addr m = a.
  Definition recv ch p c a t m := dt.recv ch p c t m /\ addr m = a.
  Definition proc ch p c a t m := dt.proc ch p c t m /\ addr m = a.
  Definition deq ch p c a t m := dt.deq ch p c t m /\ addr m = a.

  Section local.
    Context {s: ChannelType}.
    Context {p c : Cache} {a: Addr}.
    Axiom uniqMark1: forall {m n t}, mark s p c a t m -> mark s p c a t n -> m = n.
    Axiom uniqMark2: forall {m t1 t2}, mark s p c a t1 m -> mark s p c a t2 m -> t1 = t2.
    Axiom uniqSend1: forall {m n t}, send s p c a t m -> send s p c a t n -> m = n.
    Axiom uniqSend2: forall {m t1 t2}, send s p c a t1 m -> send s p c a t2 m -> t1 = t2.
    Axiom uniqRecv1: forall {m n t}, recv s p c a t m -> recv s p c a t n -> m = n.
    Axiom uniqRecv2: forall {m t1 t2}, recv s p c a t1 m -> recv s p c a t2 m -> t1 = t2.
    Axiom uniqProc1: forall {m n t}, proc s p c a t m -> proc s p c a t n -> m = n.
    Axiom uniqProc2: forall {m t1 t2}, proc s p c a t1 m -> proc s p c a t2 m -> t1 = t2.
    Axiom uniqDeq1: forall {m n t}, deq s p c a t m -> deq s p c a t n -> m = n.
    Axiom uniqDeq2: forall {m t1 t2}, deq s p c a t1 m -> deq s p c a t2 m -> t1 = t2.
    Axiom sendImpMark: forall {m t}, send s p c a t m -> exists t', t' <= t /\ mark s p c a t' m.
    Axiom recvImpSend: forall {m t}, recv s p c a t m -> exists t', t' <= t /\ send s p c a t' m.
    Axiom procImpRecv: forall {m t}, proc s p c a t m -> exists t', t' <= t /\ recv s p c a t' m.
    Axiom deqImpProc: forall {m t}, deq s p c a t m -> exists t', t' <= t /\ proc s p c a t' m.
    Axiom deqImpRecv: forall {m t}, deq s p c a t m -> exists t', t' <= t /\ recv s p c a t' m.
    Axiom deqImpSend: forall {m t}, deq s p c a t m -> exists t', t' <= t /\ send s p c a t' m.
    Axiom deqImpMark: forall {m t}, deq s p c a t m -> exists t', t' <= t /\ mark s p c a t' m.
    Axiom procImpSend: forall {m t}, proc s p c a t m -> exists t', t' <= t /\ send s p c a t' m.
    Axiom procImpMark: forall {m t}, proc s p c a t m -> exists t', t' <= t /\ mark s p c a t' m.
    Axiom recvImpMark: forall {m t}, recv s p c a t m -> exists t', t' <= t /\ mark s p c a t' m.
    Axiom procImpMarkBefore: forall {m ts tr}, proc s p c a tr m -> mark s p c a ts m ->
                                               ts <= tr.
    Axiom recvImpMarkBefore: forall {m ts tr}, recv s p c a tr m -> mark s p c a ts m ->
                                               ts <= tr.
  End local.
End ChannelPerAddr.

Module mkChannelPerAddr (dt: DataTypes) (ch: Channel dt) : ChannelPerAddr dt.
  Module chThm := mkChannelThms dt ch.
  Definition mark ch p c a t m := dt.mark ch p c t m /\ addr m = a.
  Definition send ch p c a t m := dt.send ch p c t m /\ addr m = a.
  Definition recv ch p c a t m := dt.recv ch p c t m /\ addr m = a.
  Definition proc ch p c a t m := dt.proc ch p c t m /\ addr m = a.
  Definition deq ch p c a t m := dt.deq ch p c t m /\ addr m = a.

  Set Implicit Arguments.
  Section local.
    Variable s: ChannelType.
    Variable p c : Cache.
    Variable a: Addr.
    Definition uniqMark1 {m n t} (sendm : mark s p c a t m) (sendn : mark s p c a t n) :=
      ch.uniqMark1 (proj1 sendm) (proj1 sendn).
    Definition uniqMark2 {m t1 t2} (sendm1: mark s p c a t1 m) (sendm2: mark s p c a t2 m) :=
      ch.uniqMark2 (proj1 sendm1) (proj1 sendm2).
    Definition uniqSend1 {m n t} (sendm : send s p c a t m) (sendn : send s p c a t n) :=
      ch.uniqSend1 (proj1 sendm) (proj1 sendn).
    Definition uniqSend2 {m t1 t2} (sendm1: send s p c a t1 m) (sendm2: send s p c a t2 m) :=
      ch.uniqSend2 (proj1 sendm1) (proj1 sendm2).
    Definition uniqRecv1 {m n t} (sendm : recv s p c a t m) (sendn : recv s p c a t n) :=
      ch.uniqRecv1 (proj1 sendm) (proj1 sendn).
    Definition uniqRecv2 {m t1 t2} (sendm1: recv s p c a t1 m) (sendm2: recv s p c a t2 m) :=
      ch.uniqRecv2 (proj1 sendm1) (proj1 sendm2).
    Definition uniqProc1 {m n t} (sendm : proc s p c a t m) (sendn : proc s p c a t n) :=
      ch.uniqProc1 (proj1 sendm) (proj1 sendn).
    Definition uniqProc2 {m t1 t2} (sendm1: proc s p c a t1 m) (sendm2: proc s p c a t2 m) :=
      ch.uniqProc2 (proj1 sendm1) (proj1 sendm2).
    Definition uniqDeq1 {m n t} (deqm: deq s p c a t m) (deqn: deq s p c a t n) :=
      ch.uniqDeq1 (proj1 deqm) (proj1 deqn).
    Definition uniqDeq2 {m t1 t2} (deqm1: deq s p c a t1 m) (deqm2: deq s p c a t2 m) :=
      ch.uniqDeq2 (proj1 deqm1) (proj1 deqm2).

    Definition sendImpMark {m t} (deqm: send s p c a t m) :=
      match ch.sendImpMark (proj1 deqm) with
          | ex_intro x Px =>
              ex_intro (fun t' =>
                          t' <= t /\ mark s p c a t' m) x (conj (proj1 Px) (conj (proj2 Px) (proj2 deqm)))
          end.

    Definition recvImpSend {m t} (deqm: recv s p c a t m) :=
      match ch.recvImpSend (proj1 deqm) with
          | ex_intro x Px =>
              ex_intro (fun t' =>
                          t' <= t /\ send s p c a t' m) x (conj (proj1 Px) (conj (proj2 Px) (proj2 deqm)))
          end.

    Definition procImpRecv {m t} (deqm: proc s p c a t m) :=
      match ch.procImpRecv (proj1 deqm) with
          | ex_intro x Px =>
              ex_intro (fun t' =>
                          t' <= t /\ recv s p c a t' m) x (conj (proj1 Px) (conj (proj2 Px) (proj2 deqm)))
          end.

    Definition deqImpProc {m t} (deqm: deq s p c a t m) :=
      match ch.deqImpProc (proj1 deqm) with
          | ex_intro x Px =>
              ex_intro (fun t' =>
                          t' <= t /\ proc s p c a t' m) x (conj (proj1 Px) (conj (proj2 Px) (proj2 deqm)))
          end.

    Definition deqImpRecv {m t} (deqm: deq s p c a t m) :=
      match chThm.deqImpRecv (proj1 deqm) with
          | ex_intro x Px =>
              ex_intro (fun t' =>
                          t' <= t /\ recv s p c a t' m) x (conj (proj1 Px) (conj (proj2 Px) (proj2 deqm)))
          end.

    Definition deqImpSend {m t} (deqm: deq s p c a t m) :=
      match chThm.deqImpSend (proj1 deqm) with
          | ex_intro x Px =>
              ex_intro (fun t' =>
                          t' <= t /\ send s p c a t' m) x (conj (proj1 Px) (conj (proj2 Px) (proj2 deqm)))
          end.

    Definition deqImpMark {m t} (deqm: deq s p c a t m) :=
      match chThm.deqImpMark (proj1 deqm) with
          | ex_intro x Px =>
              ex_intro (fun t' =>
                          t' <= t /\ mark s p c a t' m) x (conj (proj1 Px) (conj (proj2 Px) (proj2 deqm)))
          end.

    Definition procImpSend {m t} (deqm: proc s p c a t m) :=
      match chThm.procImpSend (proj1 deqm) with
          | ex_intro x Px =>
              ex_intro (fun t' =>
                          t' <= t /\ send s p c a t' m) x (conj (proj1 Px) (conj (proj2 Px) (proj2 deqm)))
          end.

    Definition procImpMark {m t} (deqm: proc s p c a t m) :=
      match chThm.procImpMark (proj1 deqm) with
          | ex_intro x Px =>
              ex_intro (fun t' =>
                          t' <= t /\ mark s p c a t' m) x (conj (proj1 Px) (conj (proj2 Px) (proj2 deqm)))
          end.

    Definition recvImpMark {m t} (deqm: recv s p c a t m) :=
      match chThm.recvImpMark (proj1 deqm) with
          | ex_intro x Px =>
              ex_intro (fun t' =>
                          t' <= t /\ mark s p c a t' m) x (conj (proj1 Px) (conj (proj2 Px) (proj2 deqm)))
          end.
    Definition procImpMarkBefore: forall {m ts tr}, proc s p c a tr m -> mark s p c a ts m ->
                                               ts <= tr.
    Proof.
      intros m ts tr procm markm.
      unfold proc in *.
      unfold mark in *.
      destruct procm as [procm _].
      destruct markm as [markm _].
      apply (chThm.procImpMarkBefore procm markm).
    Qed.

    Definition recvImpMarkBefore: forall {m ts tr}, recv s p c a tr m -> mark s p c a ts m ->
                                                    ts <= tr.
    Proof.
      intros m ts tr procm markm.
      unfold proc in *.
      unfold mark in *.
      destruct procm as [procm _].
      destruct markm as [markm _].
      apply (chThm.recvImpMarkBefore procm markm).
    Qed.
  End local.
End mkChannelPerAddr.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj18eqsynthconj3 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 (plus lv0 Zero))).
Admitted.
QuickChick conj18eqsynthconj3.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal86.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (IHx:@eq natural (mult x y) (mult y x)):@eq natural (plus (mult y x) y) (mult y (Succ x)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal86_mult_commut_88_mult_succ/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y.
QuickChick collect_data.
Success.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj29eqsynthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (plus Zero (mult lv0 lv1))).
Admitted.
QuickChick conj29eqsynthconj1.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj27eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 (plus Zero lv0))).
Admitted.
QuickChick conj27eqsynthconj4.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj8synthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv1 lv0)).
Admitted.
QuickChick conj8synthconj6.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj29synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (mult lv0 lv1) (plus lv1 lv0))) (plus (mult lv2 lv0) lv2)).
Admitted.
QuickChick conj29synthconj6.


Require Import FP.Data.Function.
Require Import FP.Structures.Monad.
Require Import FP.Structures.MonadTrans.
Require Import FP.Structures.Functor.

Import FunctionNotation.
Import MonadNotation.
Import FunctorNotation.

Class Continuation m :=
  { callcc : forall {A}, (forall {R}, (A -> m R) -> m R) -> m A }.

Inductive kon_t (m:Type->Type) A := KonT { un_kon_t : forall {R}, (A -> m R) -> m R }.
Arguments KonT {m A} _.
Arguments un_kon_t {m A} _ {R} _.

Definition run_kon_t {m} {M:Monad m} {A} (aMK:kon_t m A) : m A := un_kon_t aMK ret.

Instance kon_Monad {m} {M:Monad m} : Monad (kon_t m) :=
  { ret :=
      fun A (a:A) =>
        KonT $ fun R (k:A -> m R) =>
          k a
  ; bind :=
      fun A B (aMK:kon_t m A) (f:A -> kon_t m B) =>
        KonT $ fun R (k:B -> m R) =>
          un_kon_t aMK $ fun (a:A) =>
            k =<< run_kon_t (f a)
  }.

Instance kon_MonadTrans : MonadTrans kon_t :=
  { lift :=
      fun m M A (aM:m A) =>
        KonT $ fun R (k:A -> m R) =>
          aM >>= k
  }.

Instance kon_Continuation {m} {M:Monad m} : Continuation (kon_t m) :=
  { callcc :=
      fun A (kk:forall {R}, (A -> kon_t m R) -> kon_t m R) =>
        KonT $ fun R (k:A -> m R) =>
          run_kon_t $ kk $ lift '.' k
  }.

Class Cont3 m :=
  { callcc3 : forall {A R}, ((A -> m R R) -> m R R) -> m R A }.

Inductive kon_t3 (m:Type->Type) R A := KonT3 { un_kon_t3 : (A -> m R) -> m R }.
Arguments KonT3 {m R A} _.
Arguments un_kon_t3 {m R A} _ _.

Definition kon_t3_lift {m} {M:Monad m} {A} (aM:m A) : kon_t3 m A A :=
  KonT3 $ fun (k:A -> m A) => aM >>= k.

Instance kon_Monad3 {m} {M:Monad m} {R} : Monad (kon_t3 m R) :=
  { ret :=
      fun A (a:A) =>
        KonT3 $ fun (k:A -> m R) =>
          k a
  ; bind :=
      fun A B (aMK:kon_t3 m R A) (f:A -> kon_t3 m R B) =>
        KonT3 $ fun (k:B -> m R) =>
          un_kon_t3 aMK $ fun (a:A) =>
            un_kon_t3 (f a) k
  }.

Instance kon_Cont3 {m} {M:Monad m} : Cont3 (kon_t3 m) :=
  { callcc3 :=
      fun A R (kk:(A -> kon_t3 m R R) -> kon_t3 m R R) =>
        KonT3 $ fun (k:A -> m R) =>
          un_kon_t3 (kk (kon_t3_lift '.' k)) ret
  }.

Inductive reader_tk E (m:Type->Type->Type) R A := ReaderTK { un_reader_tk : E -> m R A }.
Arguments ReaderTK {E m R A} _.
Arguments un_reader_tk {E m R A} _ _.

Definition run_reader_tk {E m R A} e (x:reader_tk E m R A) := un_reader_tk x e.

Instance Rasdfa {m} {M:forall R, Monad (m R)} {C:Cont3 m} {E} : Cont3 (reader_tk E m) :=
  { callcc3 :=
      fun A R (kk:(A -> reader_tk E m R R) -> reader_tk E m R R) =>
        ReaderTK $ fun (e:E) =>
          callcc3 $ fun (k:A -> m R R) =>
            run_reader_tk e $
              kk $ fun (a:A) =>
                ReaderTK (fun _ => k a)
  }.

Class Cont R m :=
  { callcc' : forall {A}, (forall {R'}, (R -> m R') -> (A -> m R) -> m R') -> m A }.

Inductive kon_t' R (m:Type->Type) A := KonT' { un_kon_t' : forall {R'}, (R -> m R') -> (A -> m R) -> m R' }.
Arguments KonT' {R m A} _.
Arguments un_kon_t' {R m A} _ {R'} _ _.

Definition run_kon_t' {m} {M:Monad m} {A} (aMK:kon_t' A m A) : m A := un_kon_t' aMK ret ret.

Instance kon_Monad' {R} {m} {M:Monad m} : Monad (kon_t' R m) :=
  { ret :=
      fun A (a:A) =>
        KonT' $ fun R' (k_out:R -> m R') (k_in:A -> m R) => k_in a >>= k_out
  ; bind :=
      fun A B (aMK:kon_t' R m A) (f:A -> kon_t' R m B) =>
        KonT' $ fun R' (k_out:R -> m R') (k_in:B -> m R) =>
          un_kon_t' aMK k_out $ fun (a:A) =>
            un_kon_t' (f a) ret k_in
}.

Instance kon_MonadTrans' {R} : MonadTrans (kon_t' R) :=
  { lift :=
      fun m M A (aM:m A) =>
        KonT' $ fun R' (k_out:R -> m R') (k_in:A -> m R) =>
          aM >>= k_in >>= k_out
  }.

Instance kon_Cont {R} {m} {M:Monad m} : Cont R (kon_t' R m) :=
  { callcc' :=
      fun A (kk:forall {R'}, (R -> kon_t' R m R') -> (A -> kon_t' R m R) -> kon_t' R m R') =>
        KonT' $ fun R' (k_out:R -> m R') (k_in:A -> m R) =>
          un_kon_t' (kk ret (lift '.' k_in)) k_out ret
  }.

Class Cont2 m :=
  { callcc2 : forall {R A}, (forall {R'}, (R -> m R R') -> (A -> m R R) -> m R R') -> m R A
  ; map_kont : forall {R R' A}, (R -> R') -> (R' -> R) -> m R A -> m R' A
  }.

Inductive kon_t2 (m:Type -> Type) R A := KonT2 { un_kon_t2 : forall {R'}, (R -> m R') -> (A -> m R) -> m R' }.
Arguments KonT2 {m R A} _.
Arguments un_kon_t2 {m R A} _ {R'} _ _.

Definition run_kon_t2 {m} {M:Monad m} {A} (aMK:kon_t2 m A A) : m A := un_kon_t2 aMK ret ret.
Definition lift_kon_t2 {m} {M:Monad m} {A} (aM:m A) : kon_t2 m A A :=
  KonT2 $ fun R' k_out k_in => aM >>= k_in >>= k_out.

Instance kon_Monad2 {m} {M:Monad m} {R} : Monad (kon_t2 m R) :=
  { ret :=
      fun A (a:A) =>
        KonT2 $ fun R' (k_out:R -> m R') (k_in:A -> m R) => k_in a >>= k_out
  ; bind :=
      fun A B (aMK:kon_t2 m R A) (f:A -> kon_t2 m R B) =>
        KonT2 $ fun R' (k_out:R -> m R') (k_in:B -> m R) =>
          un_kon_t2 aMK k_out $ fun (a:A) =>
            un_kon_t2 (f a) ret k_in
  }.

Instance Kon_Cont2 {m} {M:Monad m} : Cont2 (kon_t2 m) :=
  { callcc2 :=
      fun R A (kk:forall {R'}, (R -> kon_t2 m R R') -> (A -> kon_t2 m R R) -> kon_t2 m R R') =>
        KonT2 $ fun R' (k_out:R -> m R') (k_in:A -> m R) =>
          un_kon_t2 (kk ret (lift_kon_t2 '.' k_in)) k_out ret
  ; map_kont :=
      fun R R' A (f:R -> R') (g:R' -> R) (aMK:kon_t2 m R A) =>
        KonT2 $ fun R'' (k_out:R' -> m R'') (k_in:A -> m R') =>
          un_kon_t2 aMK _ _
  }.
Admitted.


Require Import RRR.Lebesgue.Lebesgue.
Require Import Omega.
Require Import RRR.Lang.Lang.
Import RRR.Lang.Syntax.
Require Import Lra.
Require Import Coq.Program.Wf.

Set Implicit Arguments.

Lemma loeb (P : nat → Prop) :
(∀ n, (∀ m, m < n → P m) → P n)%nat → ∀ n, P n.
Proof.
intros H n.
specialize (lt_wf n).
induction 1 as [ n _ H2 ].
apply H.
intros m Hm.
apply H2. apply Hm.
Qed.

Open Scope ennr_scope.

Definition ORel (N : nat) (e₁ e₂ : exp0) :=
μNS_inf e₂ ≤ μNS N e₁ ∧ ∀ V, μTV N e₁ V ≤ μTV_sup e₂ V.

Definition VRel_Sig := nat → val0 → val0 → Prop.

Definition KRel_fun (VRel : VRel_Sig)
(N : nat) (K₁ K₂ : ktx) :=
∀ N', N' <= N →
∀ v₁ v₂, VRel N' v₁ v₂ → ORel N' (ktx_plug K₁ v₁) (ktx_plug K₂ v₂).

Definition ERel_fun (VRel : VRel_Sig)
(N : nat) (e₁ e₂ : exp0) :=
∀ N', N' <= N →
∀ K₁ K₂, KRel_fun VRel N' K₁ K₂ → ORel N' (ktx_plug K₁ e₁) (ktx_plug K₂ e₂).

Fixpoint VRel (T : ty) (N : nat) (v₁ v₂ : val0) {struct T} : Prop :=
match T with
| ty_unit => v₁ = val_unit ∧ v₂ = val_unit
| ty_bool => ∃ b, v₁ = val_bool b ∧ v₂ = val_bool b
| ty_real => ∃ r, v₁ = val_real r ∧ v₂ = val_real r
| ty_fun U R =>
  wf_val ∅→ v₁ (ty_fun U R) ∧
  wf_val ∅→ v₂ (ty_fun U R) ∧
  ∀ (N' : nat), N' <= N →
  ∀ u₁ u₂, VRel U N' u₁ u₂ →
  ERel_fun (VRel R) N' (exp_app v₁ u₁) (exp_app v₂ u₂)
| ty_pair U W =>
  ∃ u₁ u₂ w₁ w₂, v₁ = val_pair u₁ w₁ ∧ v₂ = val_pair u₂ w₂ ∧
  VRel U N u₁ u₂ ∧ VRel W N w₁ w₂
| ty_dist T =>
  wf_val ∅→ v₁ (ty_dist T) ∧
  wf_val ∅→ v₂ (ty_dist T) ∧
  ERel_fun (VRel T) N (exp_sample v₁) (exp_sample v₂)
end.

Notation KRel T := (KRel_fun (VRel T)).
Notation ERel T := (ERel_fun (VRel T)).

Lemma ORel_monotone :
∀ e₁ e₂ N, ORel N e₁ e₂ →
∀ N', N' <= N →
ORel N' e₁ e₂.
Proof.
unfold ORel.
intros e₁ e₂ N O' N' HN'.
destruct O' as [O'NS O'TV].
split.
+ eapply ennr_le_trans; [apply O'NS; apply TV|].
  apply μNS_antitone. omega.
+ intro V. eapply ennr_le_trans; [|apply O'TV].
  apply μTV_monotone. omega.
Qed.

Lemma KRel_monotone T N K₁ K₂ :
KRel_fun T N K₁ K₂ →
∀ N', N' <= N →
KRel_fun T N' K₁ K₂.
Proof.
unfold KRel_fun.
intro H. intros. apply H.
+ omega.
+ assumption.
Qed.

Lemma ERel_monotone T N e₁ e₂ :
ERel_fun T N e₁ e₂ →
∀ N', N' <= N →
ERel_fun T N' e₁ e₂.
Proof.
unfold ERel_fun.
intro H. intros. apply H.
+ omega.
+ assumption.
Qed.

Lemma VRel_monotone :
∀ T N v₁ v₂,
VRel T N v₁ v₂ →
∀ N', N' <= N → VRel T N' v₁ v₂.
Proof.
induction T ; intros N v₁ v₂ Hv N' Hle ; simpl in Hv |- *.
+ assumption.
+ assumption.
+ assumption.
+ destruct Hv as [Wf_v₁ [Wf_v₂ Hv]].
  split; [|split]. 1:{ apply Wf_v₁. } 1:{ apply Wf_v₂. }
  intros N'' Hle' u₁ u₂ Hu. apply Hv.
  - omega.
  - apply Hu.
+ destruct Hv as [u₁ [u₂ [w₁ [w₂ [? [? [? ?]]]]]]].
  subst.
  repeat eexists ; eauto.
+ destruct Hv as [Wf_v₁ [Wf_v₂ Hv]].
  split; [|split]. 1:{ apply Wf_v₁. } 1:{ apply Wf_v₂. }
  eapply ERel_monotone ; eauto.
Qed.

Lemma ORel_sss_l N e₁ e₁' :
(∀ t, sss (eval N) t e₁ t e₁' 1) →
∀ e₂, ORel N e₁' e₂ →
ORel (S N) e₁ e₂.
Proof.
unfold ORel. intros Hsss e₂ O_N.
destruct O_N as [O_NS O_TV]. split.
+ erewrite sss_preserves_μNS by apply Hsss. rewrite ennr_mul_1_r.
  apply O_NS.
+ intro V. erewrite sss_preserves_μTV by apply Hsss.
  unfold unif_score_meas. rewrite ennr_mul_1_r. apply O_TV.
Qed.

Lemma ORel_sss_r N e₂ e₂' :
(∀ N₂ t, sss (eval N₂) t e₂ t e₂' 1) →
∀ e₁, ORel N e₁ e₂' →
ORel N e₁ e₂.
Proof.
unfold ORel.
intros Hsss e₁ O_N.
destruct O_N as [O_NS O_TV]. split.
+ erewrite sss_preserves_μNS_inf by apply Hsss.
  repeat rewrite ennr_mul_1_r.
  apply O_NS.
+ intros V. erewrite sss_preserves_μTV_sup by apply Hsss.
  simpl. rewrite ennr_mul_1_r. apply O_TV.
Qed.

Lemma ORel_O_nonval e₁ e₂ :
(∀ v, e₁ = exp_val v → False) →
ORel O e₁ e₂.
Proof.
intros NV.
split.
+ rewrite μNS_O. apply μNS_inf_le_1.
+ intro. rewrite μTV_O_nonval by apply NV. apply ennr_le_0.
Qed.

Lemma ERel_O_nonval T e₁ e₂ :
(∀ v, e₁ = exp_val v → False) →
ERel T O e₁ e₂.
Proof.
intros NV. intros N HN K₁ K₂ HK.
assert (N = O) by omega. subst.
apply ORel_O_nonval.
intros. ktx_plug_is_val_absurd. subst. eapply NV; eauto.
Qed.

Lemma ORel_stuck N₁ e₁ N₂ e₂ :
stop N₁ e₁ →
(∀ v, e₁ = exp_val v → False) →
stop N₂ e₂ →
(∀ v, e₂ = exp_val v → False) →
∀ N, ORel N e₁ e₂.
Proof.
intros Stop_e₂ NV_e₂ Stop_e₁ NV_e₁.
split.
+ erewrite <- μNS_inf_stuck by eassumption. apply ennr_le_0.
+ intro. erewrite <- μTV_stuck by eassumption. apply ennr_le_0.
Qed.

Lemma ERel_stuck N₁ e₁ N₂ e₂ :
stop N₁ e₁ →
(∀ v, e₁ = exp_val v → False) →
stop N₂ e₂ →
(∀ v, e₂ = exp_val v → False) →
∀ T N, ERel T N e₁ e₂.
Proof.
intros Stop₁ NV₁ Stop₂ NV₂ T N.
intros N' HN K₁ K₂ HK.
eapply ORel_stuck.
4:{ intros. ktx_plug_is_val_absurd. subst. eapply NV₂. reflexivity. }
3:{ apply ktx_preserves_stuck; eassumption. }
2:{ intros. ktx_plug_is_val_absurd. subst. eapply NV₁. reflexivity. }
1:{ apply ktx_preserves_stuck; eassumption. }
Qed.

Lemma ERel_exn T N :
ERel T N exp_exn exp_exn.
Proof.
intros N' HN' K₁ K₂ HK. split.
+ rewrite <-μNS_exn. apply μNS_inf_le_1.
+ intro. rewrite <-μTV_exn. apply ennr_le_0.
Qed.

Lemma ERel_sss_l T N e₁ e₁' :
(∀ N', N' <= N → ∀ t, sss (eval N') t e₁ t e₁' 1) →
∀ e₂, ERel T N e₁' e₂ →
ERel T (S N) e₁ e₂.
Proof.
intros Hsss e₂ He N' HN' K₁ K₂ HK.
destruct N'.
+ apply ORel_O_nonval.
  intros v Hv. ktx_plug_is_val_absurd. subst.
  specialize (Hsss N (le_refl _) entropy0).
  inversion Hsss.
+ apply ORel_sss_l with (e₁' := ktx_plug K₁ e₁').
  1:{ intro t. apply ktx_congruence. apply Hsss ; omega. }
  apply He. 1:{ omega. }
  eapply KRel_monotone ; [ apply HK | omega ].
Qed.

Lemma ERel_sss_r T N e₂ e₂' :
(∀ N₂ t, sss (eval N₂) t e₂ t e₂' 1) →
∀ e₁, ERel T N e₁ e₂' →
ERel T N e₁ e₂.
Proof.
intros Hsss e₁ He N' HN' K₁ K₂ HK.
apply He in HK as Obs ; [|omega].
eapply ORel_sss_r with (e₂' := ktx_plug K₂ e₂').
+ intros N₂ t. apply ktx_congruence. apply Hsss.
+ apply Obs.
Qed.

Lemma VRel_in_ERel T v₁ v₂ N :
VRel T v₁ v₂ N →
ERel T v₁ v₂ N.
Proof.
intro Hv.
intros N' Hle K₁ K₂ HK.
apply HK ; [ omega | ].
eapply VRel_monotone ; eauto.
Qed.

Lemma ERel_ktx_plug Ta Tb N K₁ K₂ :
( ∀ N', N' <= N →
  ∀ v₁ v₂, VRel Ta N' v₁ v₂ →
  ERel Tb N' (ktx_plug K₁ v₁) (ktx_plug K₂ v₂) ) →
∀ N', N' <= N →
∀ e₁ e₂, ERel Ta N' e₁ e₂ →
ERel Tb N' (ktx_plug K₁ e₁) (ktx_plug K₂ e₂).
Proof.
intros HKv N' Hle' e₁ e₂ He.
intros N'' Hle'' J₁ J₂ HJ.
repeat rewrite ktx_plug_comp.
apply He ; [ apply Hle'' | ].
intros N''' Hle''' v₁ v₂ Hv.
repeat rewrite <- ktx_plug_comp.
specialize (HKv N''').
eapply HKv ; [ omega | | omega | ].
+ eapply VRel_monotone ; [ eassumption | omega ].
+ eapply KRel_monotone ; [ eassumption | omega ].
Qed.

Lemma VRel_wf_val T N v₁ v₂ :
VRel T N v₁ v₂ → wf_val ∅→ v₁ T ∧ wf_val ∅→ v₂ T.
Proof.
generalize N v₁ v₂. clear. induction T; intros N v₁ v₂ Hv.
+ destruct Hv. subst. split; constructor.
+ destruct Hv as [? [? ?]]. subst. split; constructor.
+ destruct Hv as [? [? ?]]. subst. split; constructor.
+ destruct Hv as [? [? ?]]. split; assumption.
+ destruct Hv as [? [? [? [? [? [? [? ?]]]]]]]. subst.
  apply IHT1 in H1 as [? ?].
  apply IHT2 in H2 as [? ?].
  split; constructor; assumption.
+ destruct Hv as [? [? ?]]. split; assumption.
Qed.

Section section_open_rels.
Context (V : Set).
Context (Γ : V → ty).

Definition EnvRel N (γ₁ γ₂ : V → val0) :=
∀ x, VRel (Γ x) N (γ₁ x) (γ₂ x).

Definition VRel_open (T : ty) (v₁ v₂ : val V) :=
∀ N,
∀ γ₁ γ₂, EnvRel N γ₁ γ₂ →
VRel T N (V_bind_val γ₁ v₁) (V_bind_val γ₂ v₂).

Definition ERel_open (T : ty) (e₁ e₂ : Syntax.exp V) :=
(wf_exp Γ e₁ T ∧ wf_exp Γ e₂ T) ∧
∀ N,
∀ γ₁ γ₂, EnvRel N γ₁ γ₂ →
         ERel T N (V_bind_exp γ₁ e₁) (V_bind_exp γ₂ e₂).

Lemma EnvRel_monotone N γ₁ γ₂ :
EnvRel N γ₁ γ₂ →
∀ N', N' <= N → EnvRel N' γ₁ γ₂.
Proof.
intros Hγ N' Hle x.
eapply VRel_monotone.
+ apply Hγ.
+ omega.
Qed.

Lemma EnvRel_wf_env N γ₁ γ₂ :
EnvRel N γ₁ γ₂ → wf_env γ₁ Γ ∧ wf_env γ₂ Γ.
Proof.
intro Hγ.
assert (∀ x, wf_val ∅→ (γ₁ x) (Γ x) ∧ wf_val ∅→ (γ₂ x) (Γ x)).
2:{ split; intro; apply H. }
intro x. eapply VRel_wf_val. apply Hγ.
Qed.

End section_open_rels.

Definition Ciu N e₁ e₂ :=
∀ K, ORel N (ktx_plug K e₁) (ktx_plug K e₂).

Definition Ciu_open (V: Set) (Γ : V → ty) (T : ty) (e₁ e₂ : exp V) :=
(wf_exp Γ e₁ T ∧ wf_exp Γ e₂ T) ∧
∀ N γ, wf_env γ Γ → Ciu N (V_bind_exp γ e₁) (V_bind_exp γ e₂).

Lemma ERel_Ciu_ERel_open (V: Set) (Γ : V → ty) T e₁ e₂' e₂ :
ERel_open Γ T e₁ e₂' →
Ciu_open Γ T e₂' e₂ →
ERel_open Γ T e₁ e₂.
Proof.
intros HE HC.
destruct HE as [[? ?] HE].
destruct HC as [[? ?] HC].
split. 1:{ split; assumption. }
intros N γ₁ γ₂ Hγ.
intros N' HN' K₁ K₂ HK.
apply EnvRel_wf_env in Hγ as Wf_γ. destruct Wf_γ as [Wf_γ₁ Wf_γ₂].

specialize (HE N γ₁ γ₂ Hγ).
apply HE in HK as Obs' ; [|omega].
destruct Obs' as [Obs' Obs''].
assert (∀ M, μNS_inf (ktx_plug K₂ (V_bind_exp γ₂ e₂)) ≤ μNS M (ktx_plug K₂ (V_bind_exp γ₂ e₂'))) as NS_e₂'.
1:{
  clear -HC Wf_γ₂. intro M.
  specialize (HC M γ₂ Wf_γ₂ K₂) as [HC _]. apply HC.
}
assert (∀ A M, μTV M (ktx_plug K₂ (V_bind_exp γ₂ e₂')) A ≤ μTV_sup (ktx_plug K₂ (V_bind_exp γ₂ e₂)) A) as TV_e₂'.
1:{
  clear -HC Wf_γ₂. intros A M.
  specialize (HC M γ₂ Wf_γ₂ K₂) as [_ HC]. apply HC.
}

apply μNS_inf_is_glb in NS_e₂'.
split.
+ eapply ennr_le_trans; [apply NS_e₂'|apply Obs'].
+ intro A. eapply ennr_le_trans; [apply Obs''|].
  eapply μTV_sup_is_lub in TV_e₂'. apply TV_e₂'.
Qed.


(* ************************************************************************** *)
(** * Basic tactics *)
(* ************************************************************************** *)

(** This file collects a number of basic tactics for better proof automation,
    structuring large proofs, or rewriting.  Many of the definitions have been
    ported from ss-reflect. *)

(** Symbols starting with [hahn__] are internal. *)

Require Import Bool Arith ZArith String.
Require ClassicalFacts.
Require Export ClassicalDescription FunctionalExtensionality.

Open Scope bool_scope.
Open Scope list_scope.

Set Implicit Arguments.
Unset Strict Implicit.

(** Set up hint databases *)
Create HintDb hahn discriminated.      (* General stuff, used by done *)
Create HintDb hahn_refl discriminated. (* Decidable equalities *)
Create HintDb hahn_full discriminated. (* Expensive lemmas *)

(** Shorthand for applying functional extensionality. *)

Ltac exten := apply functional_extensionality.

(** Notation for classical if-then-else *)

Notation "'ifP' c 'then' u 'else' v" :=
  (if excluded_middle_informative c then u else v)
  (at level 200).

(* ************************************************************************** *)
(** ** Coersion of [bool] into [Prop] *)
(* ************************************************************************** *)

(** Coersion of bools into Prop *)
Coercion is_true (b : bool) : Prop := b = true.

(** Hints for auto *)
Lemma hahn__true_is_true : true.
Proof. reflexivity. Qed.

Lemma hahn__not_false_is_true : ~ false.
Proof. discriminate. Qed.

Global Hint Resolve hahn__true_is_true hahn__not_false_is_true : core.

(* ************************************************************************** *)
(** ** Very basic automation *)
(* ************************************************************************** *)

(** Set up for basic simplification *)

(** Adaptation of the ss-reflect "[done]" tactic. *)

Ltac hahn__basic_done :=
  solve [trivial with hahn | simple apply sym_equal; trivial | discriminate | contradiction].

Ltac done := trivial with hahn; hnf; intros;
  solve [try hahn__basic_done; split;
         try hahn__basic_done; split;
         try hahn__basic_done; split;
         try hahn__basic_done; split;
         try hahn__basic_done; split; hahn__basic_done
    | match goal with H : ~ _ |- _ => solve [case H; trivial] end].

(** A variant of the ssr "done" tactic that performs "eassumption". *)

Ltac edone := try eassumption; trivial; hnf; intros;
  solve [try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; try hahn__basic_done; split;
         try eassumption; hahn__basic_done
    | match goal with H : ~ _ |- _ => solve [case H; trivial] end].

Tactic Notation "by"  tactic(tac) := (tac; done).
Tactic Notation "eby" tactic(tac) := (tac; edone).

(* ************************************************************************** *)
(** ** Equality types *)
(* ************************************************************************** *)

Module Equality.

  Definition axiom T (e : T -> T -> bool) :=
    forall x y, reflect (x = y) (e x y).

  Structure mixin_of T := Mixin {op : T -> T -> bool; _ : axiom op}.
  Notation class_of := mixin_of (only parsing).

  Section ClassDef.

    Structure type := Pack {sort; _ : class_of sort; _ : Type}.

    Definition class cT' :=
      match cT' return class_of (sort cT') with @Pack _ c _ => c end.

    Definition pack (T: Type) c := @Pack T c T.

  End ClassDef.

  Module Exports.
    Coercion sort : type >-> Sortclass.
    Notation eqType := type.
    Notation EqMixin := Mixin.
    Notation EqType T m := (@pack T m).
  End Exports.

End Equality.
Export Equality.Exports.

Definition eq_op T := Equality.op (Equality.class T).
Arguments eq_op {T}.

Lemma eqE : forall T x, eq_op x = Equality.op (Equality.class T) x.
Proof. done. Qed.

Lemma eqP : forall T, Equality.axiom (@eq_op T).
Proof. by unfold eq_op; destruct T as [? []]. Qed.
Arguments eqP [T] x y.

(*
Notation "x == y" := (eq_op x y)
  (at level 70, no associativity) : bool_scope.
Notation "x == y :> T" := ((x : T) == (y : T))
  (at level 70, y at next level) : bool_scope.
Notation "x != y" := (negb (x == y))
  (at level 70, no associativity) : bool_scope.
Notation "x != y :> T" := (negb (x == y :> T))
  (at level 70, y at next level) : bool_scope.
*)

Lemma hahn__internal_eqP :
  forall (T: eqType) (x y : T), reflect (x = y) (eq_op x y).
Proof. apply eqP. Qed.

Lemma neqP : forall (T: eqType) (x y: T), reflect (x <> y) (negb (eq_op x y)).
Proof. intros; case eqP; constructor; auto. Qed.

Lemma beq_refl : forall (T : eqType) (x : T), eq_op x x.
Proof. by intros; case eqP. Qed.

Lemma beq_sym : forall (T : eqType) (x y : T), (eq_op x y) = (eq_op y x).
Proof. intros; do 2 case eqP; congruence. Qed.

Global Hint Resolve beq_refl : hahn.
Hint Rewrite beq_refl : hahn_trivial.

Notation eqxx := beq_refl.

(** Comparison for [nat] *)

Fixpoint eqn_rec (x y: nat) {struct x} :=
   match x, y with
     | O, O => true
     | S x, S y => eqn_rec x y
     | _, _ => false
   end.

Definition eqn := match tt with tt => eqn_rec end.

Lemma eqnP: forall x y, reflect (x = y) (eqn x y).
Proof.
  induction x; destruct y; try (constructor; done).
  change (eqn (S x) (S y)) with (eqn x y).
  case IHx; constructor; congruence.
Qed.

Canonical Structure nat_eqMixin := EqMixin eqnP.
Canonical Structure nat_eqType := Eval hnf in EqType nat nat_eqMixin.

Lemma eqnE : eqn = (@eq_op _).
Proof. done. Qed.

(* ************************************************************************** *)
(** ** Basic simplification tactics *)
(* ************************************************************************** *)

Lemma hahn__negb_rewrite : forall b, negb b -> b = false.
Proof. by intros []. Qed.

Lemma hahn__andb_split : forall b1 b2, b1 && b2 -> b1 /\ b2.
Proof. by intros [] []. Qed.

Lemma hahn__nandb_split : forall b1 b2, b1 && b2 = false -> b1 = false \/ b2 = false.
Proof. intros [] []; auto. Qed.

Lemma hahn__orb_split : forall b1 b2, b1 || b2 -> b1 \/ b2.
Proof. intros [] []; auto. Qed.

Lemma hahn__norb_split : forall b1 b2, b1 || b2 = false -> b1 = false /\ b2 = false.
Proof. intros [] []; auto. Qed.

Lemma hahn__eqb_split : forall b1 b2 : bool, (b1 -> b2) -> (b2 -> b1) -> b1 = b2.
Proof. intros [] [] H H'; unfold is_true in *; auto using sym_eq. Qed.

Lemma hahn__beq_rewrite (T : eqType) (x1 x2 : T) : eq_op x1 x2 -> x1 = x2.
Proof. by case eqP. Qed.

(** Set up for basic simplification: database of reflection lemmas *)

Global Hint Resolve hahn__internal_eqP neqP eqnP : hahn_refl.
Global Hint Resolve Z.eqb_spec Z.leb_spec0 Z.ltb_spec0 : hahn_refl.
Global Hint Resolve N.eqb_spec N.leb_spec0 N.ltb_spec0 : hahn_refl.
Global Hint Resolve Pos.eqb_spec Pos.leb_spec0 Pos.ltb_spec0 : hahn_refl.
Global Hint Resolve Nat.eqb_spec Nat.leb_spec0 Nat.ltb_spec0 : hahn_refl.
Global Hint Resolve Ascii.eqb_spec String.eqb_spec : hahn_refl.
Global Hint Resolve Bool.eqb_spec : hahn_refl.

Ltac hahn__complaining_inj f H :=
  let X := fresh in
  (match goal with | [|- ?P ] => set (X := P) end);
  injection H; clear H; intros; subst X;
  try subst.

Ltac hahn__clarify1 :=
  try subst;
  repeat match goal with
  | [H: is_true (andb _ _) |- _] =>
      let H' := fresh H in case (hahn__andb_split H); clear H; intros H' H
  | [H: is_true (negb ?x) |- _] => rewrite (hahn__negb_rewrite H) in *
  | [H: is_true ?x        |- _] => rewrite H in *
  | [H: ?x = true         |- _] => rewrite H in *
  | [H: ?x = false        |- _] => rewrite H in *
  | [H: is_true (eq_op _ _)  |- _] => generalize (hahn__beq_rewrite H); clear H; intro H
  | [H: @existT _ _ _ _ = @existT _ _ _ _ |- _] => apply inj_pair2 in H; try subst
  | [H: ?f _             = ?f _             |- _] => hahn__complaining_inj f H
  | [H: ?f _ _           = ?f _ _           |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _         = ?f _ _ _         |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _       = ?f _ _ _ _       |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _ _     = ?f _ _ _ _ _     |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _ _ _   = ?f _ _ _ _ _ _   |- _] => hahn__complaining_inj f H
  | [H: ?f _ _ _ _ _ _ _ = ?f _ _ _ _ _ _ _ |- _] => hahn__complaining_inj f H
  end; try done.

(** Perform injections & discriminations on all hypotheses *)

Ltac clarify :=
  hahn__clarify1;
  repeat match goal with
    | H1: ?x = Some _, H2: ?x = None   |- _ => rewrite H2 in H1; discriminate
    | H1: ?x = Some _, H2: ?x = Some _ |- _ => rewrite H2 in H1; hahn__clarify1
  end; (* autorewrite with hahn_trivial; *) try done.

(** Kill simple goals that require up to two econstructor calls. *)

Ltac vauto :=
  (clarify; try edone;
   try [> econstructor; (solve [edone | [> econstructor; edone]])]).

Ltac inv x := inversion x; clarify.
Ltac simpls  := simpl in *; try done.
Ltac ins := simpl in *; try done; intros.

Ltac hahn__clarsimp1 :=
  clarify; (autorewrite with hahn_trivial hahn in * );
  (autorewrite with hahn_trivial in * ); try done;
  clarify; auto 1 with hahn.

Ltac clarsimp := intros; simpl in *; hahn__clarsimp1.

Ltac autos   := clarsimp; auto with hahn.

Tactic Notation "econs" := econstructor.
Tactic Notation "econs" int_or_var(x) := econstructor x.

(* ************************************************************************** *)
(** Destruct but give useful names *)
(* ************************************************************************** *)

Definition  NW (P: unit -> Prop) : Prop := P tt.

Notation "⟪ x : t ⟫" := (NW (fun x => t)) (at level 80, x ident, no associativity).
Notation "<< x : t >>" := (NW (fun x => t))
  (at level 80, x ident, no associativity, only parsing).
Notation "⟪ t ⟫" := (NW (fun _ => t)) (at level 79, no associativity, format "⟪ t ⟫").

Ltac unnw := unfold NW in *.
Ltac rednw := red; unnw.

Global Hint Unfold NW : core.

Ltac splits :=
  intros; unfold NW;
  repeat match goal with
  | [ |- _ /\ _ ] => split
  end.

Ltac esplits :=
  intros; unfold NW;
  repeat match goal with
  | [ |- @ex _ _ ] => eexists
  | [ |- _ /\ _ ] => split
  | [ |- @sig _ _ ] => eexists
  | [ |- @sigT _ _ ] => eexists
  | [ |- @prod _  _ ] => split
  end.

(** Destruct, but no case split *)
Ltac desc :=
  repeat match goal with
    | H: is_true (eq_op _ _) |- _ => generalize (hahn__beq_rewrite H); clear H; intro H
    | H : exists x, NW (fun y => _) |- _ =>
      progress first [try (destruct H as [? H] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y']
    | H : exists x, ?p |- _ =>
      let x' := fresh x in destruct H as [x' H]
    | H : ?p /\ ?q |- _ =>
      progress first [try (destruct H as [H ?] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => red in x' | _ => idtac end;
      match q with | NW _ => red in y' | _ => idtac end]
    | H : is_true (_ && _) |- _ =>
          let H' := fresh H in case (hahn__andb_split H); clear H; intros H H'
    | H : (_ || _) = false |- _ =>
          let H' := fresh H in case (hahn__norb_split H); clear H; intros H H'
    | H : ?x = ?x   |- _ => clear H

(*    | H: is_true ?x |- _ => eapply elimT in H; [|solve [trivial with hahn_refl]]
    | H: ?x = true  |- _ => eapply elimT in H; [|solve [trivial with hahn_refl]]
    | H: ?x = false |- _ => eapply elimFn in H; [|solve [trivial with hahn_refl]]
    | H: ?x = false |- _ => eapply elimF in H; [|solve [trivial with hahn_refl]]  *)
  end.

Ltac des :=
  repeat match goal with
    | H: is_true (eq_op _ _) |- _ => generalize (hahn__beq_rewrite H); clear H; intro H
    | H : exists x, NW (fun y => _) |- _ =>
      progress first [try (destruct H as [? H] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := fresh x in let y' := fresh y in destruct H as [x' y']; red in y']
    | H : exists x, ?p |- _ =>
      let x' := fresh x in destruct H as [x' H]
    | H : ?p /\ ?q |- _ =>
      progress first [try (destruct H as [H ?] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => red in x' | _ => idtac end;
      match q with | NW _ => red in y' | _ => idtac end]
    | H : is_true (_ && _) |- _ =>
        let H' := fresh H in case (hahn__andb_split H); clear H; intros H H'
    | H : (_ || _) = false |- _ =>
        let H' := fresh H in case (hahn__norb_split H); clear H; intros H H'
    | H : ?x = ?x |- _ => clear H
    | H : ?p <-> ?q |- _ =>
      progress first [try (destruct H as [H ?] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y'];
      match p with | NW _ => unfold NW at 1 in x'; red in y' | _ => idtac end;
      match q with | NW _ => unfold NW at 1 in y'; red in x' | _ => idtac end]
    | H : ?p \/ ?q |- _ =>
      progress first [try (destruct H as [H|H] ; fail 1) | (* Check it's not a Section Hypothesis *)
      let x' := match p with | NW (fun z => _) => fresh z | _ => H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => H end in
      destruct H as [x' | y'];
      [ match p with | NW _ => red in x' | _ => idtac end
      | match q with | NW _ => red in y' | _ => idtac end]]
    | H : is_true (_ || _) |- _ => case (hahn__orb_split H); clear H; intro H
    | H : (_ && _) = false |- _ => case (hahn__nandb_split H); clear H; intro H
  end.

Ltac desc_section :=
  repeat match goal with
    | H : exists x, NW (fun y => _) |- _ =>
      try (destruct H as [? H] ; fail 1); (* Check it is a Section Hypothesis *)
      let x' := fresh x in let y' := fresh y in destruct H as [x' y']; clear H; red in y'
    | H : exists x, ?p |- _ =>
      try (destruct H as [? H] ; fail 1); (* Check it is a Section Hypothesis *)
      let x' := fresh x in let y' := fresh H in destruct H as [x' y']; clear H; red in y'
    | H : ?p /\ ?q |- _ =>
      try (destruct H as [H ?] ; fail 1); (* Check it is a Section Hypothesis *)
      let x' := match p with | NW (fun z => _) => fresh z | _ => fresh H end in
      let y' := match q with | NW (fun z => _) => fresh z | _ => fresh H end in
      destruct H as [x' y']; clear H;
      match p with | NW _ => red in x' | _ => idtac end;
      match q with | NW _ => red in y' | _ => idtac end
    | H : ?x = ?x   |- _ => clear H
  end; desc.

Ltac cdes H :=
  let H' := fresh H in assert (H' := H); try red in H'; desc.

Ltac des_if_asm :=
  clarify;
  repeat
    match goal with
      | H: context[ match ?x with _ => _ end ] |- _ =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
    end.

Ltac des_if_goal :=
  clarify;
  repeat
    match goal with
      | |- context[match ?x with _ => _ end] =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
    end.

Ltac des_if :=
  clarify;
  repeat
    match goal with
      | |- context[match ?x with _ => _ end] =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
      | H: context[ match ?x with _ => _ end ] |- _ =>
        match (type of x) with
          | { _ } + { _ } => destruct x; clarify
          | bool =>
            let Heq := fresh "Heq" in
            let P := fresh in
            evar(P: Prop);
            assert (Heq: reflect P x) by (subst P; trivial with hahn_refl);
            subst P; destruct Heq as [Heq|Heq]
          | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
        end
    end.

Ltac des_eqrefl :=
  match goal with
    | H: context[match ?X with _ => _ end Logic.eq_refl] |- _ =>
    let EQ := fresh "EQ" in
    let id' := fresh "x" in
    revert H;
    generalize (Logic.eq_refl X); generalize X at 1 3;
    intros id' EQ; destruct id'; intros H
    | |- context[match ?X with _ => _ end Logic.eq_refl] =>
    let EQ := fresh "EQ" in
    let id' := fresh "x" in
    generalize (Logic.eq_refl X); generalize X at 1 3;
    intros id' EQ; destruct id'
  end.

Ltac desf_asm := clarify; des; des_if_asm.

Ltac desf := clarify; des; des_if.

Ltac clarassoc := clarsimp; autorewrite with hahn_trivial hahn hahnA in *; try done.

Ltac hahn__hacksimp1 :=
   clarsimp;
   match goal with
     | H: _ |- _ => solve [rewrite H; clear H; clarsimp
                         |rewrite <- H; clear H; clarsimp]
     | _ => solve [f_equal; clarsimp]
   end.

Ltac hacksimp :=
   clarsimp;
   try match goal with
   | H: _ |- _ => solve [rewrite H; clear H; clarsimp
                              |rewrite <- H; clear H; clarsimp]
   | |- context[match ?p with _ => _ end] => solve [destruct p; hahn__hacksimp1]
   | _ => solve [f_equal; clarsimp]
   end.

Ltac clarify_not :=
  repeat (match goal with
  | H : ~ False |- _ => clear H
  | H : ~ ~ _ |- _ => apply NNPP in H
  | H : ~ _ |- _ => apply imply_to_and in H; desc
  | H : ~ _ |- _ => apply not_or_and in H; desc
  | H : ~ _ |- _ => apply not_and_or in H; des
  | H : ~ _ |- _ => apply not_all_ex_not in H; desc
  end; clarify).

Tactic Notation "tertium_non_datur" constr(P) :=
  destruct (classic P); clarify_not.

Tactic Notation "tertium_non_datur" constr(P) "as" simple_intropattern(pattern) :=
  destruct (classic P) as pattern; clarify_not.

(* ************************************************************************** *)
(** ** Unification helpers *)
(* ************************************************************************** *)

Tactic Notation "pattern_lhs" uconstr(term) :=
  match goal with
    |- _ ?lhs _ =>
    let P := fresh in
    pose (P := lhs); pattern term in P; change lhs with P; subst P
  end.

Tactic Notation "pattern_rhs" uconstr(term) :=
  match goal with
    |- _ _ ?rhs =>
    let P := fresh in
    pose (P := rhs); pattern term in P; change rhs with P; subst P
  end.

(* ************************************************************************** *)
(** ** Exploiting a hypothesis *)
(* ************************************************************************** *)

Tactic Notation "forward" tactic1(tac) :=
  let foo := fresh in
  evar (foo : Prop); cut (foo); subst foo; cycle 1; [tac|].

Tactic Notation "forward" tactic1(tac) "as" simple_intropattern(H) :=
  let foo := fresh in
  evar (foo : Prop); cut (foo); subst foo; cycle 1; [tac|intros H].

Tactic Notation "specialize_full" ident(H) :=
  let foo := fresh in
  evar (foo : Prop); cut (foo); subst foo; cycle 1; [eapply H|try clear H; intro H].

(** Exploit an assumption (adapted from CompCert). *)

Ltac exploit x :=
    refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _ _) _)
 || refine ((fun x y => y x) (x _ _ _) _)
 || refine ((fun x y => y x) (x _ _) _)
 || refine ((fun x y => y x) (x _) _).


(* Default settings (from HsToCoq.Coq.Preamble) *)

Generalizable All Variables.

Unset Implicit Arguments.
Set Maximal Implicit Insertion.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Preamble *)

Require Import CTZ.
Require Import Coq.ZArith.ZArith.
Require Import Data.Bits.

Definition shiftLL (n: N) (s : N) : N := Coq.NArith.BinNat.N.shiftl n s.
Definition shiftRL (n: N) (s : N) : N := Coq.NArith.BinNat.N.shiftr n s.

Definition bit_N s := shiftLL 1%N (Coq.ZArith.BinInt.Z.to_N s).

Definition highestBitMask (n: N) : N := N.pow 2%N (N.log2 n).
Definition lowestBitMask  (n: N) : N := N.pow 2%N (N_ctz n).

Definition bitcount : Coq.Numbers.BinNums.N -> Coq.Numbers.BinNums.N -> Coq.Numbers.BinNums.N :=
  fun a x => (a + N_popcount x)%N.

(* No imports to convert. *)

(* No type declarations to convert. *)

(* No value declarations to convert. *)

(* Skipping definition `Utils.Containers.Internal.BitUtil.bitcount' *)

(* Skipping definition `Utils.Containers.Internal.BitUtil.highestBitMask' *)

(* Skipping definition `Utils.Containers.Internal.BitUtil.shiftRL' *)

(* Skipping definition `Utils.Containers.Internal.BitUtil.shiftLL' *)

(* Skipping definition `Utils.Containers.Internal.BitUtil.wordSize' *)


Set Implicit Arguments.
Require Import FunInd.
Require Import Lists.List.
Require Import Arith.PeanoNat.
Require Import Recdef.
Require Import ArithRing.
Require Import Program.Wf.
Require Import OrderedType OrderedTypeEx.

Add LoadPath ".".
Require Import Node.
Require Import FileSystem.

Module Inode := Node_as_OT Nat_as_OT Nat_as_OT.
Module IM := OrderedTypeFacts Inode.
Definition FileSystem := @FileSystem nat nat.

Lemma size_cons_gt : forall (x:Inode.t) (fs:FileSystem),
    size fs < size (x :: fs).
Proof.
  intros. assert (x :: fs = (x :: nil) ++ fs). 1:auto. rewrite H.
  clear H. rewrite size_concat. pattern (size fs) at 1. rewrite <- Nat.add_0_l.
  apply Nat.add_lt_mono_r. remember (x :: nil) as fs'. destruct x.
  - assert ((fs', nil) = fs_split fs').
    + rewrite Heqfs'. unfold fs_split. reflexivity.
    + rewrite (split_size fs' H). rewrite Heqfs'. unfold size.
      rewrite fold_level_nil. auto.
  - assert ((dir n nil :: nil, l) = fs_split fs').
    + rewrite Heqfs'. unfold fs_split. simpl. rewrite app_nil_r. reflexivity.
    + rewrite (split_size fs' H). simpl. apply Nat.lt_succ_r. apply size_ge_0.
Qed.

Function fs_map_inode (f:Inode.t->Inode.t) (fs:FileSystem)
         {measure size fs} : FileSystem :=
  match fs with
  | nil => nil
  | x::fs' =>
    let x' := match x with
              | file _ _ => f x
              | dir n fs'' => dir n (fs_map_inode f fs'')
              end
    in x' :: fs_map_inode f fs'
  end.
Proof.
  - intros. clear f teq fs. rewrite <- teq0. apply size_cons_gt.
  - intros. clear f teq fs. rewrite <- teq0. apply size_cons_gt.
  - intros. clear f. rewrite <- teq. assert (fs = (dir n fs'' :: nil) ++ fs').
    1:auto. rewrite H. clear H. rewrite size_concat.
    pattern (size fs'') at 1. rewrite <- Nat.add_0_r. apply Nat.add_lt_le_mono.
    + assert ((dir n nil :: nil, fs'') = fs_split (dir n fs'' :: nil)).
      * unfold fs_split. simpl. rewrite app_nil_r. reflexivity.
      * rewrite (split_size (dir n fs'' :: nil) H). auto.
    + apply size_ge_0.
Qed.

Definition fs_set_storage (s:nat) (fs:FileSystem) :=
  let f x := match x with
             | file n _ => file n s
             | dir _ _ => x
             end
  in fs_map_inode f fs.

Fixpoint fs_sort_insert (x:Inode.t) (fs:FileSystem) : FileSystem :=
  match fs with
  | nil => x :: nil
  | x'::fs' => match Inode.compare x x' with
               | LT _ => x :: fs
               | EQ _ => x :: fs
               | GT _ => x' :: fs_sort_insert x fs'
               end
  end.

Lemma fs_sort_insert_comm : forall (x y:Inode.t) (fs:FileSystem),
    Inode.lt x y -> fs_sort_insert x (fs_sort_insert y fs) =
                    fs_sort_insert y (fs_sort_insert x fs).
Proof.
  intros x y fs. revert x y. induction fs; intros; simpl.
  - assert (H0 := H). apply IM.elim_compare_lt in H. destruct H. rewrite H.
    apply IM.elim_compare_gt in H0. destruct H0. rewrite H0. reflexivity.
  - destruct (Inode.compare y a).
    + pose proof (Inode.lt_trans x y a H l). apply IM.elim_compare_lt in H0.
      destruct H0. rewrite H0. simpl. assert (H2 := H).
      apply IM.elim_compare_lt in H. destruct H. rewrite H.
      apply IM.elim_compare_gt in H2. destruct H2. rewrite H1.
      apply IM.elim_compare_lt in l. destruct l. rewrite H2. reflexivity.
    + pose proof (IM.lt_eq H e). apply IM.elim_compare_lt in H0. destruct H0.
      rewrite H0. simpl. assert (H2 := H). apply IM.elim_compare_lt in H.
      destruct H. rewrite H. apply IM.elim_compare_gt in H2. destruct H2.
      rewrite H1. apply IM.elim_compare_eq in e. destruct e. rewrite H2.
      reflexivity.
    + destruct (Inode.compare x a); simpl; apply IM.elim_compare_gt in l;
        destruct l; rewrite H0; apply IM.elim_compare_gt in H; destruct H;
          try rewrite H.
      * apply IM.elim_compare_lt in l0. destruct l0. rewrite H1. reflexivity.
      * apply IM.elim_compare_eq in e. destruct e. rewrite H1. reflexivity.
      * apply IM.elim_compare_gt in l0. destruct l0. rewrite H1.
        specialize (IHfs x y x1). rewrite IHfs. reflexivity.
Qed.

Lemma size_insert : forall (x:Inode.t) (fs:FileSystem),
    size (fs_sort_insert x fs) = size (x :: fs).
Proof.
  intros x fs. induction fs; unfold fs_sort_insert. 1:reflexivity.
  fold fs_sort_insert. destruct (Inode.compare x a); try reflexivity.
  assert (a :: fs_sort_insert x fs = (a :: nil) ++ fs_sort_insert x fs).
  1:reflexivity. rewrite H. rewrite size_concat. rewrite IHfs.
  assert (x :: a :: fs = (x :: a :: nil) ++ fs).
  1:reflexivity. rewrite H0. rewrite size_concat.
  assert (x :: fs = (x :: nil) ++ fs).
  1:reflexivity. rewrite H1. rewrite size_concat.
  assert (x :: a :: nil = (x :: nil) ++ (a :: nil)).
  1:reflexivity. rewrite H2. rewrite size_concat. ring.
Qed.

Fixpoint fs_sort_level (fs:FileSystem) : FileSystem :=
  match fs with
  | nil => nil
  | x::fs' => fs_sort_insert x (fs_sort_level fs')
  end.

Lemma fs_sort_level_insert : forall (x:Inode.t) (fs:FileSystem),
    fs_sort_level (fs_sort_insert x fs) = fs_sort_level (x :: fs).
Proof.
  intros x fs. revert x. induction fs. 1:reflexivity.
  simpl. intro x. destruct (Inode.compare x a); try reflexivity.
  simpl in *. specialize (IHfs x). rewrite IHfs.
  apply (fs_sort_insert_comm a x (fs_sort_level fs) l).
Qed.

Lemma fs_sort_level_dec : forall (x:Inode.t) (fs fs':FileSystem),
    x :: fs = fs_sort_level fs' ->
    exists (fs'':FileSystem), fs = fs_sort_level fs''.
Proof.
  intros x fs fs'. revert x fs. induction fs'; intros. 1:discriminate.
  simpl in H. remember (fs_sort_level fs') as xs. destruct xs.
  - inversion H. eauto.
  - simpl in H. destruct (Inode.compare a n); inversion H; try eauto.
    assert (n :: xs = n :: xs). 1:reflexivity. specialize (IHfs' n xs H0).
    destruct IHfs' as [fs'' IHfs']. rewrite IHfs'.
    assert (fs_sort_insert a (fs_sort_level fs'') = fs_sort_level (a :: fs'')).
    + induction fs''; reflexivity.
    + eauto.
Qed.

Lemma fs_sort_level_double : forall (fs:FileSystem),
    fs_sort_level (fs_sort_level fs) = fs_sort_level fs.
Proof.
  intro fs. induction fs; simpl. 1:reflexivity.
  remember (fs_sort_level fs) as fs'. clear Heqfs' fs.
  pattern fs' at 2. rewrite <- IHfs. clear IHfs.
  revert a. induction fs'; simpl. 1:reflexivity.
  intro a0. destruct (Inode.compare a0 a); try auto. simpl.
  specialize (IHfs' a). rewrite <- IHfs'. clear IHfs'.
  revert a a0 l. induction fs'; intros; simpl.
  - assert (l0 := l). apply IM.elim_compare_lt in l. destruct l. rewrite H.
    apply IM.elim_compare_gt in l0. destruct l0. rewrite H0. reflexivity.
  - destruct (Inode.compare a1 a).
    + pose proof (Inode.lt_trans a0 a1 a l l0). apply IM.elim_compare_lt in H.
      destruct H. rewrite H. simpl.
      apply (fs_sort_insert_comm a0 a1 (fs_sort_insert a (fs_sort_level fs')) l).
    + pose proof (IM.lt_eq l e). apply IM.elim_compare_lt in H. destruct H.
      rewrite H. simpl.
      apply (fs_sort_insert_comm a0 a1 (fs_sort_insert a (fs_sort_level fs')) l).
    + destruct (Inode.compare a0 a); simpl.
      * specialize (IHfs' a a1 l0). rewrite IHfs'.
        rewrite fs_sort_level_insert. simpl.
        apply (fs_sort_insert_comm a0 a1 (fs_sort_insert a (fs_sort_level fs')) l).
      * specialize (IHfs' a a1 l0). rewrite IHfs'.
        rewrite fs_sort_level_insert. simpl.
        apply (fs_sort_insert_comm a0 a1 (fs_sort_insert a (fs_sort_level fs')) l).
      * assert (IHfs'0 := IHfs'). specialize (IHfs' a a1 l0). rewrite IHfs'.
        specialize (IHfs'0 a a0 l1). rewrite IHfs'0.
        apply (fs_sort_insert_comm a0 a1 (fs_sort_level (fs_sort_insert a fs')) l).
Qed.

Lemma size_sorted : forall (fs:FileSystem),
    size (fs_sort_level fs) = size fs.
Proof.
  intro fs. induction fs; unfold fs_sort_level. 1:reflexivity.
  fold fs_sort_level. rewrite size_insert.
  assert (a :: fs = (a :: nil) ++ fs). 1:reflexivity. rewrite H.
  rewrite size_concat. rewrite <- IHfs.
  rewrite <- size_concat. simpl. reflexivity.
Qed.

Function fs_sort_other (fs:FileSystem)
         {measure size fs} : FileSystem :=
  match fs with
  | nil => nil
  | x::fs' =>
    let x' := match x with
              | file _ _ => x
              | dir n fs' => dir n (fs_sort_other (fs_sort_level fs'))
              end
    in x' :: fs_sort_other fs'
  end.
Proof.
  - intros. rewrite <- teq. assert (fs = (file n n0 :: nil) ++ fs').
    1:rewrite teq; reflexivity. rewrite H. rewrite size_concat.
    pattern (size fs') at 1. rewrite <- Nat.add_0_l. apply Nat.add_lt_mono_r.
    pose proof (size_cons_gt (file n n0) nil). unfold size in *.
    rewrite fold_level_nil in H0. assumption.
  - intros. rewrite <- teq. assert (fs = (dir n fs'0 :: nil) ++ fs').
    1:rewrite teq; reflexivity. rewrite H. rewrite size_concat.
    pattern (size fs') at 1. rewrite <- Nat.add_0_l. apply Nat.add_lt_mono_r.
    pose proof (size_cons_gt (dir n fs'0) nil). unfold size in *.
    rewrite fold_level_nil in H0. assumption.
  - intros. rewrite size_sorted. rewrite <- teq.
    assert (fs = (dir n fs'0 :: nil) ++ fs'). 1:rewrite teq; reflexivity.
    rewrite H. rewrite size_concat. pattern (size fs'0) at 1.
    rewrite <- Nat.add_0_r. apply Nat.add_lt_le_mono.
    + assert ((dir n nil :: nil, fs'0) = fs_split (dir n fs'0 :: nil)).
      * unfold fs_split. simpl. rewrite app_nil_r. reflexivity.
      * rewrite (split_size (dir n fs'0 :: nil) H0). auto.
    + apply size_ge_0.
Qed.

Definition fs_sort (fs:FileSystem) : FileSystem :=
  fs_sort_other (fs_sort_level fs).

Fixpoint fs_group_level (fs:FileSystem) : list FileSystem :=
  match fs with
  | nil => nil
  | x::fs' =>
    let
      gs := fs_group_level fs'
    in match gs with
       | nil => (x :: nil) :: nil
       | xs::gs' => match hd_error xs with
                    | None => (x :: nil) :: gs
                    | Some x' => if IM.eqb x x'
                                 then (x :: xs) :: gs'
                                 else (x :: nil) :: gs
                    end
       end
  end.

Definition resolve_names (x1 x2:Inode.t) : (nat * nat)%type :=
  match x1, x2 with
  | dir n1 _,  dir n2 _  => (n1, n2)
  | dir n1 _,  file n2 _ => (n1, n2)
  | file n1 _, dir n2 _  => (n1, n2)
  | file n1 _, file n2 _ => (n1, n2)
  end.

Lemma size_insert_gt_0 : forall (x:Inode.t) (fs:FileSystem),
    0 < size (fs_sort_insert x fs).
Proof.
  intros. unfold fs_sort_insert. destruct fs.
  - pose proof (size_cons_gt x nil). unfold size in *.
    rewrite fold_level_nil in H. assumption.
  - destruct (Inode.compare x n).
    + assert (x :: n :: fs = (x :: nil) ++ (n :: fs)). 1:reflexivity.
      rewrite H. rewrite size_concat.
      pattern 0. rewrite <- Nat.add_0_l. apply Nat.add_lt_le_mono.
      * pose proof (size_cons_gt x nil). unfold size in *.
        rewrite fold_level_nil in H0. assumption.
      * apply size_ge_0.
    + assert (x :: n :: fs = (x :: nil) ++ (n :: fs)). 1:reflexivity.
      rewrite H. rewrite size_concat.
      pattern 0. rewrite <- Nat.add_0_l. apply Nat.add_lt_le_mono.
      * pose proof (size_cons_gt x nil). unfold size in *.
        rewrite fold_level_nil in H0. assumption.
      * apply size_ge_0.
    + fold fs_sort_insert. remember (fs_sort_insert x fs) as fs'.
      assert (n :: fs' = (n :: nil) ++ fs'). 1:reflexivity.
      rewrite H. rewrite size_concat.
      pattern 0. rewrite <- Nat.add_0_l. apply Nat.add_lt_le_mono.
      * pose proof (size_cons_gt n nil). unfold size in *.
        rewrite fold_level_nil in H0. assumption.
      * apply size_ge_0.
Qed.

Lemma size_grouped : forall (fs:FileSystem),
    fold_right Nat.add O (map (fun x => size x) (fs_group_level fs)) = size fs.
Proof.
  intro fs. induction fs.
  - simpl. unfold size. symmetry. apply fold_level_nil.
  - unfold fs_group_level. fold fs_group_level. destruct (fs_group_level fs).
    + rewrite map_cons. simpl. simpl in IHfs.
      assert (a :: fs = (a :: nil) ++ fs). 1:reflexivity.
      rewrite H. rewrite size_concat. rewrite <- IHfs. reflexivity.
    + rewrite map_cons in IHfs. simpl in IHfs. destruct (hd_error f).
      * destruct (IM.eqb a n); assert (a :: fs = (a :: nil) ++ fs);
          try reflexivity; rewrite H; rewrite size_concat.
        -- rewrite map_cons. assert (a :: f = (a :: nil) ++ f). 1:reflexivity.
           rewrite H0. rewrite size_concat. rewrite <- IHfs.
           unfold fold_right. ring_simplify. reflexivity.
        -- do 2 rewrite map_cons. rewrite <- IHfs. unfold fold_right.
           ring_simplify. reflexivity.
      * do 2 rewrite map_cons. assert (a :: fs = (a :: nil) ++ fs).
        1:reflexivity. rewrite H. rewrite size_concat.
        rewrite <- IHfs. unfold fold_right. ring_simplify. reflexivity.
Qed.

Lemma size_compacted :
  forall (n n1 n2:nat) (fs fs1 fs2:FileSystem),
    size (dir n (fs1 ++ fs2) :: fs) <
    size (dir n1 fs1 :: dir n2 fs2 :: fs).
Proof.
  intros. assert (dir n (fs1 ++ fs2) :: fs = (dir n (fs1 ++ fs2) :: nil) ++ fs).
  1:reflexivity. rewrite H. rewrite size_concat.
  assert (dir n1 fs1 :: dir n2 fs2 :: fs =
          (dir n1 fs1 :: dir n2 fs2 :: nil) ++ fs).
  1:reflexivity. rewrite H0. rewrite size_concat.
  apply Nat.add_lt_mono_r.
  remember (fs_split (dir n (fs1 ++ fs2) :: nil)) as p.
  assert (H1 := Heqp). unfold fs_split in H1. simpl in H1.
  rewrite app_nil_r in H1. rewrite Heqp in H1. symmetry in H1. clear Heqp p.
  rewrite (split_size (dir n (fs1 ++ fs2) :: nil) H1).
  assert (dir n1 fs1 :: dir n2 fs2 :: nil =
          (dir n1 fs1 :: nil) ++ (dir n2 fs2 :: nil)).
  1:reflexivity. rewrite H2. do 2 rewrite size_concat.
  remember (fs_split (dir n1 fs1 :: nil)) as p.
  assert (H3 := Heqp). unfold fs_split in H3. simpl in H3.
  rewrite app_nil_r in H3. rewrite Heqp in H3. symmetry in H3. clear Heqp p.
  rewrite (split_size (dir n1 fs1 :: nil) H3).
  remember (fs_split (dir n2 fs2 :: nil)) as q.
  assert (H4 := Heqq). unfold fs_split in H4. simpl in H4.
  rewrite app_nil_r in H4. rewrite Heqq in H4. symmetry in H4. clear Heqq q.
  rewrite (split_size (dir n2 fs2 :: nil) H4). simpl.
  rewrite <- Nat.succ_lt_mono. apply Nat.add_lt_mono_l. auto.
Qed.

Lemma size_perm : forall (x1 x2:Inode.t) (fs:FileSystem),
    size (x1 :: x2 :: fs) = size (x2 :: x1 :: fs).
Proof.
  intros. assert (x1 :: x2 :: fs = (x1 :: nil) ++ (x2 :: fs)).
  1:reflexivity. assert (x2 :: x1 :: fs = (x2 :: nil) ++ (x1 :: fs)).
  1:reflexivity. rewrite H. rewrite H0. do 2 rewrite size_concat.
  assert (x1 :: fs = (x1 :: nil) ++ fs). 1:reflexivity.
  assert (x2 :: fs = (x2 :: nil) ++ fs). 1:reflexivity.
  rewrite H1. rewrite H2. do 2 rewrite size_concat. ring.
Qed.

Function fs_compact_group (fs:FileSystem)
         {measure size fs} : option Inode.t :=
  match fs with
  | nil => None
  | x1::nil => Some x1
  | x1::x2::fs' =>
    if IM.eqb x1 x2
    then let
        (n1, n2) := resolve_names x1 x2
      in match x1, x2 with
         | dir _ fs1, dir _ fs2 => fs_compact_group (dir n1 (fs1 ++ fs2) :: fs')
         | file _ _, file _ _ => fs_compact_group (x1 :: fs')
         | _, _ => None
         end
    else None
  end.
Proof.
  - intros. rewrite size_perm. apply size_cons_gt.
  - intros. apply (f_equal (fun x => size x)) in teq. symmetry in teq.
    apply (size_compacted n1 n n0 fs' fs1 fs2).
Qed.

Lemma fs_compacted_group_eq : forall (x y:Inode.t) (fs:FileSystem),
    fs_compact_group (x :: fs) = Some y -> Inode.eq x y.
Proof.
  intros x y fs. remember (x :: fs) as fs'. revert x fs Heqfs'.
  functional induction fs_compact_group fs'; intros; inversion H.
  - inversion Heqfs'. rewrite <- H1. rewrite <- H2. reflexivity.
  - specialize (IHo (dir n1 (fs1 ++ fs2)) fs').
    assert (dir n1 (fs1 ++ fs2) :: fs' = dir n1 (fs1 ++ fs2) :: fs').
    1:reflexivity. specialize (IHo H0 H). inversion Heqfs'. simpl in e1.
    inversion e1. simpl in IHo. destruct y; inversion IHo. simpl. reflexivity.
  - specialize (IHo (file _x _x0) fs').
    assert (file _x _x0 :: fs' = file _x _x0 :: fs'). 1:reflexivity.
    specialize (IHo H0 H). inversion Heqfs'. assumption.
Qed.

Lemma fs_compacted_group_dir_cons : forall (n:nat) (fs fs1 fs2:FileSystem),
    fs_compact_group (dir n fs1 :: dir n fs2 :: fs) =
    fs_compact_group (dir n (fs1 ++ fs2) :: fs).
Proof.
  intros. remember (dir n fs1 :: dir n fs2 :: fs) as fs'.
  functional induction fs_compact_group fs'; inversion Heqfs'.
  - repeat f_equal. simpl in e1. inversion e1. rewrite <- H5. assumption.
  - rewrite H0 in y. rewrite H1 in y. inversion y.
  - rewrite H0 in e0. rewrite H1 in e0. simpl in e0.
    assert (n = n). 1:reflexivity. rewrite IM.eqb_alt in e0.
    destruct (Inode.compare (dir n fs1) (dir n fs2)); try discriminate;
      simpl in l; contradiction (Nat.lt_irrefl n).
Qed.

Lemma fs_compacted_group_file_cons : forall (n:nat) (s:nat) (fs:FileSystem),
    fs_compact_group (file n s :: file n s :: fs) =
    fs_compact_group (file n s :: fs).
Proof.
  intros. remember (file n s :: file n s :: fs) as fs'.
  functional induction fs_compact_group fs'; inversion Heqfs'.
  - reflexivity.
  - rewrite H0 in y. rewrite H1 in y. inversion y.
  - rewrite H0 in e0. rewrite H1 in e0. simpl in e0. rewrite IM.eqb_alt in e0.
    destruct (Inode.compare (file n s) (file n s)); try discriminate;
      simpl in l; destruct l; try contradiction (Nat.lt_irrefl n);
        destruct H; contradiction (Nat.lt_irrefl s).
Qed.

Lemma fs_compacted_group_cons : forall (x y:Inode.t) (fs:FileSystem),
    fs_compact_group fs = Some y -> Inode.eq x y ->
    exists (z:Inode.t), fs_compact_group (x :: fs) = Some z.
Proof.
  intros. remember (x :: fs) as fs'.
  destruct x; destruct y; intros. simpl in H0; inversion H0.
  - rewrite <- H1, <- H2 in H. clear H0 H1 H2 n1 n2.
    functional induction fs_compact_group fs; inversion H.
    + rewrite <- H1 in Heqfs'. rewrite Heqfs'. rewrite <- Heqfs'.
      assert (fs_compact_group fs' = fs_compact_group (x1 :: nil)).
      1:rewrite Heqfs', H1; apply fs_compacted_group_file_cons. rewrite H0.
      clear H0. remember (x1 :: nil) as fs.
      functional induction fs_compact_group fs; inversion Heqfs. eauto.
    + pose proof (fs_compacted_group_eq (dir n1 (fs1 ++ fs2)) fs'0 H).
      simpl in H0. contradiction.
    + rewrite IM.eqb_alt in e0.
      destruct (Inode.compare (file _x _x0) (file _x1 _x2)) in e0;
        try discriminate. simpl in e. inversion e. rewrite <- H0, <- H2 in Heqfs'.
      pose proof (fs_compacted_group_eq (file _x _x0) fs'0 H). simpl in H3.
      inversion H3. rewrite H4, H5 in Heqfs', H. rewrite Heqfs'.
      do 2 rewrite fs_compacted_group_file_cons. eauto.
  - simpl in H0. contradiction.
  - simpl in H0. contradiction.
  - simpl in H0. rewrite <- H0 in H. revert fs' Heqfs'.
    functional induction fs_compact_group fs; inversion H; intros.
    + remember (dir n (l ++ l0) :: nil) as fs.
      assert (fs_compact_group fs' = fs_compact_group fs).
      1:rewrite Heqfs', Heqfs. apply fs_compacted_group_dir_cons. rewrite H1.
      clear H1. functional induction fs_compact_group fs; inversion Heqfs. eauto.
    + specialize (IHo H). rewrite IM.eqb_alt in e0.
      destruct (Inode.compare (dir _x fs1) (dir _x0 fs2)); try discriminate e0.
      simpl in e. rewrite <- e in e1, Heqfs'. simpl in e1. inversion e1.
      rewrite H3 in Heqfs'. remember (dir n l :: dir n1 (fs1 ++ fs2) :: fs') as fs.
      specialize (IHo fs Heqfs).
      pose proof (fs_compacted_group_eq (dir n1 (fs1 ++ fs2)) fs' H).
      simpl in H1. rewrite H1 in H, Heqfs, Heqfs'.
      assert (fs_compact_group fs'0 = fs_compact_group fs).
      * rewrite Heqfs, Heqfs'. do 3 rewrite fs_compacted_group_dir_cons.
        rewrite <- List.app_assoc. reflexivity.
      * rewrite H5. assumption.
    + pose proof (fs_compacted_group_eq (file _x _x0) fs' H). simpl in H1.
      contradiction.
Qed.

Fixpoint fs_compact_groups (gs:list FileSystem) : FileSystem :=
  match gs with
  | nil => nil
  | g::gs' => match fs_compact_group g with
              | None => fs_compact_groups gs'
              | Some x => x :: fs_compact_groups gs'
              end
  end.

Lemma fs_compact_groups_dec : forall (gs:list FileSystem),
    size (fs_compact_groups gs) <=
    fold_right Nat.add O (map (fun x => size x) gs).
Proof.
  intros. induction gs.
  - simpl. unfold size.
    rewrite (fold_level_nil (fun _ => S) O). auto.
  - unfold fs_compact_groups. fold fs_compact_groups.
    functional induction (fs_compact_group a).
    + simpl. pattern (size (fs_compact_groups gs)).
      rewrite <- Nat.add_0_l. revert IHgs. apply Nat.add_le_mono.
      unfold size. rewrite (fold_level_nil (fun _ => S) O). auto.
    + transitivity
        (size (x1 :: nil) + size (fs_compact_groups gs)).
      * rewrite <- size_concat. auto.
      * rewrite map_cons. simpl. apply Nat.add_le_mono_l. assumption.
    + rewrite IHo. simpl. apply Nat.add_le_mono_r. apply Nat.lt_eq_cases.
      left. apply (size_compacted n1 _x _x0 fs' fs1 fs2).
    + rewrite IHo. simpl. apply Nat.add_le_mono_r.
      rewrite size_perm. apply Nat.lt_eq_cases. left.
      apply size_cons_gt.
    + rewrite IHgs. simpl.
      pattern (fold_right Nat.add 0 (map (fun x => size x) gs)) at 1.
      rewrite <- Nat.add_0_l.
      apply Nat.add_le_mono; [apply size_ge_0 | auto].
    + simpl. pattern (size (fs_compact_groups gs)) at 1.
      rewrite <- Nat.add_0_l. apply Nat.add_le_mono;
                                [apply size_ge_0 | assumption].
Qed.

Definition fs_compact_level (fs:FileSystem) : FileSystem :=
  fs_compact_groups (fs_group_level fs).

Lemma fs_compact_level_dec : forall (fs:FileSystem),
    size (fs_compact_level fs) <= size fs.
Proof.
  intro fs. induction fs; unfold fs_compact_level. 1:auto.
  rewrite fs_compact_groups_dec. rewrite size_grouped. auto.
Qed.

Function fs_compact_other (fs:FileSystem)
         {measure size fs} : FileSystem :=
  match fs with
  | nil => nil
  | x::fs' =>
    let x' := match x with
              | file _ _ => x
              | dir n fs' => dir n (fs_compact_other (fs_compact_level fs'))
              end
    in x' :: fs_compact_other fs'
  end.
Proof.
  - intros. rewrite <- teq. assert (fs = (x :: nil) ++ fs').
    1:rewrite teq, teq0; reflexivity. rewrite H. rewrite size_concat.
    pattern (size fs') at 1. rewrite <- Nat.add_0_l.
    apply Nat.add_lt_mono_r. pose proof (size_cons_gt x nil). unfold size in *.
    rewrite fold_level_nil in H0. assumption.
  - intros. rewrite <- teq. assert (fs = (x :: nil) ++ fs').
    1:rewrite teq, teq0; reflexivity. rewrite H. rewrite size_concat.
    pattern (size fs') at 1. rewrite <- Nat.add_0_l. apply Nat.add_lt_mono_r.
    pose proof (size_cons_gt x nil). unfold size in *.
    rewrite fold_level_nil in H0. assumption.
  - intros. rewrite <- teq. assert (fs = (x :: nil) ++ fs').
    1:rewrite teq, teq0; reflexivity. rewrite H. rewrite size_concat.
    pattern (size (fs_compact_level fs'0)) at 1.
    rewrite <- Nat.add_0_r. apply Nat.add_lt_le_mono.
    + remember (fs_split (x :: nil)) as p. assert (H0 := Heqp).
      rewrite teq0 in H0. unfold fs_split in H0. simpl in H0.
      rewrite Heqp in H0. clear Heqp p. rewrite app_nil_r in H0.
      symmetry in H0. rewrite (split_size (x :: nil) H0). simpl.
      apply Nat.lt_succ_r. apply fs_compact_level_dec.
    + apply size_ge_0.
Qed.

Definition fs_compact (fs:FileSystem) : FileSystem :=
  fs_compact_other (fs_compact_level fs).

Definition fs_merge (fs1 fs2:FileSystem) : FileSystem :=
  fs_compact (fs_sort (fs1 ++ fs2)).

Fixpoint fs_inode_lookup (x:Inode.t) (fs:FileSystem) : option Inode.t :=
  match fs with
  | nil => None
  | x'::fs' => if IM.eqb x x'
               then Some x'
               else fs_inode_lookup x fs'
  end.

Fixpoint fs_find (xs:list Inode.t) (fs:FileSystem) : Prop :=
  match xs with
  | nil => True
  | x::xs' => match fs_inode_lookup x fs with
              | None => False
              | Some x' => match x' with
                           | file _ _ => fs_find xs' nil
                           | dir _ fs' => fs_find xs' fs'
                           end
              end
  end.

Fixpoint fs_inode_lookup_group (x:Inode.t) (gs:list FileSystem) : option Inode.t :=
  match gs with
  | nil => None
  | g::gs' => match fs_inode_lookup x g with
              | Some y => Some y
              | None => fs_inode_lookup_group x gs'
              end
  end.

Lemma fs_lookup_eq : forall (x y:Inode.t) (fs:FileSystem),
    fs_inode_lookup x fs = Some y -> Inode.eq x y.
Proof.
  intros. induction fs; simpl in H. 1:discriminate H.
  case_eq (IM.eqb x a); intro H0. rewrite H0 in H. inversion H.
  - rewrite H2 in H0. rewrite IM.eqb_alt in H0.
    destruct (Inode.compare x y); try discriminate H0. assumption.
  - rewrite H0 in H. specialize (IHfs H). assumption.
Qed.

Lemma fs_lookup_cons_none : forall (x y:Inode.t) (fs:FileSystem),
    fs_inode_lookup x (y :: fs) = None -> fs_inode_lookup x fs = None.
Proof.
  intros. unfold fs_inode_lookup in H.
  fold fs_inode_lookup in H. destruct (IM.eqb x y); [discriminate H | assumption].
Qed.

Lemma fs_lookup_cons_some : forall (x y:Inode.t) (fs:FileSystem),
    fs_inode_lookup x fs = Some y -> exists (z:Inode.t),
      fs_inode_lookup x (y :: fs) = Some z.
Proof.
  intros. unfold fs_inode_lookup in H. destruct fs. 1:discriminate.
  fold fs_inode_lookup in H. case_eq (IM.eqb x n); intro H0; rewrite H0 in H.
  - inversion H. rewrite H2 in H0. exists y. simpl. rewrite H0. reflexivity.
  - exists y. simpl. destruct (IM.eqb x y). 1:reflexivity.
    rewrite H0. assumption.
Qed.

Lemma fs_lookup_inserted : forall (x x' y:Inode.t) (fs:FileSystem),
    fs_inode_lookup x fs = Some x' -> exists (z:Inode.t),
      fs_inode_lookup x (fs_sort_insert y fs) = Some z.
Proof.
  intros. induction fs. 1:discriminate H. simpl. destruct (Inode.compare y a).
  - simpl. destruct (IM.eqb x y).
    + exists y. reflexivity.
    + simpl in H. rewrite H. exists x'. reflexivity.
  - simpl. destruct (IM.eqb x y).
    + exists y. reflexivity.
    + simpl in H. rewrite H. exists x'. reflexivity.
  - simpl in *. destruct (IM.eqb x a).
    + exists a. reflexivity.
    + specialize (IHfs H). assumption.
Qed.

Lemma fs_lookup_sorted_level : forall (x y:Inode.t) (fs:FileSystem),
    fs_inode_lookup x fs = Some y -> exists (z:Inode.t),
      fs_inode_lookup x (fs_sort_level fs) = Some z.
Proof.
  intros x y fs. revert x y. induction fs; intros. 1:discriminate H.
  simpl. simpl in H. case_eq (IM.eqb x a); intro H0; rewrite H0 in H.
  - inversion H. rewrite H2 in H0. clear H H2 a. clear IHfs.
    remember (fs_sort_level fs) as fs'. clear Heqfs' fs.
    induction fs'; simpl. 1:rewrite H0; eauto.
    destruct (Inode.compare y a); simpl; try (rewrite H0; eauto).
    destruct (IM.eqb x a); [eauto | assumption].
  - specialize (IHfs x y H). remember (fs_sort_level fs) as fs'.
    clear Heqfs' H y fs. destruct IHfs as [y IHfs].
    induction fs'. 1:discriminate. simpl.
    destruct (Inode.compare a a0); simpl; case_eq (IM.eqb x a0); intro;
      try (rewrite H0); eauto; simpl in IHfs; rewrite H in IHfs; eauto.
Qed.

Lemma fs_lookup_sorted : forall (x y:Inode.t) (fs:FileSystem),
    fs_inode_lookup x fs = Some y -> exists (z:Inode.t),
      fs_inode_lookup x (fs_sort fs) = Some z.
Proof.
  intros. unfold fs_sort.
  assert (exists (z:Inode.t), fs_inode_lookup x (fs_sort_level fs) = Some z).
  1:apply (fs_lookup_sorted_level x fs H). remember (fs_sort_level fs) as fs'.
  clear H Heqfs' y fs. destruct H0 as [y H0].
  functional induction fs_sort_other fs'; simpl in H0.
  - discriminate.
  - simpl. destruct (IM.eqb x (file _x _x0)). 1:eauto.
    specialize (IHf H0). assumption.
  - remember (fs_sort_other (fs_sort_level fs'0)) as fs.
    case_eq (IM.eqb x (dir n fs'0)); intro H; rewrite H in H0;
      destruct x; simpl in H.
    + rewrite IM.eqb_alt in H. destruct (Inode.compare (file n0 n1) (dir n fs'0));
                                 discriminate H || contradiction.
    + rewrite IM.eqb_alt in H.
      destruct (Inode.compare (dir n0 l) (dir n fs'0)); try discriminate H.
      simpl in *. rewrite e. assert (IM.eqb (dir n l) (dir n fs) = true).
      * rewrite IM.eqb_alt.
        destruct (Inode.compare (dir n l) (dir n fs)); try reflexivity;
          simpl in *; contradiction (Nat.lt_irrefl n).
      * rewrite H1. eauto.
    + specialize (IHf0 H0). simpl.
      destruct (IM.eqb (file n0 n1) (dir n fs)); [eauto | assumption].
    + specialize (IHf0 H0). simpl.
      destruct (IM.eqb (dir n0 l) (dir n fs)); [eauto | assumption].
Qed.

Lemma fs_lookup_grouped_level : forall (x y:Inode.t) (fs:FileSystem),
    fs_inode_lookup x fs = Some y -> exists (z:Inode.t),
      fs_inode_lookup_group x (fs_group_level fs) = Some z.
Proof.
  intros x y fs. revert x y. induction fs; intros. 1:discriminate H.
  simpl in H. case_eq (IM.eqb x a); intro H0; rewrite H0 in H.
  - inversion H. rewrite H2 in H0. simpl. destruct (fs_group_level fs).
    + simpl. rewrite H0. eauto.
    + destruct (hd_error f); try (destruct (IM.eqb y n));
        simpl; rewrite H0; eauto.
  - specialize (IHfs x y H). destruct IHfs as [z IHfs].
    simpl. destruct (fs_group_level fs).
    + unfold fs_inode_lookup_group in IHfs. discriminate.
    + destruct (hd_error f); try (destruct (IM.eqb a n)); simpl; rewrite H0;
        simpl in IHfs; rewrite IHfs; eauto.
Qed.


(*! WTT Typing *)

From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
From Equations Require Import Equations.
From Translation
Require Import util Sorts WAst WLiftSubst WEquality.
Import ListNotations.

Open Scope w_scope.

(* Preliminaries *)
Section Prelim.

Context `{Sort_notion : Sorts.notion}.

Definition wcontext := list wterm.

Definition wsnoc (Γ : wcontext) (d : wterm) := d :: Γ.

(** Global contexts of axioms
    Basically a list of ITT types.
 *)
Record glob_decl := { dname : ident ; dtype : wterm ; dbody : wterm }.

Definition wglobal_context : Type := list glob_decl.

Definition lookup_glob (Σ : wglobal_context) (id : ident) :=
  List.find (fun d => ident_eq id (dname d)) Σ.

Definition wapp_context (Γ Γ' : wcontext) : wcontext := (Γ' ++ Γ)%list.

End Prelim.

Notation " Γ ,, d " := (wsnoc Γ d) (at level 20, d at next level) : w_scope.
Notation " Γ  ,,, Γ' " :=
  (wapp_context Γ Γ')
    (at level 25, Γ' at next level, left associativity) : w_scope.

(*! Typing *)

Section WTyping.

Context `{Sort_notion : Sorts.notion}.

Reserved Notation " Σ ;;; Γ '|-w' t : T " (at level 50, Γ, t, T at next level).

Inductive typing (Σ : wglobal_context) : wcontext -> wterm -> wterm -> Prop :=
| type_Rel Γ n :
    wf Σ Γ ->
    forall A,
      nth_error Γ n = Some A ->
      Σ ;;; Γ |-w (wRel n) : lift0 (S n) A

| type_Sort Γ s :
    wf Σ Γ ->
    Σ ;;; Γ |-w (wSort s) : wSort (Sorts.succ s)

| type_Prod Γ n A B s1 s2 :
    Σ ;;; Γ |-w A : wSort s1 ->
    Σ ;;; Γ ,, A |-w B : wSort s2 ->
    Σ ;;; Γ |-w wProd n A B : wSort (Sorts.prod_sort s1 s2)

| type_Lambda Γ n n' t s A B :
    Σ ;;; Γ |-w A : wSort s ->
    Σ ;;; Γ ,, A |-w t : B ->
    Σ ;;; Γ |-w wLambda n A t : wProd n' A B

| type_App Γ n t A B u :
    Σ ;;; Γ |-w t : wProd n A B ->
    Σ ;;; Γ |-w u : A ->
    Σ ;;; Γ |-w wApp t u : B{ 0 := u }

| type_Sum Γ n t b s1 s2 :
    Σ ;;; Γ |-w t : wSort s1 ->
    Σ ;;; Γ ,, t |-w b : wSort s2 ->
    Σ ;;; Γ |-w (wSum n t b) : wSort (Sorts.sum_sort s1 s2)

| type_Pair Γ n A B u v s1 s2 :
    Σ ;;; Γ |-w A : wSort s1 ->
    Σ ;;; Γ ,, A |-w B : wSort s2 ->
    Σ ;;; Γ |-w u : A ->
    Σ ;;; Γ |-w v : B{ 0 := u } ->
    Σ ;;; Γ |-w wPair A B u v : wSum n A B

| type_Pi1 Γ n A B s1 s2 p :
    Σ ;;; Γ |-w p : wSum n A B ->
    Σ ;;; Γ |-w A : wSort s1 ->
    Σ ;;; Γ ,, A |-w B : wSort s2 ->
    Σ ;;; Γ |-w wPi1 A B p : A

| type_Pi2 Γ n A B s1 s2 p :
    Σ ;;; Γ |-w p : wSum n A B ->
    Σ ;;; Γ |-w A : wSort s1 ->
    Σ ;;; Γ ,, A |-w B : wSort s2 ->
    Σ ;;; Γ |-w wPi2 A B p : B{ 0 := wPi1 A B p }

| type_Eq Γ s A u v :
    Σ ;;; Γ |-w A : wSort s ->
    Σ ;;; Γ |-w u : A ->
    Σ ;;; Γ |-w v : A ->
    Σ ;;; Γ |-w wEq A u v : wSort (Sorts.eq_sort s)

| type_Refl Γ s A u :
    Σ ;;; Γ |-w A : wSort s ->
    Σ ;;; Γ |-w u : A ->
    Σ ;;; Γ |-w wRefl A u : wEq A u u

| type_J Γ s1 s2 A u v P p w :
    Σ ;;; Γ |-w A : wSort s1 ->
    Σ ;;; Γ |-w u : A ->
    Σ ;;; Γ |-w v : A ->
    Σ ;;; Γ ,, A ,, (wEq (lift0 1 A) (lift0 1 u) (wRel 0)) |-w P : wSort s2 ->
    Σ ;;; Γ |-w p : wEq A u v ->
    Σ ;;; Γ |-w w : P{ 1 := u }{ 0 := wRefl A u } ->
    Σ ;;; Γ |-w wJ A u P w v p : P{ 1 := v }{ 0 := p }

| type_Transport Γ s T1 T2 p t :
    Σ ;;; Γ |-w T1 : wSort s ->
    Σ ;;; Γ |-w T2 : wSort s ->
    Σ ;;; Γ |-w p : wEq (wSort s) T1 T2 ->
    Σ ;;; Γ |-w t : T1 ->
    Σ ;;; Γ |-w wTransport T1 T2 p t : T2

| type_Beta Γ s A B t u n :
    Σ ;;; Γ |-w A : wSort s ->
    Σ ;;; Γ ,, A |-w t : B ->
    Σ ;;; Γ |-w u : A ->
    Σ ;;; Γ |-w wBeta t u : wEq (B{ 0 := u })
                               (wApp (wLambda n A t) u)
                               (t{ 0 := u })

| type_K Γ A u p s :
    Σ ;;; Γ |-w p : wEq A u u ->
    Σ ;;; Γ |-w A : wSort s ->
    Σ ;;; Γ |-w u : A ->
    Σ ;;; Γ |-w wK A u p : wEq (wEq A u u) p (wRefl A u)

| type_Funext Γ A B f g p n nx n1 n2 :
    Σ ;;; Γ |-w p : wProd nx A
                     (wEq B (wApp (lift0 1 f) (wRel 0))
                            (wApp (lift0 1 g) (wRel 0))) ->
    Σ ;;; Γ |-w f : wProd n1 A B ->
    Σ ;;; Γ |-w g : wProd n2 A B ->
    Σ ;;; Γ |-w wFunext f g p : wEq (wProd n A B) f g

| type_JBeta Γ A u P w s1 s2 :
    Σ ;;; Γ |-w u : A ->
    Σ ;;; Γ ,, A ,, (wEq (lift0 1 A) (lift0 1 u) (wRel 0)) |-w P : wSort s2 ->
    Σ ;;; Γ |-w w : P{ 1 := u }{ 0 := wRefl A u } ->
    Σ ;;; Γ |-w A : wSort s1 ->
    Σ ;;; Γ |-w wJBeta u P w : wEq (P{ 1 := u }{ 0 := wRefl A u })
                                (wJ A u P w u (wRefl A u))
                                w

| type_TransportBeta Γ s A t :
    Σ ;;; Γ |-w A : wSort s ->
    Σ ;;; Γ |-w t : A ->
    Σ ;;; Γ |-w wTransportBeta A t
             : wEq A (wTransport A A (wRefl (wSort s) A) t) t

| type_PairEta Γ A B p n n' :
    Σ ;;; Γ |-w p : wSum n A B ->
    Σ ;;; Γ |-w wPairEta p
             : wEq (wSum n' A B) (wPair A B (wPi1 A B p) (wPi2 A B p)) p

| type_ProdExt Γ A B1 B2 n1 n2 p s1 s2 :
    Σ ;;; Γ,, A |-w p : wEq (wSort s2) B1 B2 ->
    Σ ;;; Γ |-w A : wSort s1 ->
    Σ ;;; Γ |-w wProdExt A p : wEq (wSort (prod_sort s1 s2)) (wProd n1 A B1) (wProd n2 A B2)

| type_SumExt Γ A B1 B2 n1 n2 p s1 s2 :
    Σ ;;; Γ,, A |-w p : wEq (wSort s2) B1 B2 ->
    Σ ;;; Γ |-w A : wSort s1 ->
    Σ ;;; Γ |-w wSumExt A p : wEq (wSort (sum_sort s1 s2)) (wSum n1 A B1) (wSum n2 A B2)

| type_Ax Γ id d :
    wf Σ Γ ->
    lookup_glob Σ id = Some d ->
    Σ ;;; Γ |-w wAx id : dtype d

| type_Delta Γ id d :
    wf Σ Γ ->
    lookup_glob Σ id = Some d ->
    Σ ;;; Γ |-w wDelta id : wEq (dtype d) (wAx id) (dbody d)

| type_rename Γ t A B :
    Σ ;;; Γ |-w t : A ->
    nl A = nl B ->
    Σ ;;; Γ |-w t : B

where " Σ ;;; Γ '|-w' t : T " := (@typing Σ Γ t T) : w_scope

with wf (Σ : wglobal_context) : wcontext -> Prop :=
| wf_nil :
    wf Σ nil

| wf_snoc s Γ A :
    wf Σ Γ ->
    Σ ;;; Γ |-w A : wSort s ->
    wf Σ (Γ ,, A)
.

End WTyping.

Notation " Σ ;;; Γ '|-w' t : T " :=
  (@typing _ Σ Γ t T) (at level 50, Γ, t, T at next level) : w_scope.

Derive Signature for typing.
Derive Signature for wf.

Delimit Scope w_scope with w.

Section Global.

Context `{Sort_notion : Sorts.notion}.

Definition isType (Σ : wglobal_context) (Γ : wcontext) (t : wterm) :=
  exists s, Σ ;;; Γ |-w t : wSort s.

Inductive fresh_glob (id : ident) : wglobal_context -> Prop :=
| fresh_glob_nil : fresh_glob id []
| fresh_glob_cons Σ d :
    fresh_glob id Σ ->
    (dname d) <> id ->
    fresh_glob id (d :: Σ).

Inductive type_glob : wglobal_context -> Type :=
| type_glob_nil : type_glob []
| type_glob_cons Σ d :
    type_glob Σ ->
    fresh_glob (dname d) Σ ->
    isType Σ [] (dtype d) ->
    Σ ;;; [] |-w dbody d : dtype d ->
    type_glob (d :: Σ).

End Global.

Derive Signature for fresh_glob.
Derive Signature for type_glob.


(**********************************************************************

 Monads in the bicategory of enriched categories

 We give some useful statements when using monads internal to the
 bicategory of enriched categories.

 **********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentMonad.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.EnrichedCats.
Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfUnivCats.
Require Import UniMath.Bicategories.Monads.Examples.MonadsInTotalBicat.

Local Open Scope cat.

Section EnrichmentMonads.
  Context (V : monoidal_cat).

  Definition make_mnd_enriched_cats
             {C : univalent_category}
             (E : enrichment C V)
             (M : Monad C)
             (EM : monad_enrichment E M)
    : mnd (bicat_of_enriched_cats V).
  Proof.
    use make_mnd_total_bicat.
    - apply disp_2cell_isapprop_enriched_cats.
    - exact (Monad_to_mnd_bicat_of_univ_cats M).
    - use make_disp_mnd ; cbn.
      + exact E.
      + exact EM.
      + exact (unit_of_monad_enrichment EM).
      + exact (mu_of_monad_enrichment EM).
  Defined.

  Definition Monad_from_mnd_enriched_cats
             (M : mnd (bicat_of_enriched_cats V))
    : Monad (pr11 (ob_of_mnd M))
    := mnd_bicat_of_univ_cats_to_Monad (pr1_of_mnd_total_bicat M).

  Definition Monad_enrichment_from_mnd_enriched_cats
             (M : mnd (bicat_of_enriched_cats V))
    : monad_enrichment
        (pr2 (ob_of_mnd M))
        (Monad_from_mnd_enriched_cats M).
  Proof.
    simple refine (_ ,, _ ,, _).
    - exact (pr2 (endo_of_mnd M)).
    - exact (pr2 (unit_of_mnd M)).
    - exact (pr2 (mult_of_mnd M)).
  Defined.

  Section MonadMorProjections.
    Context {m₁ m₂ : mnd (bicat_of_enriched_cats V)}
            (f : m₁ --> m₂).

    Let C₁ : univalent_category := pr1 (ob_of_mnd m₁).
    Let C₂ : univalent_category := pr1 (ob_of_mnd m₂).
    Let M₁ : Monad C₁ := Monad_from_mnd_enriched_cats m₁.
    Let M₂ : Monad C₂ := Monad_from_mnd_enriched_cats m₂.
    Let η₁ : functor_identity _ ⟹ M₁ := pr1 (unit_of_mnd m₁).
    Let η₂ : functor_identity _ ⟹ M₂ := pr1 (unit_of_mnd m₂).
    Let μ₁ : M₁ ∙ M₁ ⟹ M₁ := pr1 (mult_of_mnd m₁).
    Let μ₂ : M₂ ∙ M₂ ⟹ M₂ := pr1 (mult_of_mnd m₂).
    Let F : C₁ ⟶ C₂ := pr1 (mor_of_mnd_mor f).
    Let Fm : F ∙ M₂ ⟹ M₁ ∙ F := pr1 (mnd_mor_endo f).

    Definition mnd_mor_unit_enriched
               (x : C₁)
      : #F (η₁ x) = η₂ (F x) · Fm x.
    Proof.
      pose (maponpaths (λ z, pr11 z x) (mnd_mor_unit f)) as p.
      cbn in p.
      rewrite !id_left in p.
      exact p.
    Qed.

    Definition mnd_mor_mu_enriched
               (x : C₁)
      : #M₂ (Fm x) · Fm (M₁ x) · #F (μ₁ x) = μ₂ (F x) · Fm x.
    Proof.
      pose (maponpaths (λ z, pr11 z x) (mnd_mor_mu f)) as p.
      cbn in p.
      rewrite !id_left in p.
      rewrite !id_right in p.
      exact p.
    Qed.
  End MonadMorProjections.

  Section MonadCellProjections.
    Context {m₁ m₂ : mnd (bicat_of_enriched_cats V)}
            {f₁ f₂ : m₁ --> m₂}
            (τ : f₁ ==> f₂).

    Let C₁ : univalent_category := pr1 (ob_of_mnd m₁).
    Let C₂ : univalent_category := pr1 (ob_of_mnd m₂).
    Let M₁ : Monad C₁ := Monad_from_mnd_enriched_cats m₁.
    Let M₂ : Monad C₂ := Monad_from_mnd_enriched_cats m₂.
    Let η₁ : functor_identity _ ⟹ M₁ := pr1 (unit_of_mnd m₁).
    Let η₂ : functor_identity _ ⟹ M₂ := pr1 (unit_of_mnd m₂).
    Let μ₁ : M₁ ∙ M₁ ⟹ M₁ := pr1 (mult_of_mnd m₁).
    Let μ₂ : M₂ ∙ M₂ ⟹ M₂ := pr1 (mult_of_mnd m₂).
    Let F₁ : C₁ ⟶ C₂ := pr1 (mor_of_mnd_mor f₁).
    Let Fm₁ : F₁ ∙ M₂ ⟹ M₁ ∙ F₁ := pr1 (mnd_mor_endo f₁).
    Let F₂ : C₁ ⟶ C₂ := pr1 (mor_of_mnd_mor f₂).
    Let Fm₂ : F₂ ∙ M₂ ⟹ M₁ ∙ F₂ := pr1 (mnd_mor_endo f₂).
    Let τc : F₁ ⟹ F₂ := pr1 (cell_of_mnd_cell τ).

    Definition mnd_cell_endo_enriched
               (x : C₁)
      : Fm₁ x · τc (M₁ x) = #M₂ (τc x) · Fm₂ x.
    Proof.
      pose (maponpaths (λ z, pr11 z x) (mnd_cell_endo τ)) as p.
      exact p.
    Qed.
  End MonadCellProjections.
End EnrichmentMonads.


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 Aprime Pprime Cprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Aprime Pprime /\ (wd_ Aprime O /\ (wd_ A Aprime /\ (wd_ Aprime Cprime /\ (wd_ A C /\ (wd_ B C /\ (wd_ O Pprime /\ (wd_ E Aprime /\ (wd_ E Pprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O Eprime Aprime /\ col_ Aprime Pprime Cprime)))))))))))))))))) -> col_ O B A)).
Proof.
  time tac.
Qed.

End FOFProblem.