(** * ImpCEvalFun: Evaluation Function for Imp *)

(* $Date: 2013-07-01 18:48:47 -0400 (Mon, 01 Jul 2013) $ *)

(* #################################### *)
(** ** Evaluation Function *)

Require Import Imp.

(** Here's a first try at an evaluation function for commands,
    omitting [WHILE]. *)

Fixpoint ceval_step1 (st : state) (c : com) : state :=
  match c with
    | SKIP =>
        st
    | l ::= a1 =>
        update st l (aeval st a1)
    | c1 ;; c2 =>
        let st' := ceval_step1 st c1 in
        ceval_step1 st' c2
    | IFB b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_step1 st c1
          else ceval_step1 st c2
    | WHILE b1 DO c1 END =>
        st  (* bogus *)
  end.

(** In a traditional functional programming language like ML or
    Haskell we could write the WHILE case as follows:
<<
    | WHILE b1 DO c1 END =>
        if (beval st b1)
          then ceval_step1 st (c1;; WHILE b1 DO c1 END)
          else st
>>
    Coq doesn't accept such a definition ([Error: Cannot guess
    decreasing argument of fix]) because the function we want to
    define is not guaranteed to terminate. Indeed, the changed
    [ceval_step1] function applied to the [loop] program from [Imp.v] would
    never terminate. Since Coq is not just a functional programming
    language, but also a consistent logic, any potentially
    non-terminating function needs to be rejected. Here is an
    invalid(!) Coq program showing what would go wrong if Coq allowed
    non-terminating recursive functions:
<<
     Fixpoint loop_false (n : nat) : False := loop_false n.
>>
    That is, propositions like [False] would become
    provable (e.g. [loop_false 0] would be a proof of [False]), which
    would be a disaster for Coq's logical consistency.

    Thus, because it doesn't terminate on all inputs, the full version
    of [ceval_step1] cannot be written in Coq -- at least not
    without one additional trick... *)

(** Second try, using an extra numeric argument as a "step index" to
    ensure that evaluation always terminates. *)

Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
  match i with
  | O => empty_state
  | S i' =>
    match c with
      | SKIP =>
          st
      | l ::= a1 =>
          update st l (aeval st a1)
      | c1 ;; c2 =>
          let st' := ceval_step2 st c1 i' in
          ceval_step2 st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step2 st c1 i'
            else ceval_step2 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then let st' := ceval_step2 st c1 i' in
               ceval_step2 st' c i'
          else st
    end
  end.

(** _Note_: It is tempting to think that the index [i] here is
    counting the "number of steps of evaluation."  But if you look
    closely you'll see that this is not the case: for example, in the
    rule for sequencing, the same [i] is passed to both recursive
    calls.  Understanding the exact way that [i] is treated will be
    important in the proof of [ceval__ceval_step], which is given as
    an exercise below. *)

(** Third try, returning an [option state] instead of just a [state]
    so that we can distinguish between normal and abnormal
    termination. *)

Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (update st l (aeval st a1))
      | c1 ;; c2 =>
          match (ceval_step3 st c1 i') with
          | Some st' => ceval_step3 st' c2 i'
          | None => None
          end
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step3 st c1 i'
            else ceval_step3 st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then match (ceval_step3 st c1 i') with
               | Some st' => ceval_step3 st' c i'
               | None => None
               end
          else Some st
    end
  end.

(** We can improve the readability of this definition by introducing a
    bit of auxiliary notation to hide the "plumbing" involved in
    repeatedly matching against optional states. *)

Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (update st l (aeval st a1))
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None    => None
  | Some st => Some (st X, st Y, st Z)
  end.

(* Eval compute in
     (test_ceval empty_state
         (X ::= ANum 2;;
          IFB BLe (AId X) (ANum 1)
            THEN Y ::= ANum 3
            ELSE Z ::= ANum 4
          FI)).
   ====>
      Some (2, 0, 4)   *)

(** **** Exercise: 2 stars (pup_to_n) *)
(** Write an Imp program that sums the numbers from [1] to
   [X] (inclusive: [1 + 2 + ... + X]) in the variable [Y].  Make sure
   your solution satisfies the test that follows. *)

Definition pup_to_n : com :=
  (* FILL IN HERE *) admit.

(*
Example pup_to_n_1 :
  test_ceval (update empty_state X 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.
*)
(** [] *)

(** **** Exercise: 2 stars, optional (peven) *)
(** Write a [While] program that sets [Z] to [0] if [X] is even and
    sets [Z] to [1] otherwise.  Use [ceval_test] to test your
    program. *)

(* FILL IN HERE *)
(** [] *)

(* ################################################################ *)
(** ** Equivalence of Relational and Step-Indexed Evaluation *)

(** As with arithmetic and boolean expressions, we'd hope that
    the two alternative definitions of evaluation actually boil down
    to the same thing.  This section shows that this is the case.
    Make sure you understand the statements of the theorems and can
    follow the structure of the proofs. *)

Theorem ceval_step__ceval: forall c st st',
      (exists i, ceval_step st c i = Some st') ->
      c / st || st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i as [| i' ].

  Case "i = 0 -- contradictory".
    intros c st st' H. inversion H.

  Case "i = S i'".
    intros c st st' H.
    com_cases (destruct c) SCase;
           simpl in H; inversion H; subst; clear H.
      SCase "SKIP". apply E_Skip.
      SCase "::=". apply E_Ass. reflexivity.

      SCase ";;".
        destruct (ceval_step st c1 i') eqn:Heqr1.
        SSCase "Evaluation of r1 terminates normally".
          apply E_Seq with s.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
        SSCase "Otherwise -- contradiction".
          inversion H1.

      SCase "IFB".
        destruct (beval st b) eqn:Heqr.
        SSCase "r = true".
          apply E_IfTrue. rewrite Heqr. reflexivity.
          apply IHi'. assumption.
        SSCase "r = false".
          apply E_IfFalse. rewrite Heqr. reflexivity.
          apply IHi'. assumption.

      SCase "WHILE". destruct (beval st b) eqn :Heqr.
        SSCase "r = true".
         destruct (ceval_step st c i') eqn:Heqr1.
          SSSCase "r1 = Some s".
            apply E_WhileLoop with s. rewrite Heqr. reflexivity.
            apply IHi'. rewrite Heqr1. reflexivity.
            apply IHi'. simpl in H1. assumption.
          SSSCase "r1 = None".
            inversion H1.
        SSCase "r = false".
          inversion H1.
          apply E_WhileEnd.
          rewrite <- Heqr. subst. reflexivity.  Qed.

(** **** Exercise: 4 stars (ceval_step__ceval_inf) *)
(** Write an informal proof of [ceval_step__ceval], following the
    usual template.  (The template for case analysis on an inductively
    defined value should look the same as for induction, except that
    there is no induction hypothesis.)  Make your proof communicate
    the main ideas to a human reader; do not simply transcribe the
    steps of the formal proof.

(* FILL IN HERE *)
[]
*)

Theorem ceval_step_more: forall i1 i2 st st' c,
  i1 <= i2 ->
  ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
  Case "i1 = 0".
    simpl in Hceval. inversion Hceval.
  Case "i1 = S i1'".
    destruct i2 as [|i2']. inversion Hle.
    assert (Hle': i1' <= i2') by omega.
    com_cases (destruct c) SCase.
    SCase "SKIP".
      simpl in Hceval. inversion Hceval.
      reflexivity.
    SCase "::=".
      simpl in Hceval. inversion Hceval.
      reflexivity.
    SCase ";;".
      simpl in Hceval. simpl.
      destruct (ceval_step st c1 i1') eqn:Heqst1'o.
      SSCase "st1'o = Some".
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      SSCase "st1'o = None".
        inversion Hceval.

    SCase "IFB".
      simpl in Hceval. simpl.
      destruct (beval st b); apply (IHi1' i2') in Hceval; assumption.

    SCase "WHILE".
      simpl in Hceval. simpl.
      destruct (beval st b); try assumption.
      destruct (ceval_step st c i1') eqn: Heqst1'o.
      SSCase "st1'o = Some".
        apply (IHi1' i2') in Heqst1'o; try assumption.
        rewrite -> Heqst1'o. simpl. simpl in Hceval.
        apply (IHi1' i2') in Hceval; try assumption.
      SSCase "i1'o = None".
        simpl in Hceval. inversion Hceval.  Qed.

(** **** Exercise: 3 stars (ceval__ceval_step) *)
(** Finish the following proof.  You'll need [ceval_step_more] in a
    few places, as well as some basic facts about [<=] and [plus]. *)

Theorem ceval__ceval_step: forall c st st',
      c / st || st' ->
      exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  ceval_cases (induction Hce) Case.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem ceval_and_ceval_step_coincide: forall c st st',
      c / st || st'
  <-> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st'.
  split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

(* ####################################################### *)
(** ** Determinism of Evaluation (Simpler Proof) *)

(** Here's a slicker proof showing that the evaluation relation is
    deterministic, using the fact that the relational and step-indexed
    definition of evaluation are the same. *)

Theorem ceval_deterministic' : forall c st st1 st2,
     c / st || st1  ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  omega. omega.  Qed.


Set Implicit Arguments.

Section TotalMap.

  Variable K V : Type.
  Variable eqK : K -> K -> bool.

  Definition totalMap := K -> V.

  Definition emptyTMap (v : V) : totalMap := fun _ => v.

  Definition updateTMap (m : totalMap) (k : K) (v : V) :=
    fun k' => if eqK k k' then v else m k'.

End TotalMap.

Section PartialMap.

  Variable K V : Type.
  Variable eqK : K -> K -> bool.

  Definition partialMap := totalMap K (option V).

  Definition emptyPMap : partialMap := emptyTMap None.

  Definition updatePMap (m : partialMap) (k : K) (v : V) :=
    updateTMap eqK m k (Some v).

End PartialMap.

Section Env.

  Variable K V : Type.
  Variable eqK : K -> K -> bool.
  Notation "i '==' j" := (eqK i j) (at level 80, right associativity).

  Definition listMap := list (K * V).

  Fixpoint lookup (Sigma : listMap) (k : K) : option V :=
    match Sigma with
    | nil          => None
    | cons (k',v) Delta => if (k' == k) then Some v
                      else lookup Delta k
    end.

  Definition add (Sigma : listMap) (k : K) (v' : V) : listMap :=
    cons (k,v') Sigma.

  Fixpoint update (Sigma : listMap) (k : K) (v : V) : listMap :=
    match Sigma with
    | nil            => cons (k,v) nil
    | cons (k',v') Delta => if (k' == k) then cons (k',v) Delta
                    else cons (k',v') (update Delta k v)
    end.

  Definition union (Sigma Delta : listMap) : listMap := app Sigma Delta.

End Env.

Section Properties.

  Lemma lookup_deterministic :
    forall (A B : Type) (eqA : A -> A -> bool) (Sigma : listMap A B) (k : A) (v1 v2 : option B),
      lookup eqA Sigma k = v1 ->
      lookup eqA Sigma k = v2 ->
      v1 = v2.
  Proof.
    intros.
    rewrite H in H0.
    apply H0.
  Qed.

  Lemma add_lookupL1 :
    forall (A B : Type) (eqA : A -> A -> bool) (Sigma : listMap A B) (k : A) (v : B),
      (forall x : A, eqA x x = true) ->
      lookup eqA (add Sigma k v) k = Some v.
  Proof.
    intros.
    unfold add.
    simpl lookup.
    rewrite (H k).
    reflexivity.
  Qed.

  Lemma add_lookupL2 :
    forall (A B : Type) (eqA : A -> A -> bool) (Sigma : listMap A B) (k1 k2 : A) (v  : B),
      eqA k2 k1 = false ->
      lookup eqA (add Sigma k2 v) k1 = lookup eqA Sigma k1.
  Proof.
    intros.
    unfold add.
    simpl lookup.
    rewrite H.
    reflexivity.
  Qed.

End Properties.


(** * Finite Modular Maps: Ordered Lists *)

(** Author: Pierre Letouzey (Université de Paris - INRIA),
    adapted from earlier works in Coq Standard Library, see README.md.
    License: LGPL-2.1-only, see file LICENSE. *)

(** This file proposes an implementation of the interface
    [MMaps.Interface.S] using lists of pairs ordered (increasing)
    with respect to left projection. Almost all operations
    have linear complexity. *)

From Coq Require Import OrdersFacts OrdersLists.
From MMaps Require Comparisons Interface Raw.
Import Comparisons Interface.

Set Implicit Arguments.
Unset Strict Implicit.

Module MakeRaw (X:OrderedType) <: Raw.S X.

Module Import MX := OrderedTypeFacts X.
Module Import PX := KeyOrderedType X.

Definition key := X.t.
Definition t (elt:Type) := list (X.t * elt).

Definition eq_key {elt} := @PX.eqk elt.
Definition lt_key {elt} := @PX.ltk elt.
Definition eq_key_elt {elt} := @PX.eqke elt.
Definition IsOk {elt} := sort (@ltk elt).
Class Ok {elt}(m:t elt) : Prop := ok : sort ltk m.

Local Hint Unfold Ok IsOk : map.
Ltac chok :=
 match goal with
 | H : context [sort (@ltk ?elt)] |- _ =>
   change (sort (@ltk elt)) with (@Ok elt) in H; chok
 | |- context [sort (@ltk ?elt)] =>
   change (sort (@ltk elt)) with (@Ok elt); chok
 | _ => idtac
 end.
Ltac autok := chok; auto with typeclass_instances map.
Ltac eautok := chok; eauto with typeclass_instances map.

Local Notation Sort := (sort ltk).
Local Notation Inf := (lelistA (ltk)).

Section Elt.
Variable elt : Type.

Ltac SortLt :=
 match goal with
   | H1 : Sort ?m, H2:Inf (?k',?e') ?m, H3:In ?k ?m |- _  =>
     assert (X.lt k' k);
     [let e := fresh "e" in destruct H3 as (e,H3);
      change (ltk (k',e') (k,e));
      apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ]
   | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:MapsTo ?k ?e ?m |- _  =>
     assert (X.lt k' k);
     [change (ltk (k',e') (k,e));
      apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ]
   | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:InA eqke (?k,?e) ?m |- _  =>
     assert (X.lt k' k);
     [change (ltk (k',e') (k,e));
      apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ]
 end.

(** [isok] : deciding [Ok]. Not used here, see [Mkt_bool] in [Raw.v] *)

Fixpoint isok (m:t elt) :=
  match m with
  | nil => true
  | _ :: nil => true
  | (x,_) :: (((y,_) :: _) as m') =>
    match X.compare x y with
    | Lt => isok m'
    | _ => false
    end
  end.

Lemma isok_spec (m:t elt) : isok m = true <-> Ok m.
Proof.
 induction m as [|(x,e) m IH]; simpl.
 - intuition (auto with map).
 - destruct m as [|(y,e') m].
   + intuition (auto with map).
   + case X.compare_spec; intros C.
     * split. easy. inversion 1; subst. inversion H3; subst.
       compute in H1. order.
     * rewrite IH. split. intros; constructor; autok.
       inversion 1; auto.
     * split. easy. inversion 1; subst. inversion H3; subst.
       compute in H1. order.
Qed.

Lemma isok_Ok (m:t elt) : isok m = true -> Ok m.
Proof. apply isok_spec. Qed.

(** ** find *)

Fixpoint find (k:key) (m: t elt) : option elt :=
 match m with
  | nil => None
  | (k',x)::m' =>
     match X.compare k k' with
      | Lt => None
      | Eq => Some x
      | Gt => find k m'
     end
 end.

Lemma find_spec m x e {Hm:Ok m}:
 find x m = Some e <-> MapsTo x e m.
Proof.
 induction m as [|(k,e') m IH]; simpl.
 - split. discriminate. inversion 1.
 - inversion_clear Hm.
   unfold MapsTo in *. rewrite InA_cons, eqke_def.
   case X.compare_spec; intros.
   + split. injection 1 as ->; auto.
     intros [(_,<-)|IN]; trivial. SortLt. MX.order.
   + split. discriminate.
     intros [(E,<-)|IN]; trivial; try SortLt; MX.order.
   + rewrite IH; trivial. split; auto.
     intros [(E,<-)|IN]; trivial. MX.order.
Qed.

(** ** mem *)

Fixpoint mem (k : key) (m : t elt) : bool :=
 match m with
  | nil => false
  | (k',_) :: l =>
     match X.compare k k' with
      | Lt => false
      | Eq => true
      | Gt => mem k l
     end
 end.

Lemma mem_spec m x {Hm:Ok m} : mem x m = true <-> In x m.
Proof.
 induction m as [|(k,e') m IH]; simpl.
 - split. discriminate. inversion 1. inversion_clear H0.
 - inversion_clear Hm.
   rewrite In_cons; simpl.
   case X.compare_spec; intros.
   + intuition.
   + split. discriminate. intros [E|(e,IN)]. MX.order.
     SortLt. MX.order.
   + rewrite IH; trivial. split; auto. intros [E|IN]; trivial.
     MX.order.
Qed.

(** ** empty *)

Definition empty : t elt := nil.

Lemma empty_spec x : find x empty = None.
Proof.
 reflexivity.
Qed.

#[export] Instance empty_ok : Ok empty.
Proof.
 unfold empty; autok.
Qed.

(** ** is_empty *)

Definition is_empty (l : t elt) : bool := if l then true else false.

Lemma is_empty_spec m :
 is_empty m = true <-> forall x, find x m = None.
Proof.
 destruct m as [|(k,e) m]; simpl; split; trivial; try discriminate.
 intros H. specialize (H k). now rewrite compare_refl in H.
Qed.

(** ** add *)

Fixpoint add (k : key) (x : elt) (s : t elt) : t elt :=
 match s with
  | nil => (k,x) :: nil
  | (k',y) :: l =>
     match X.compare k k' with
      | Lt => (k,x)::s
      | Eq => (k,x)::l
      | Gt => (k',y) :: add k x l
     end
 end.

Lemma add_spec1' m x e : find x (add x e m) = Some e.
Proof.
 induction m as [|(k,e') m IH]; simpl.
 - now rewrite compare_refl.
 - case X.compare_spec; simpl; rewrite ?compare_refl; trivial.
   rewrite <- compare_gt_iff. now intros ->.
Qed.

Lemma add_spec2' m x y e : ~X.eq x y -> find y (add x e m) = find y m.
Proof.
 induction m as [|(k,e') m IH]; simpl.
 - case X.compare_spec; trivial; MX.order.
 - case X.compare_spec; simpl; intros; trivial.
   + rewrite <-H. case X.compare_spec; trivial; MX.order.
   + do 2 (case X.compare_spec; trivial; try MX.order).
   + now rewrite IH.
Qed.

Lemma add_spec1 m x e `{!Ok m} : find x (add x e m) = Some e.
Proof. apply add_spec1'. Qed.

Lemma add_spec2 m x y e `{!Ok m} :
 ~X.eq x y -> find y (add x e m) = find y m.
Proof. apply add_spec2'. Qed.

Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt),
  Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m).
Proof.
 induction m.
 simpl; intuition.
 intros.
 destruct a as (x'',e'').
 inversion_clear H.
 compute in H0,H1.
 simpl; case X.compare; intuition.
Qed.
Local Hint Resolve add_Inf : map.

#[export] Instance add_ok m x e {Hm:Ok m} : Ok (add x e m).
Proof.
 induction m as [|(y,v) m IH].
 - simpl; intuition (auto with map).
 - simpl; case (X.compare_spec x y); intuition auto; inversion_clear Hm;
     constructor; autok.
   apply Inf_eq with (y,v); auto.
Qed.

(** ** remove *)

Fixpoint remove (k : key) (s : t elt) : t elt :=
 match s with
  | nil => nil
  | (k',x) :: l =>
     match X.compare k k' with
      | Lt => s
      | Eq => l
      | Gt => (k',x) :: remove k l
     end
 end.

Lemma remove_spec1 m x {Hm:Ok m} : find x (remove x m) = None.
Proof.
 induction m as [|(k,e') m IH]; simpl; trivial.
 inversion_clear Hm; chok.
 case X.compare_spec; simpl.
 - intros E. rewrite <- E in H0.
   apply Sort_Inf_NotIn in H0; trivial.
   assert (F := @find_spec m x).
   destruct (find x m); trivial.
   elim H0; exists e. rewrite <- (F e); auto.
 - rewrite <- compare_lt_iff. now intros ->.
 - rewrite <- compare_gt_iff. intros ->; auto.
Qed.

Lemma remove_spec2 m x y {Hm:Ok m} :
  ~X.eq x y -> find y (remove x m) = find y m.
Proof.
 induction m as [|(k,e') m IH]; simpl; trivial.
 inversion_clear Hm.
 case X.compare_spec; simpl; intros E E'; try rewrite IH; auto.
 case X.compare_spec; simpl; trivial; try MX.order.
 intros. rewrite <- E in H0,H1. clear E E'.
 destruct (find y m) eqn:F; trivial.
 apply find_spec in F; trivial.
 SortLt. MX.order.
Qed.

Lemma remove_Inf (m:t elt){Hm : Ok m}(x x':key)(e':elt) :
  Inf (x',e') m -> Inf (x',e') (remove x m).
Proof.
 induction m.
 simpl; intuition.
 intros.
 destruct a as (x'',e'').
 inversion_clear H.
 compute in H0.
 simpl; case X.compare; intuition.
 inversion_clear Hm.
 apply Inf_lt with (x'',e''); auto.
Qed.
Local Hint Resolve remove_Inf : map.

#[export] Instance remove_ok m x {Hm:Ok m} : Ok (remove x m).
Proof.
 induction m.
 simpl; intuition.
 intros.
 destruct a as (x',e').
 simpl; case X.compare_spec; intuition; inversion_clear Hm; auto.
 constructor; autok.
Qed.

(** ** bindings *)

Definition bindings (m: t elt) := m.

Lemma bindings_spec1 m x e :
  InA eqke (x,e) (bindings m) <-> MapsTo x e m.
Proof.
 reflexivity.
Qed.

Lemma bindings_spec2 m {Hm:Ok m} : sort ltk (bindings m).
Proof.
 auto.
Qed.

Lemma bindings_spec2w m {Hm:Ok m} : NoDupA eqk (bindings m).
Proof.
 now apply Sort_NoDupA.
Qed.

(** ** singleton *)

Definition singleton k (e:elt) : t elt := (k,e)::nil.

Lemma singleton_spec x e : bindings (singleton x e) = (x,e)::nil.
Proof. reflexivity. Qed.

#[export] Instance singleton_ok x e : Ok (singleton x e).
Proof.
 constructor; auto.
Qed.

(** ** fold *)

Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) :  A :=
  match m with
   | nil => acc
   | (k,e)::m' => fold f m' (f k e acc)
  end.

Lemma fold_spec m : forall (A:Type)(i:A)(f:key->elt->A->A),
  fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
Proof.
 induction m as [|(k,e) m IH]; simpl; auto.
Qed.

(** ** equal *)

Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) : bool :=
  match m, m' with
   | nil, nil => true
   | (x,e)::l, (x',e')::l' =>
      match X.compare x x' with
       | Eq => cmp e e' && equal cmp l l'
       | _  => false
      end
   | _, _ => false
  end.

Definition Equal m m' := forall y, find y m = find y m'.
Definition Eqdom m m' := forall y, @In elt y m <-> @In elt y m'.
Definition Equiv (R:elt->elt->Prop) m m' :=
  Eqdom m m' /\
  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> R e e').
Definition Equivb (cmp:elt->elt->bool) := Equiv (Cmp cmp).

Lemma equal_1 : forall m m' {Hm:Ok m}{Hm': Ok m'} cmp,
  Equivb cmp m m' -> equal cmp m m' = true.
Proof.
 induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl.
 - trivial.
 - intros _ _ cmp (H,_). exfalso. specialize (H k').
   rewrite In_nil, In_cons in H. rewrite H. now left.
 - intros _ _ cmp (H,_). exfalso. specialize (H k).
   rewrite In_nil, In_cons in H. rewrite <- H. now left.
 - intros Hm Hm' cmp E.
   inversion_clear Hm; inversion_clear Hm'.
   case X.compare_spec; intros E'.
   + apply andb_true_intro; split.
     * eapply E; eauto. apply InA_cons; now left.
     * apply IH; clear IH; trivial.
       destruct E as (E1,E2). split.
       { intros x. clear E2.
         split; intros; SortLt.
         specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1.
         destruct E1 as ([E1|E1],_); eauto. MX.order.
         specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1.
         destruct E1 as (_,[E1|E1]); eauto. MX.order. }
       { intros x xe xe' Hx HX'. eapply E2; eauto. }
   + assert (IN : In k ((k',e')::m')).
     { apply E. apply In_cons; now left. }
     apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order.
     SortLt. MX.order.
   + assert (IN : In k' ((k,e)::m)).
     { apply E. apply In_cons; now left. }
     apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order.
     SortLt. MX.order.
Qed.

Lemma equal_2 m m' {Hm:Ok m}{Hm':Ok m'} cmp :
  equal cmp m m' = true -> Equivb cmp m m'.
Proof.
 revert m' Hm'.
 induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl;
  try discriminate.
 - split. red. reflexivity. inversion 1.
 - intros Hm'. case X.compare_spec; try discriminate.
   rewrite andb_true_iff. intros E (C,EQ).
   inversion_clear Hm; inversion_clear Hm'.
   apply IH in EQ; trivial.
   destruct EQ as (E1,E2).
   split.
   + intros x. rewrite 2 In_cons; simpl. rewrite <- (E1 x).
     intuition; now left; MX.order.
   + intros x ex ex'. unfold MapsTo in *. rewrite 2 InA_cons, 2 eqke_def.
     intuition; subst.
     * trivial.
     * SortLt. MX.order.
     * SortLt. MX.order.
     * eapply E2; eauto.
Qed.

Lemma equal_spec cmp m m' {Hm:Ok m}{Hm':Ok m'} :
  equal cmp m m' = true <-> Equivb cmp m m'.
Proof.
 split. now apply equal_2. now apply equal_1.
Qed.

(** This lemma isn't part of the spec of [Equivb], but is used in [MMaps.AVL] *)

Lemma equal_cons : forall cmp l1 l2 x y, Ok (x::l1) -> Ok (y::l2) ->
  eqk x y -> cmp (snd x) (snd y) = true ->
  (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)).
Proof.
 intros.
 inversion H; subst.
 inversion H0; subst.
 destruct x; destruct y; compute in H1, H2.
 split; intros.
 apply equal_2; auto.
 simpl.
 case X.compare_spec; intros; try MX.order.
 rewrite H2; simpl.
 apply equal_1; auto.
 apply equal_2; auto.
 generalize (equal_1 H3).
 simpl.
 case X.compare_spec; try discriminate.
 rewrite andb_true_iff. intuition.
Qed.

Variable elt':Type.

(** ** map and mapi *)

Definition map (f:elt -> elt') (m:t elt) : t elt' :=
  List.map (fun '(k,e) => (k,f e)) m.

Definition mapi (f: key -> elt -> elt') (m:t elt) : t elt' :=
  List.map (fun '(k,e) => (k,f k e)) m.

End Elt.
Arguments find {elt} k m.
Section Elt2.
Variable elt elt' : Type.

(** Specification of [map] *)

Lemma map_spec (f:elt->elt')(m:t elt) :
  bindings (map f m) = List.map (fun '(k,e) => (k,f e)) (bindings m).
Proof.
 reflexivity.
Qed.

Lemma map_Inf (f:elt->elt') m x e e' :
  Inf (x,e) m -> Inf (x,e') (map f m).
Proof.
 induction m as [|(x0,e0) m IH]; simpl; auto.
 inversion_clear 1; auto.
Qed.
Local Hint Resolve map_Inf : map.

#[export] Instance map_ok (f:elt->elt')(m: t elt){Hm : Ok m} : Ok (map f m).
Proof.
 induction m as [|(x,e) m IH]; simpl; autok.
 inversion_clear Hm. constructor; eautok.
Qed.

(** Specification of [mapi] *)

Lemma mapi_spec (f:key->elt->elt')(m:t elt) :
  bindings (mapi f m) = List.map (fun '(k,e) => (k,f k e)) (bindings m).
Proof.
 reflexivity.
Qed.

Lemma mapi_Inf (f:key->elt->elt') m x e :
  Inf (x,e) m -> Inf (x,f x e) (mapi f m).
Proof.
 induction m as [|(x0,e0) m IH]; simpl; auto.
 inversion_clear 1; auto.
Qed.
Local Hint Resolve mapi_Inf : map.

#[export] Instance mapi_ok (f:key->elt->elt') m {Hm : Ok m} :
  Ok (mapi f m).
Proof.
 induction m as [|(x,e) m IH]; simpl; autok.
 inversion_clear Hm; constructor; autok.
Qed.

End Elt2.
Section Elt3.

(** ** merge *)

Variable elt elt' elt'' : Type.
Variable f : key -> option elt -> option elt' -> option elt''.

Definition option_cons {A}(k:key)(o:option A)(l:list (key*A)) :=
  match o with
   | Some e => (k,e)::l
   | None => l
  end.

Fixpoint merge_l (m : t elt) : t elt'' :=
  match m with
   | nil => nil
   | (k,e)::l => option_cons k (f k (Some e) None) (merge_l l)
  end.

Fixpoint merge_r (m' : t elt') : t elt'' :=
  match m' with
   | nil => nil
   | (k,e')::l' => option_cons k (f k None (Some e')) (merge_r l')
  end.

Fixpoint merge (m : t elt) : t elt' -> t elt'' :=
  match m with
   | nil => merge_r
   | (k,e) :: l =>
      fix merge_aux (m' : t elt') : t elt'' :=
        match m' with
         | nil => merge_l m
         | (k',e') :: l' =>
            match X.compare k k' with
             | Lt => option_cons k (f k (Some e) None) (merge l m')
             | Eq => option_cons k (f k (Some e) (Some e')) (merge l l')
             | Gt => option_cons k' (f k' None (Some e')) (merge_aux l')
            end
        end
  end.

Notation oee' := (option elt * option elt')%type.

Fixpoint combine (m : t elt) : t elt' -> t oee' :=
  match m with
   | nil => map (fun e' => (None,Some e'))
   | (k,e) :: l =>
      fix combine_aux (m':t elt') : list (key * oee') :=
        match m' with
         | nil => map (fun e => (Some e,None)) m
         | (k',e') :: l' =>
            match X.compare k k' with
             | Lt => (k,(Some e, None))::combine l m'
             | Eq => (k,(Some e, Some e'))::combine l l'
             | Gt => (k',(None,Some e'))::combine_aux l'
            end
        end
  end.

Definition fold_right_pair {A B C}(f: A->B->C->C)(l:list (A*B))(i:C) :=
  List.fold_right (fun p => f (fst p) (snd p)) i l.

Definition merge' m m' :=
  let m0 : t oee' := combine m m' in
  let m1 : t (option elt'') := mapi (fun k p => f k (fst p) (snd p)) m0 in
  fold_right_pair (option_cons (A:=elt'')) m1 nil.

Lemma merge_equiv : forall m m', merge' m m' = merge m m'.
Proof.
 unfold merge'.
 induction m as [|(k,e) m IHm]; intros.
 - (* merge_r *)
   simpl.
   induction m' as [|(k',e') m' IHm']; simpl; rewrite ?IHm'; auto.
 - induction m' as [|(k',e') m' IHm']; simpl.
   + f_equal.
     (* merge_l *)
     clear k e IHm.
     induction m as [|(k,e) m IHm]; simpl; rewrite ?IHm; auto.
   + elim X.compare_spec; intros; simpl; f_equal.
     * apply IHm.
     * apply IHm.
     * apply IHm'.
Qed.

Lemma combine_Inf :
  forall m m' (x:key)(e:elt)(e':elt')(e'':oee'),
  Inf (x,e) m ->
  Inf (x,e') m' ->
  Inf (x,e'') (combine m m').
Proof.
 induction m.
 - intros. simpl. eapply map_Inf; eauto.
 - induction m'; intros.
   + destruct a.
     replace (combine ((t0, e0) :: m) nil) with
      (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto.
     eapply map_Inf; eauto.
   + simpl.
     destruct a as (k,e0); destruct a0 as (k',e0').
     elim X.compare_spec.
     * inversion_clear H; auto.
     * inversion_clear H; auto.
     * inversion_clear H0; auto.
Qed.
Local Hint Resolve combine_Inf : map.

#[export] Instance combine_ok m m' {Hm : Ok m}{Hm' : Ok m'} :
 Ok (combine m m').
Proof.
 revert m' Hm'.
 induction m.
 - intros; clear Hm. simpl. apply map_ok; auto.
 - induction m'; intros.
   + clear Hm'.
     destruct a.
     replace (combine ((t0, e) :: m) nil) with
      (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto.
     apply map_ok; auto.
   + simpl.
     destruct a as (k,e); destruct a0 as (k',e').
     inversion_clear Hm; inversion_clear Hm'.
     case X.compare_spec; [intros Heq| intros Hlt| intros Hlt];
      constructor; autok.
     * assert (Inf (k, e') m') by (apply Inf_eq with (k',e'); auto).
       exact (combine_Inf _ H0 H3).
     * assert (Inf (k, e') ((k',e')::m')) by auto.
       exact (combine_Inf _ H0 H3).
     * assert (Inf (k', e) ((k,e)::m)) by auto.
       exact (combine_Inf _  H3 H2).
Qed.

#[export] Instance merge_ok m m' {Hm : Ok m}{Hm' : Ok m'} :
  Ok (merge m m').
Proof.
 intros.
 rewrite <- merge_equiv.
 unfold merge'.
 assert (Hmm':=@combine_ok m m' _ _).
 set (l0:=combine m m') in *; clearbody l0.
 set (f':= fun k p => f k (fst p) (snd p)).
 assert (H1:=@mapi_ok _ _ f' l0 _).
 set (l1:=mapi f' l0) in *; clearbody l1.
 clear f' f Hmm' l0 Hm Hm' m m'.
 (* Ok fold_right_pair *)
 induction l1.
 - simpl; autok.
 - inversion_clear H1. chok.
   destruct a; destruct o; auto.
   simpl.
   constructor; autok.
   clear IHl1.
   (* Inf fold_right_pair *)
   induction l1.
   + simpl; auto.
   + destruct a; destruct o; simpl; autok.
     * inversion_clear H0; auto.
     * inversion_clear H0. inversion_clear H.
       compute in H1.
       apply IHl1; auto.
       apply Inf_lt with (t1, None); auto.
Qed.

Definition at_least_one (o:option elt)(o':option elt') :=
  match o, o' with
   | None, None => None
   | _, _  => Some (o,o')
  end.

Lemma combine_spec m m' {Hm : Ok m}{Hm' : Ok m'} (x:key) :
  find x (combine m m') = at_least_one (find x m) (find x m').
Proof.
 revert m' Hm'.
 induction m.
 intros.
 simpl.
 induction m'.
 intros; simpl; auto.
 simpl; destruct a.
 simpl; destruct (X.compare x t0); simpl; auto.
 inversion_clear Hm'; auto.
 induction m'.
 (* m' = nil *)
 intros; destruct a; simpl.
 destruct (X.compare_spec x t0) as [ |Hlt|Hlt]; simpl; auto.
 inversion_clear Hm; clear H0 Hlt Hm' IHm t0.
 induction m; simpl; auto.
 inversion_clear H.
 destruct a.
 simpl; destruct (X.compare x t0); simpl; auto.
 (* m' <> nil *)
 intros.
 destruct a as (k,e); destruct a0 as (k',e'); simpl.
 inversion Hm; inversion Hm'; subst.
 destruct (X.compare_spec k k'); simpl;
  destruct (X.compare_spec x k);
   MX.order || destruct (X.compare_spec x k');
               simpl; try MX.order; auto.
 - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order.
 - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order.
 - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order.
 - change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')).
   rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order.
 - change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')).
   rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order.
 - change (find x (combine ((k, e) :: m) m') =
         at_least_one (find x m) (find x m')).
   rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order.
Qed.

Definition at_least_one_then_f k (o:option elt)(o':option elt') :=
  match o, o' with
   | None, None => None
   | _, _  => f k o o'
  end.

Lemma merge_spec0 m m' {Hm : Ok m}{Hm' : Ok m'} (x:key) :
  exists y, X.eq y x /\
  find x (merge m m') = at_least_one_then_f y (find x m) (find x m').
Proof.
 intros.
 rewrite <- merge_equiv.
 unfold merge'.
 assert (H:=combine_spec x).
 assert (H2:=@combine_ok m m' _ _).
 set (f':= fun k p => f k (fst p) (snd p)).
 set (m0 := combine m m') in *; clearbody m0.
 set (o:=find x m) in *; clearbody o.
 set (o':=find x m') in *; clearbody o'.
 clear Hm Hm' m m'. revert H.
 match goal with |- ?G =>
   assert (G/\(find x m0 = None ->
               find x (fold_right_pair option_cons (mapi f' m0) nil) = None));
    [|intuition] end.
 induction m0; simpl in *; intuition.
 - exists x; split; [easy|].
   destruct o; destruct o'; simpl in *; try discriminate; auto.
 - destruct a as (k,(oo,oo')); simpl in *.
   inversion_clear H2.
   destruct (X.compare_spec x k) as [Heq|Hlt|Hlt]; simpl in *.
   + (* x = k *)
     exists k; split; [easy|].
     assert (at_least_one_then_f k o o' = f k oo oo').
     { destruct o; destruct o'; simpl in *; inversion_clear H; auto. }
     rewrite H2.
     unfold f'; simpl.
     destruct (f k oo oo'); simpl.
     * elim X.compare_spec; trivial; try MX.order.
     * destruct (IHm0 H0) as (_,H4); apply H4; auto.
       case_eq (find x m0); intros; auto.
       assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))).
       now compute.
       symmetry in H5.
       destruct (Sort_Inf_NotIn H0 (Inf_eq H5 H1)).
       exists p; apply find_spec; auto.
   + (* x < k *)
     destruct (f' k (oo,oo')); simpl.
     * elim X.compare_spec; trivial; try MX.order.
       destruct o; destruct o'; simpl in *; try discriminate; auto.
       now exists x.
     * apply IHm0; trivial.
       rewrite <- H.
       case_eq (find x m0); intros; auto.
       assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
       red; auto.
       destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)).
       exists p; apply find_spec; auto.
   + (* k < x *)
     unfold f'; simpl.
     destruct (f k oo oo'); simpl.
     * elim X.compare_spec; trivial; try MX.order.
       intros. apply IHm0; auto.
     * apply IHm0; auto.

 - (* None -> None *)
   destruct a as (k,(oo,oo')).
   simpl.
   inversion_clear H2.
   destruct (X.compare_spec x k) as [Hlt|Heq|Hlt]; try discriminate.
   + (* x < k *)
     unfold f'; simpl.
     destruct (f k oo oo'); simpl.
     elim X.compare_spec; trivial; try MX.order. intros.
     apply IHm0; auto.
     case_eq (find x m0); intros; auto.
     assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
     now compute.
     destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)).
     exists p; apply find_spec; auto.
   + (* k < x *)
     unfold f'; simpl.
     destruct (f k oo oo'); simpl.
     elim X.compare_spec; trivial; try MX.order. intros.
     apply IHm0; auto.
     apply IHm0; auto.
Qed.

(** Specification of [merge] *)

Lemma merge_spec1 m m' x {Hm : Ok m}{Hm' : Ok m'} :
  In x m \/ In x m' ->
  exists y, X.eq y x /\
    find x (merge m m') = f y (find x m) (find x m').
Proof.
 intros.
 destruct (merge_spec0 x) as (y,(Hy,H')).
 exists y; split; [easy|]. rewrite H'.
 destruct H as [(e,H)|(e,H)];
  apply find_spec in H; trivial; rewrite H; simpl; auto.
 now destruct (find x m).
Qed.

Lemma merge_spec2 m m' x {Hm : Ok m}{Hm' : Ok m'} :
  In x (merge m m') -> In x m \/ In x m'.
Proof.
 intros.
 destruct H as (e,H).
 apply find_spec in H; auto using merge_ok.
 destruct (merge_spec0 x) as (y,(Hy,H')).
 rewrite H in H'.
 destruct (find x m) eqn:F.
 - apply find_spec in F; eauto.
 - destruct (find x m') eqn:F'.
   + apply find_spec in F'; eauto.
   + simpl in H'. discriminate.
Qed.

End Elt3.

Definition cardinal {elt} (m:t elt) := length m.
Lemma cardinal_spec {elt} (m:t elt) : cardinal m = length (bindings m).
Proof. reflexivity. Qed.

Definition MapsTo {elt} := @PX.MapsTo elt.
Definition In {elt} := @PX.In elt.

#[export] Instance MapsTo_compat {elt} :
  Proper (X.eq==>Logic.eq==>Logic.eq==>iff) (@MapsTo elt).
Proof.
 intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx.
Qed.

Definition compare {elt} cmp (m m':t elt) :=
  list_compare (pair_compare X.compare cmp) m m'.

Definition compare_spec {elt} cmp (m m':t elt) {Hm : Ok m}{Hm' : Ok m'}:
 compare cmp m m' =
 list_compare (pair_compare X.compare cmp) m m'.
Proof. reflexivity. Qed.

Definition filter {elt} (f:key->elt->bool) :=
  List.filter (fun '(k,e) => f k e).

Definition partition {elt} (f:key->elt->bool) :=
  List.partition (fun '(k,e) => f k e).

Definition for_all {elt} (f:key->elt->bool) :=
  List.forallb (fun '(k,e) => f k e).

Definition exists_ {elt} (f:key->elt->bool) :=
  List.existsb (fun '(k,e) => f k e).

Lemma filter_spec {elt} (f:key->elt->bool) m `{!Ok m} :
 bindings (filter f m) = List.filter (fun '(k,e) => f k e) (bindings m).
Proof. reflexivity. Qed.

Lemma partition_spec {elt} (f:key->elt->bool) m `{!Ok m} :
 prodmap (@bindings _) (partition f m) =
  List.partition (fun '(k,e) => f k e) (bindings m).
Proof. unfold bindings, partition. now destruct List.partition. Qed.

Lemma for_all_spec {elt}(f:key->elt->bool) m :
 for_all f m = List.forallb (fun '(k,e) => f k e) (bindings m).
Proof. reflexivity. Qed.

Lemma exists_spec {elt}(f:key->elt->bool) m :
 exists_ f m = List.existsb (fun '(k,e) => f k e) (bindings m).
Proof. reflexivity. Qed.

#[export] Instance filter_ok {elt} f (m:t elt) : Ok m -> Ok (filter f m).
Proof.
 eapply filter_sort with (eqA:=eqke); eauto with *.
Qed.

Lemma partition_fst {elt} f (m:t elt) : fst (partition f m) = filter f m.
Proof.
 induction m; simpl; auto.
 rewrite <- IHm. now destruct (partition f m), a, f.
Qed.

Lemma partition_snd {elt} f (m:t elt) :
  snd (partition f m) = filter (fun k e => negb (f k e)) m.
Proof.
 induction m; simpl; auto.
 rewrite <- IHm. now destruct (partition f m), a, f.
Qed.

#[export] Instance partition_ok1 {elt} f (m:t elt) : Ok m -> Ok (fst (partition f m)).
Proof.
 rewrite partition_fst; eauto with *.
Qed.

#[export] Instance partition_ok2 {elt} f (m:t elt) : Ok m -> Ok (snd (partition f m)).
Proof.
 rewrite partition_snd; eauto with *.
Qed.

End MakeRaw.

Module Make (X: OrderedType) <: S X.
 Module Raw := MakeRaw X.
 Include Raw.Pack X Raw.
End Make.


(** ** l-towers of (h-)sets.

by Vladimir Voevodsky. File created on January 30, 2015. *)

Require Import UniMath.Foundations.All.
Require Export TypeTheory.Csystems.ltowers_over.

Definition hSet_ltower := ∑ T : ltower, isaset T.

Definition hSet_ltower_constr ( T : ltower ) ( is : isaset T ):
  hSet_ltower := T ,, is.

Definition hSet_ltower_pr1: hSet_ltower -> ltower := pr1.
Coercion hSet_ltower_pr1: hSet_ltower >-> ltower.

Definition isasetB ( T : hSet_ltower ): isaset T := pr2 T.

Lemma isaprop_isover { T : hSet_ltower } ( X A : T ): isaprop ( isover X A ).
Proof.
  use isasetB.
Defined.

Lemma isaprop_isabove { T : hSet_ltower } ( X A : T ): isaprop ( isabove X A ).
Proof.
  apply isapropdirprod.
  - exact ( pr2 ( _ > _ ) ).
  - use isaprop_isover.
Defined.

Definition hSet_pltower := ∑ T : hSet_ltower, ispointed_type T.

Definition hSet_pltower_constr ( T : hSet_ltower ) ( is : ispointed_type T ):
  hSet_pltower := T ,, is.

Definition hSet_pltowers_to_pltowers: hSet_pltower -> pltower :=
  fun T => pltower_constr ( pr2 T ).
Coercion hSet_pltowers_to_pltowers : hSet_pltower >-> pltower.

Definition hSet_pltowers_pr1: hSet_pltower -> hSet_ltower := pr1.
Coercion hSet_pltowers_pr1: hSet_pltower >-> hSet_ltower.

Lemma isinvovmonot_pocto { T : hSet_ltower } { A : T } { X Y : ltower_over A }
      ( isov : isover ( pocto X ) ( pocto Y ) ): isover X Y.
Proof.
  use ( invmaponpathsincl pocto ).
  - apply isinclpr1.
    intro x.
    apply isaprop_isover.
  - rewrite <- isllmonot_pocto.
    rewrite ltower_over_ftn.
    + exact isov.
    + change ( ll X ) with ( ll ( pr1 X ) - ll A ).
      apply natgehandminusl.
      exact ( isover_geh ( isov_isov Y ) ).
Defined.

Lemma isaset_ltower_over { T : hSet_ltower } ( X : T ): isaset ( ltower_over X ).
Proof.
  apply ( isofhleveltotal2 2 ).
  - exact ( pr2 T ).
  - intro x.
    apply isasetaprop.
    apply isaprop_isover.
Defined.

Definition hSet_ltower_over { T : hSet_ltower } ( X : T ): hSet_ltower :=
  tpair ( fun T : ltower => isaset T ) ( ltower_over X ) ( isaset_ltower_over X ).

Definition hSet_pltower_over { T : hSet_ltower } ( X : T ): hSet_pltower :=
  hSet_ltower_over X  ,, pr2 ( pltower_over X ).

(** **** Completing construction of the function to_ltower_over *)

Lemma isovmonot_to_ltower_over { T : hSet_pltower } : isovmonot (to_ltower_over(T:=T)).
(* Lemma isovmonot_to_ltower_over { T : hSet_pltower }
      { X Y : T } ( isov : isover X Y ) : isover ( to_ltower_over X ) ( to_ltower_over Y ). *)
Proof.
  red.
  intros X Y isov.
  use ( @isinvovmonot_pocto T ( cntr T ) (to_ltower_over X) (to_ltower_over Y) isov ).
Defined.

Definition ltower_fun_to_ltower_over { T : hSet_pltower }:
  ltower_fun T ( hSet_ltower_over ( cntr T ) ) :=
  ltower_fun_constr ( @isovmonot_to_ltower_over T )
                     ( @isllmonot_to_ltower_over T ) ( @isbased_to_ltower_over T ).

(** **** The function lft *)

Definition lft { T : hSet_ltower }
           { X : T } { X' : ltower_over X } ( X'' : ltower_over ( pocto X' ) ): ltower_over X'.
Proof.
  use obj_over_constr.
  - split with ( pocto X'' ).
    apply ( isover_trans ( isov_isov X'' ) ( isov_isov X' ) ).
  - apply isinvovmonot_pocto.
    simpl.
    exact ( isov_isov X'' ).
Defined.

Lemma ll_lft { T : hSet_ltower }
      { X : T } { X' : ltower_over X } ( X'' : ltower_over ( pocto X' ) ):
  ll ( lft X'' ) = ll X''.
Proof.
  change
  ( ll ( pr1 X'' ) - ll X - ( ll ( pr1 X' ) - ll X ) = ll ( pr1 X'' ) - ll ( pr1 X' ) ).
  rewrite natminusassoc.
  rewrite natpluscomm.
  rewrite ( minusplusnmm _ _ ( isover_geh ( isov_isov X' ) ) ).
  apply idpath.
Defined.

Corollary isllmonot_lft { T : hSet_ltower }
      { X : T } ( X' : ltower_over X ): isllmonot ( @lft _ _ X' ).
Proof.
  unfold isllmonot.
  intros.
  do 2 rewrite ll_lft.
  apply idpath.
Defined.

Corollary isbased_lft { T : hSet_ltower }
      { X : T } ( X' : ltower_over X ): isbased ( @lft _ _ X' ).
Proof.
  unfold isbased.
  intros X0 eq0.
  rewrite ll_lft.
  exact eq0.
Defined.

Lemma isovmonot_lft { T : hSet_ltower }
      { X : T } ( X' : ltower_over X ): isovmonot ( @lft _ _ X' ).
Proof .
  unfold isovmonot.
  intros X0 Y isov.
  apply ( @isinvovmonot_pocto ( hSet_ltower_over X ) ).
  simpl.
  apply isinvovmonot_pocto.
  simpl.
  apply ( isovmonot_pocto (pocto X') _ _ isov ).
Defined.

Definition ovmonot_lft { T : hSet_ltower } { X : T } ( X' : ltower_over X ):
  ovmonot_fun ( ltower_over ( pocto X' ) ) ( ltower_over X' ) :=
  ovmonot_fun_constr _ ( isovmonot_lft X' ).

Definition ltower_fun_lft { T : hSet_ltower } { X : T } ( X' : ltower_over X ):
  ltower_fun ( ltower_over ( pocto X' ) ) ( ltower_over X' ) :=
  ltower_fun_constr ( isovmonot_lft X' ) ( isllmonot_lft X' ) ( isbased_lft X' ).

(** **** The functions ovmonot_over and ltower_fun_over *)

Definition ovmonot_over { T1 T2 : hSet_ltower } ( f : ovmonot_fun T1 T2 )
           ( X : T1 ): ovmonot_fun ( ltower_over X ) ( ltower_over ( f X ) ).
Proof.
  use ovmonot_fun_constr.
 -  intro X'.
    split with ( f ( pocto X' ) ).
    apply ( pr2 f ) .
    apply ( isov_isov X' ) .
 - intros X0 Y isov.
   simpl.
   apply isinvovmonot_pocto.
   simpl.
   apply ( pr2 f ).
   apply ( isovmonot_pocto _ _ _ isov ).
Defined.

Lemma isllmonot_ovmonot_over { T1 T2 : hSet_ltower } { f : ovmonot_fun T1 T2 } ( isf : isllmonot f )
      ( X : T1 ): isllmonot ( ovmonot_over f X ).
Proof.
  unfold isllmonot.
  intros X0 Y.
  change ( ll ( f ( pr1 X0 ) ) - ll ( f X ) - ( ll ( f ( pr1 Y ) ) - ll ( f X ) ) =
           ll X0 - ll Y ).
  do 2 rewrite isf.
  apply idpath.
Defined.

Lemma isbased_ovmonot_over { T1 T2 : hSet_ltower }
      { f : ovmonot_fun T1 T2 } ( isf : isllmonot f )
      ( X : T1 ): isbased ( ovmonot_over f X ).
Proof.
  unfold isbased.
  intros X0 eq0.
  change ( ll ( pr1 X0 ) - ll X = 0 ) in eq0.
  change ( ll ( f ( pr1 X0 ) ) - ll ( f X ) = 0 ).
  rewrite isf.
  exact eq0.
Defined.

Definition ltower_fun_over { T1 T2 : hSet_ltower } ( f : ovmonot_fun T1 T2 )
  ( isf : isllmonot f ) ( X : T1 ): ltower_fun ( ltower_over X ) ( ltower_over ( f X ) ) :=
  ltower_fun_constr ( pr2 ( ovmonot_over f X )  )
                    ( isllmonot_ovmonot_over isf X ) ( isbased_ovmonot_over isf X ).

(** **** The function to_over_pocto *)

Definition to_over_pocto  { T : hSet_ltower } { X : T } ( X' : ltower_over X )
           ( X'' : ltower_over X' ): ltower_over ( pocto X' ).
Proof.
  split with ( pocto ( pocto X'' ) ).
  apply isovmonot_pocto.
  apply ( isov_isov X'' ).
Defined.

Lemma isovmonot_to_over_pocto { T : hSet_ltower } { X : T } ( X' : ltower_over X ):
  isovmonot ( to_over_pocto X' ).
Proof.
  unfold isovmonot.
  intros X0 Y isov.
  simpl.
  apply isinvovmonot_pocto.
  simpl.
  apply isovmonot_pocto.
  apply isovmonot_pocto.
  exact isov.
Defined.

Definition ovmonot_to_over_pocto  { T : hSet_ltower } { X : T } ( X' : ltower_over X ):
  ovmonot_fun ( ltower_over X' ) ( ltower_over ( pocto X' ) ) :=
  ovmonot_fun_constr _ ( isovmonot_to_over_pocto X' ).

Lemma ll_to_over_pocto { T : hSet_ltower } { X : T } ( X' : ltower_over X )
      ( X'' : ltower_over X' ): ll ( to_over_pocto X' X'' ) = ll X''.
Proof .
  change ( ll ( pr1 ( pr1 X'' ) ) - ll ( pr1 X' ) =
           ll ( pr1 ( pr1 X'' ) ) - ll X - ( ll ( pr1 X' ) - ll X ) ).
  rewrite natminusassoc.
  rewrite natpluscomm.
  rewrite ( minusplusnmm _ _ ( isover_geh ( isov_isov X' ) ) ).
  apply idpath.
Defined.

(** the usual two corollaries follow - they should better be proven once and for all *)

Corollary isllmonot_to_over_pocto { T : hSet_ltower } { X : T } ( X' : ltower_over X ):
  isllmonot ( to_over_pocto X' ).
Proof.
  unfold isllmonot.
  intros X0 Y.
  do 2 rewrite ll_to_over_pocto.
  apply idpath.
Defined.

Corollary isbased_to_over_pocto { T : hSet_ltower } { X : T } ( X' : ltower_over X ):
  isbased ( to_over_pocto X' ).
Proof.
  unfold isbased.
  intros X0 eq0.
  rewrite ll_to_over_pocto.
  exact eq0.
Defined.

Definition ltower_fun_to_over_pocto { T : hSet_ltower } { X : T } ( X' : ltower_over X ):
  ltower_fun ( ltower_over X' ) ( ltower_over ( pocto X' ) ) :=
  ltower_fun_constr ( isovmonot_to_over_pocto X' )
                    ( isllmonot_to_over_pocto X' ) ( isbased_to_over_pocto X' ).

(** **** The function ltower_fun_second *)

Definition ovmonot_second { T : hSet_ltower } { X Y : T }
  ( f : ovmonot_fun ( ltower_over X ) ( ltower_over Y ) ) ( X' : ltower_over X ):
  ovmonot_fun ( ltower_over ( pocto X' ) ) ( ltower_over ( pocto ( f X' ) ) ).
Proof.
  set ( int1 :=
          ovmonot_funcomp ( ovmonot_lft X' )
                          ( @ovmonot_over ( hSet_ltower_over X ) ( hSet_ltower_over Y ) f X' ) ).
  apply ( ovmonot_funcomp int1 ( ovmonot_to_over_pocto _ ) ).
Defined.

Lemma isllmonot_ovmonot_second { T : hSet_ltower } { X Y : T }
  ( f : ovmonot_fun ( ltower_over X ) ( ltower_over Y ) ) ( isf : isllmonot f )
  ( X' : ltower_over X ) : isllmonot ( ovmonot_second f X' ).
Proof.
  use isllmonot_funcomp.
  - use isllmonot_funcomp.
    + apply isllmonot_lft.
    + use ( @isllmonot_ovmonot_over ( hSet_ltower_over _ )
                                    ( hSet_ltower_over _ ) _ isf X' ).
  - apply isllmonot_to_over_pocto.
Defined.

Lemma isbased_second { T : hSet_ltower } { X Y : T }
  ( f : ltower_fun ( ltower_over X ) ( ltower_over Y ) ) ( X' : ltower_over X ):
  isbased ( ovmonot_second f X' ).
Proof.
  unfold isbased.
  intros X0 eq0.
  unfold ovmonot_second.
  apply isbased_funcomp.
  - apply isbased_funcomp.
    + apply isbased_lft.
    + apply ( @isbased_ovmonot_over ( hSet_ltower_over X )
                                    ( hSet_ltower_over Y ) ).
      apply ( isllmonot_pr f ).
  - apply ( isbased_to_over_pocto ).
  - exact eq0.
Defined.

Definition ltower_fun_second { T : hSet_ltower } { X Y : T }
  ( f : ltower_fun ( ltower_over X ) ( ltower_over Y ) ) ( X' : ltower_over X ):
  ltower_fun ( ltower_over ( pocto X' ) ) ( ltower_over ( pocto ( f X' ) ) ) :=
  ltower_fun_constr ( pr2 ( ovmonot_second f X' ) )
                    ( isllmonot_ovmonot_second f ( isllmonot_pr f ) X' )
                    ( isbased_second f X' ).

(** **** The induction principle for isover *)

Definition isover_ind_int { BB : ltower }
           ( P : forall ( X Y : BB ), UU )
           ( P0 : forall ( X : BB ), P X X )
           ( Pft : forall ( X : BB ) ( gt0 : ll X > 0 ), P X ( ft X ) )
           ( Pcomp : forall ( X Y : BB ), P X ( ft X ) -> P ( ft X ) Y -> P X Y ):
  forall ( n : nat ) ( X Y : BB ) ( eq : Y = ftn n X ), P X Y.
Proof.
  induction n as [ | n IHn ].
  - intros X Y eq.
    change ( Y = X ) in eq.
    rewrite eq.
    apply P0.
  - intros X Y eq.
    destruct ( natgehchoice _ _ ( natgehn0 ( ll X ) ) ) as [ gt0 | eq0 ].
    + apply Pcomp.
      apply Pft.
      apply gt0.
      assert ( eq' : Y = ftn n ( ft X ) ).
      { rewrite ftn_ft.
        apply eq.
      }
      apply ( IHn _ _ eq' ).
    + rewrite ftnX_eq_X in eq.
      rewrite eq.
      apply P0.
      apply eq0.
Defined.

Lemma isover_ind_int_XX { BB : hSet_ltower }
           ( P : forall ( X Y : BB ), UU )
           ( P0 : forall ( X : BB ), P X X )
           ( Pft : forall ( X : BB ) ( gt0 : ll X > 0 ), P X ( ft X ) )
           ( Pcomp : forall ( X Y : BB ), P X ( ft X ) -> P ( ft X ) Y -> P X Y )
           ( n : nat ) ( eq0 : n = 0 ) ( X : BB ) ( eq : X = ftn n X ):
  isover_ind_int P P0 Pft Pcomp n X X eq = P0 X.
Proof.
  set ( Y := X ).
  change ( Y = ftn n X ) in eq.
  change (isover_ind_int P P0 Pft Pcomp n X Y eq = P0 X).
  generalize eq.
  rewrite eq0.
  intro eq1.
  assert ( eqq : eq1 = idpath X ) by apply isasetB.
  simpl.
  rewrite eqq.
  apply idpath.
Defined.

Lemma isover_ind_int_isab_eq_in_BB { BB : hSet_ltower }
      { n m : nat } ( eqn : n = S m ) { X Y : BB } ( eq : Y = ftn n X ):
  Y = ftn m ( ft X ).
Proof.
  rewrite ftn_ft.
  change ( 1 + m ) with ( S m ).
  rewrite <- eqn.
  exact eq.
Defined.

Lemma isover_ind_int_isab { BB : hSet_ltower }
           ( P : forall ( X Y : BB ), UU )
           ( P0 : forall ( X : BB ), P X X )
           ( Pft : forall ( X : BB ) ( gt0 : ll X > 0 ), P X ( ft X ) )
           ( Pcomp : forall ( X Y : BB ), P X ( ft X ) -> P ( ft X ) Y -> P X Y )
           ( n m : nat ) ( eqn : n = S m ) ( X Y : BB ) ( gt0 : ll X > 0 )
           ( eq : Y = ftn n X ) ( eq' : Y = ftn m ( ft X ) ):
  isover_ind_int P P0 Pft Pcomp n X Y eq =
  Pcomp _ _ ( Pft X gt0 ) ( isover_ind_int P P0 Pft Pcomp m ( ft X ) Y eq' ).
Proof.
  revert X Y gt0 eq eq'.
  rewrite eqn.
  intros.
  simpl.
  destruct (natgehchoice (ll X) 0 (natgehn0 (ll X))) as [ gt0' | eq0 ].
  - assert ( int : gt0 = gt0' ).
    { apply ( pr2 ( _ > _ ) ). }
    rewrite int.
(*
  assert ( int' : (uu0a.internal_identity_rew_r BB (ftn m (ft X))
           ((ft circ ftn m) X) (fun l : BB => Y = l) eq
           (ftn_ft m X)) = eq' ) .
 *)
  assert ( int' : (internal_paths_rew_r BB (ftn m (ft X))
           (ft (ftn m X)) (fun l : BB => Y = l) eq
           (ftn_ft m X)) = eq' ) by apply isasetB.
  rewrite int'.
  apply idpath.
  - assert ( gt0' : ll X > 0 ) by apply gt0 .
    rewrite eq0 in gt0'.
    destruct ( negnatgthnn _ gt0' ).
Defined.

Lemma isover_ind_int_X_ftX { BB : hSet_ltower }
           ( P : forall ( X Y : BB ), UU )
           ( P0 : forall ( X : BB ), P X X )
           ( Pft : forall ( X : BB ) ( gt0 : ll X > 0 ), P X ( ft X ) )
           ( Pcomp : forall ( X Y : BB ), P X ( ft X ) -> P ( ft X ) Y -> P X Y )
           ( Pcomp_eq : forall ( X : BB ) ( gt0 : ll X > 0 ),
                          Pcomp _ _ ( Pft _ gt0 ) ( P0 ( ft X ) ) = ( Pft _ gt0 ) )
           ( n : nat ) ( eq1 : n = 1 ) ( X : BB ) ( eq : ft X = ftn n X ) ( gt0 : ll X > 0 ):
  isover_ind_int P P0 Pft Pcomp n X ( ft X ) eq = Pft X gt0.
Proof.
  revert X eq gt0.
  rewrite eq1.
  intros X eq.
  assert ( eqq : eq = idpath _ ) by apply isasetB.
  rewrite eqq.
  intro.
  simpl.
  destruct (natgehchoice (ll X) 0 (natgehn0 (ll X))) as [ gt0' | eq0 ].
  - assert ( eq' : gt0 = gt0' ).
    { apply ( pr2 ( _ > _ ) ). }
    rewrite eq'.
    apply Pcomp_eq.
  - apply fromempty.
    rewrite eq0 in gt0.
    apply ( negnatgthnn _ gt0 ).
Defined.

Definition isover_ind { BB : ltower }
           ( P : forall ( X Y : BB ), UU )
           ( P0 : forall ( X : BB ), P X X )
           ( Pft : forall ( X : BB ) ( gt0 : ll X > 0 ), P X ( ft X ) )
           ( Pcomp : forall ( X Y : BB ), P X ( ft X ) -> P ( ft X ) Y -> P X Y ):
  forall ( X Y : BB ) ( isov : isover X Y ), P X Y :=
  fun X Y isov => isover_ind_int P P0 Pft Pcomp ( ll X - ll Y ) X Y isov.

Lemma isover_ind_XX { BB : hSet_ltower }
           ( P : forall ( X Y : BB ), UU )
           ( P0 : forall ( X : BB ), P X X )
           ( Pft : forall ( X : BB ) ( gt0 : ll X > 0 ), P X ( ft X ) )
           ( Pcomp : forall ( X Y : BB ), P X ( ft X ) -> P ( ft X ) Y -> P X Y )
           ( X : BB ) ( isov : isover X X ):
  isover_ind P P0 Pft Pcomp X X isov = P0 X.
Proof.
  apply isover_ind_int_XX.
  apply natminusnn.
Defined.

Opaque isover_ind_XX.

Lemma isover_ind_isab { BB : hSet_ltower }
           ( P : forall ( X Y : BB ), UU )
           ( P0 : forall ( X : BB ), P X X )
           ( Pft : forall ( X : BB ) ( gt0 : ll X > 0 ), P X ( ft X ) )
           ( Pcomp : forall ( X Y : BB ), P X ( ft X ) -> P ( ft X ) Y -> P X Y )
           ( X Y : BB ) ( isab : isabove X Y ):
  isover_ind P P0 Pft Pcomp X Y isab =
  Pcomp _ _ ( Pft X ( isabove_gt0 isab ) ) ( isover_ind P P0 Pft Pcomp ( ft X ) Y ( isover_ft' isab ) ).
Proof.
  apply isover_ind_int_isab.
  rewrite ll_ft.
  apply lB_2014_12_07_l1.
  apply ( isabove_gth isab ).
Defined.

Opaque isover_ind_isab.

Lemma isover_ind_X_ftX { BB : hSet_ltower }
           ( P : forall ( X Y : BB ), UU )
           ( P0 : forall ( X : BB ), P X X )
           ( Pft : forall ( X : BB ) ( gt0 : ll X > 0 ), P X ( ft X ) )
           ( Pcomp : forall ( X Y : BB ), P X ( ft X ) -> P ( ft X ) Y -> P X Y )
           ( Pcomp_eq : forall ( X : BB ) ( gt0 : ll X > 0 ),
                          Pcomp _ _ ( Pft _ gt0 ) ( P0 ( ft X ) ) = ( Pft _ gt0 ) )
           ( X : BB ) ( gt0 : ll X > 0 ):
  isover_ind P P0 Pft Pcomp X ( ft X ) ( isover_X_ftX X ) = Pft X gt0.
Proof.
  apply isover_ind_int_X_ftX.
  - intros.
    apply Pcomp_eq.
  - rewrite ll_ft.
    apply natminusmmk.
    apply ( gth0_to_geh1 gt0 ).
Defined.

(** **** Stronger induction principle for isover *)

Definition isover_strong_ind_int { BB : hSet_ltower }
           ( P : forall ( X Y : BB ) ( isov : isover X Y ), UU )
           ( P0 : forall ( X : BB ), P X X ( isover_XX X ) )
           ( Pft : forall ( X : BB ) ( gt0 : ll X > 0 ), P X ( ft X ) ( isover_X_ftX X ) )
           ( Pcomp : forall ( X Y : BB ),
                       ( forall isov1, P X ( ft X ) isov1 ) ->
                       ( forall isov2, P ( ft X ) Y isov2 ) ->
                       forall ( isab : isabove X Y ), P X Y isab ):
  forall ( n : nat ) ( X Y : BB ) ( eq : Y = ftn n X ) ( isov : isover X Y ), P X Y isov.
Proof.
  induction n as [ | n IHn ].
  - intros X Y eq isov.
    change ( Y = X ) in eq.
    revert isov.
    rewrite eq.
    intro isov.
    assert ( eq1: isov = isover_XX X ).
    { apply isaprop_isover. }
    rewrite eq1.
    apply P0.
  - intros X Y eq isov.
    destruct ( natgehchoice _ _ ( natgehn0 ( ll X ) ) ) as [ gt0 | eq0 ].
    + assert ( int1 : forall isov1 : isover X (ft X), P X (ft X) isov1).
      { intros.
        set ( int11 := Pft X gt0 ).
        assert ( eq1: isov1 = isover_X_ftX X ).
        { apply isaprop_isover. }
        rewrite eq1.
        apply int11.
      }
      assert ( int2 : forall isov2 : isover (ft X) Y, P (ft X) Y isov2).
      { intros.
        use ( IHn ( ft X ) Y ).
        rewrite ftn_ft.
        apply eq.
      }
      assert ( gt : ll X > ll Y ).
      { rewrite eq.
        rewrite ll_ftn.
        apply ( natgthgehtrans _ ( ll X - 1 ) _ ).
        * apply natminuslthn.
          -- apply gt0.
          -- apply idpath.
        * change ( ll X - S n ) with ( ll X - ( 1 + n ) ).
          rewrite <- natminusassoc.
          apply natminuslehn.
      }
      exact ( Pcomp _ _ int1 int2 ( isabove_constr gt isov ) ).
  (* assert ( int3 := Pcomp _ _ int1 int2 ) .
  set ( int31 := pr1 int3 ) . assert ( int32 := pr2 int3 ) .
  assert ( eq1: isov = int31 ) .
  apply isaprop_isover . rewrite eq1 .
  exact int32.*)
  + rewrite ftnX_eq_X in eq.
    * revert isov.
      rewrite eq.
      intro isov.
      assert ( eq1: isov = isover_XX X ).
      { apply isaprop_isover. }
      rewrite eq1.
      apply P0.
    * exact eq0.
Defined.

Definition isover_strong_ind { BB : hSet_ltower }
           ( P : forall ( X Y : BB ) ( isov : isover X Y ), UU )
           ( P0 : forall ( X : BB ), P X X ( isover_XX X ) )
           ( Pft : forall ( X : BB ) ( gt0 : ll X > 0 ), P X ( ft X ) ( isover_X_ftX X ) )
           ( Pcomp : forall ( X Y : BB ),
                       ( forall isov1, P X ( ft X ) isov1 ) ->
                       ( forall isov2, P ( ft X ) Y isov2 ) ->
                       forall isov3, P X Y isov3 ):
  forall ( X Y : BB ) ( isov : isover X Y ), P X Y isov.
Proof.
  intros.
  apply ( isover_strong_ind_int P P0 Pft Pcomp ( ll X - ll Y ) X Y isov isov ).
Defined.

(* Definition isover_strong_compt0 { BB : hSet_ltower }
           ( P : forall ( X Y : BB ) ( isov : isover X Y ) , UU )
           ( P0 : forall ( X : BB ) , P X X ( isover_XX X ) )
           ( Pft : forall ( X : BB ) ( gt0 : ll X > 0 ) , P X ( ft X ) ( isover_X_ftX X ) )
           ( Pcomp : forall ( X Y : BB ) ,
                       ( forall isov1 , P X ( ft X ) isov1 ) ->
                       ( forall isov2 , P ( ft X ) Y isov2 ) ->
                       total2 ( fun isov3 => P X Y isov3 ) )
           ( X : BB ) :  isover_strong_ind P P0 Pft Pcomp X X ( isover_XX X ) = P0 X .
Proof.
  intros.
  unfold isover_strong_ind .
  rewrite natminusnn .

  forall ( X : BB ) ( isov : isover X X ) , P X Y isov .
Proof.
  intros.
  apply ( isover_strong_ind_int P P0 Pft Pcomp ( ll X - ll Y ) X Y isov isov ) .

Defined.*)

(** * induction principle according to Lemma 2.2 of http://www.tac.mta.ca/tac/volumes/31/36/31-36.pdf *)
(** first a version that explicitly mentions natural numbers *)

Definition isover_ind_one_sided_int { BB : ltower }
           ( Γ : BB )
           ( P : forall {X : BB} (n : nat), Γ = ftn n X  -> UU )
           ( P0 : P 0 (@paths_refl _ _))
           ( Pft : forall ( X : BB ) (n : nat) ( eq : Γ = ftn (S n) X ), P n (eq @ ! (ftn_ft _ _)) -> P (S n) eq)
  : forall ( X : BB )  (n : nat) ( eq: Γ = ftn n X ), P n eq.
Proof.
  intros X n.
  revert X.
  induction n as [ | n IHn ]; intros.
  - change ( Γ = X ) in eq.
    rewrite <- eq.
    apply P0.
  - apply Pft.
    apply IHn.
Defined.

(** the induction principle we were after *)
(** notice the use of hSet_ltower - this ought to be avoided *)

Definition isover_ind_one_sided { BB : hSet_ltower }
           ( Γ : BB )
           ( P : forall {X : BB}, isover X Γ -> UU )
           ( P0 : P (isover_XX Γ) )
           ( Pft : forall ( X : BB ) ( isab : isabove X Γ ), P ( isover_ft' isab) -> P isab)
  : forall ( X : BB ) ( isov : isover X Γ ), P isov.
Proof.
  set (P' := fun {X:BB} {n: nat} (eq: Γ = ftn n X) => P _ (transportf _ (!eq) (isover_X_ftnX X n))).
  assert (P'ok : forall ( X : BB )  (n : nat) ( eq: Γ = ftn n X ) , P' X n eq).
  { apply isover_ind_one_sided_int.
    + red.
      exact P0.
    + intros X n eq IHn.
      red.
      red in IHn.
      set (H := transportf (isover (ft X)) (! (eq @ ! ftn_ft n X)) (isover_X_ftnX (ft X) n)).
      destruct ( natgehchoice _ _ ( natgehn0 ( ll X ) ) ) as [ gt0 | eq0 ].
      * assert (isab : isabove X Γ).
        { rewrite eq.
          apply isabove_X_ftnX; try assumption.
          apply natgthsn0.
        }
        specialize Pft with X isab.
        assert (eq' : isover_ft' isab = H).
        { apply isaprop_isover. }
        assert (H' : P X isab).
        { apply Pft.
          rewrite eq'.
          exact IHn.
        }
        red in isab.
        assert (eq'' : pr2 isab = transportf (isover X) (! eq) (isover_X_ftnX X (S n))).
        { apply isaprop_isover. }
        rewrite <- eq''.
        exact H'.
      * clear IHn H Pft P'.
        assert (eq' : Γ = X).
        { rewrite <- (ftnX_eq_X (S n) eq0).
          exact eq.
        }
        clear eq0.
        set (H'' := transportf (isover X) (! eq) (isover_X_ftnX X (S n))).
        set (H3 := transportf (isover X) (! eq') (isover_XX X)).
        assert (eq'' : H'' = H3) by (apply isaprop_isover).
        rewrite eq''.
        clear H'' eq'' eq.
        induction eq'.
        cbn in H3.
        unfold H3.
        apply P0.
  }
  intros.
  red in isov.
  specialize P'ok with X (ll X - ll Γ) isov.
  red in P'ok.
  assert ( eq' : isov = (transportf (isover X) (! isov) (isover_X_ftnX X (ll X - ll Γ))) ).
  { apply isasetB. }
  induction eq'.
  apply P'ok.
Defined.

(* End of the file hSet_ltowers.v *)


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Sorting.Mergesort
        Coq.Structures.Orders
        Coq.Arith.Arith
        Coq.Structures.OrderedType Coq.Structures.OrderedTypeEx
        Coq.Strings.String Coq.FSets.FMapAVL
        Fiat.Common.String_as_OT
        Fiat.Common.Tactics.CacheStringConstant
        Fiat.QueryStructure.Specification.Representation.QueryStructureNotations
        Fiat.QueryStructure.Implementation.Operations
        Fiat.QueryStructure.Implementation.DataStructures.BagADT.QueryStructureImplementation
        Fiat.QueryStructure.Implementation.DataStructures.BagADT.IndexSearchTerms
        Fiat.QueryStructure.Automation.Common.

Module OccCountOrder <: TotalLeBool.
   Definition t := (prod string nat).

   (* Largest element first *)
   Definition leb (x y : t) :=
     leb (snd y) (snd x).

   Theorem leb_total : forall a1 a2 : t, leb a1 a2 = true \/ leb a2 a1 = true.
   Proof.
     unfold t; intros; intuition; unfold leb; simpl.
     case_eq (Compare_dec.leb b b0); intuition.
     case_eq (Compare_dec.leb b0 b); intuition.
     apply leb_iff_conv in H; apply leb_iff_conv in H0.
     lia.
   Qed.

End OccCountOrder.

Module AttrCountOrder <: TotalLeBool.
  Parameter n : nat.
    Definition t := (prod (prod string (Fin.t n))  nat).

    (* Largest element first *)
    Definition leb (x y : t) :=
      leb (snd y) (snd x).

    Theorem leb_total : forall a1 a2 : t, leb a1 a2 = true \/ leb a2 a1 = true.
    Proof.
      unfold t; intros; intuition; unfold leb; simpl.
      case_eq (Compare_dec.leb b b0); intuition.
      case_eq (Compare_dec.leb b0 b); intuition.
      apply leb_iff_conv in H; apply leb_iff_conv in H0.
      lia.
    Qed.

End AttrCountOrder.

Module RelationAttributeCounter := FMapAVL.Make String_as_OT.
Module OccCountSort := Sort OccCountOrder.
Module AttrCountSort := Sort AttrCountOrder.

Record KindName
  := { KindNameKind : string;
       KindNameName : string }.

Definition OccurenceCountT {n}
           (qsSchema : Vector.t RawHeading n) :=
  ilist3 (B := fun heading => list (prod string (Attributes heading))) qsSchema.
Definition OccurenceRankT {n}
           (qsSchema : Vector.t RawHeading n) :=
  ilist3 (B := fun heading => Vector.t (RelationAttributeCounter.t nat) (NumAttr heading)) qsSchema.

Definition OccurencesCountT {n}
           (qsSchema : Vector.t RawHeading n) :=
  prod (OccurenceCountT qsSchema) (OccurenceCountT qsSchema).
Definition OccurencesRankT {n}
           (qsSchema : Vector.t RawHeading n) :=
  prod (OccurenceRankT qsSchema) (OccurenceRankT qsSchema).

Fixpoint InitAttrCount n
  : Vector.t (RelationAttributeCounter.t nat) n :=
  match n return Vector.t (RelationAttributeCounter.t nat) n with
  | 0 => Vector.nil _
  | S n' => Vector.cons _ (RelationAttributeCounter.empty nat) _ (InitAttrCount n')
  end.

Fixpoint IncrementAttrCount {n}
         (AttrRank : Vector.t (RelationAttributeCounter.t nat) n)
         (idx : Fin.t n)
         (NewOccurence : string)
         {struct idx}
  : Vector.t (RelationAttributeCounter.t nat) n.
Proof.
  refine (match idx in (Fin.t m') return
                Vector.t (RelationAttributeCounter.t nat) m'
                -> string
                -> Vector.t (RelationAttributeCounter.t nat) m' with
          | Fin.F1 q =>
            fun v new => _
          | Fin.FS q p' =>
            fun v new => _
          end AttrRank NewOccurence).
  - revert new; pattern q, v; apply Vector.caseS; intros.
    refine (match RelationAttributeCounter.find new h with
            | Some cnt => (Vector.cons _ (RelationAttributeCounter.add new (S cnt) h) _ t)
            | None => (Vector.cons _ (RelationAttributeCounter.add new 1 h) _ t)
            end).
  - generalize v p' new (fun z => IncrementAttrCount q z p'); clear; intro.
    pattern q, v; apply Vector.caseS; intros.
    exact (Vector.cons _ h _ (X t new)).
Defined.

Fixpoint InitOccRank {n}
         (qsSchema : Vector.t RawHeading n)
         {struct qsSchema}
  : OccurenceRankT qsSchema :=
  match qsSchema return OccurenceRankT qsSchema with
  | Vector.nil => inil3
  | Vector.cons sch _ qsSchema' =>
    icons3 (InitAttrCount _) (InitOccRank qsSchema')
  end.

Definition InitOccsRank {n}
           (qsSchema : Vector.t RawHeading n)
  : OccurencesRankT qsSchema :=
  (InitOccRank qsSchema, InitOccRank qsSchema).

Definition CountAttributes {n}
           (qsSchema : Vector.t RawHeading n)
           (OccCount : OccurenceCountT qsSchema)
  : OccurenceRankT qsSchema :=
  imap3 _ _ (fun heading (OccCount : list (string * (Attributes heading))) =>
               fold_right (fun attrC AttrRank => IncrementAttrCount AttrRank (snd attrC) (fst attrC)) (InitAttrCount _) OccCount) _ OccCount.

Definition CountAttributes' {n}
           (qsSchema : Vector.t RawHeading n)
           (OccCounts : OccurencesCountT qsSchema)
  : OccurencesRankT qsSchema :=
  (CountAttributes qsSchema (fst OccCounts),
   CountAttributes qsSchema (snd OccCounts)).

Fixpoint PickIndex {n}
         (AttrRank : Vector.t (RelationAttributeCounter.t nat) n)
  : list ((string * Fin.t n) * nat) :=
  match AttrRank in Vector.t _ n return
        list ((string * Fin.t n) * nat) with
  | Vector.cons attr _ AttrRank' =>
    match OccCountSort.sort (RelationAttributeCounter.elements attr) with
    | nil => (map (fun a => (fst (fst a), Fin.FS (snd (fst a)), (snd a))) (PickIndex AttrRank'))
    | a :: a' => cons (fst a, Fin.F1, snd a) (map (fun a => (fst (fst a), Fin.FS (snd (fst a)), (snd a))) (PickIndex AttrRank'))
    end
  | Vector.nil => nil
  end.

Fixpoint PickIndexes {n}
         (qsSchema : Vector.t RawSchema n)
         (OccRank : OccurencesRankT (Vector.map rawSchemaHeading qsSchema))
         {struct qsSchema}
  : ilist3 (B := fun sch => list (prod string (Attributes (rawSchemaHeading sch)))) qsSchema :=
  match qsSchema return
        OccurencesRankT (Vector.map rawSchemaHeading qsSchema)
        -> ilist3 (B := fun sch => list (prod string (Attributes (rawSchemaHeading sch)))) qsSchema with
  | Vector.cons heading _ qsSchema' =>
    fun OccRank =>
      let bestLastIndex :=
          match (PickIndex ((ilist3_hd (snd OccRank)))) with
          | idx :: _ => [fst idx]
          | _ => [ ]
          end in
      icons3 (map (@fst _ _) (PickIndex ((ilist3_hd (fst OccRank))) ) ++ bestLastIndex)
             (PickIndexes qsSchema' (ilist3_tl (fst OccRank), ilist3_tl (snd OccRank)))
  | Vector.nil => fun OccRank => inil3
  end OccRank.

(* Add a new occurence to AttrCount *)
Fixpoint InsertOccurence {n}
         {qsSchema : Vector.t RawHeading n}
         (idx : Fin.t n)
         (NewOccurence : prod string (Attributes (Vector.nth qsSchema idx)))
         (AttrCount : OccurenceCountT qsSchema)
         {struct idx}
  : OccurenceCountT qsSchema.
Proof.
  refine (match idx in (Fin.t m') return
                forall (qsSchema : Vector.t _ m'),
                  OccurenceCountT qsSchema
                  -> prod string (Attributes (Vector.nth qsSchema idx))
                  -> OccurenceCountT qsSchema with
          | Fin.F1 q =>
            fun v il new => _
          | Fin.FS q p' =>
            fun v il new => _
          end qsSchema AttrCount NewOccurence).
  - revert il new; pattern q, v; apply Vector.caseS; intros.
    exact (icons3 (new :: ilist3_hd il) (ilist3_tl il)).
  - generalize q v p' (fun z => InsertOccurence q z p') il new; clear.
      intros q v.
      pattern q, v; apply Vector.caseS; intros.
    exact (icons3 (ilist3_hd il) (X _ new (ilist3_tl il))).
Defined.

Definition InsertOccurenceOfAny {n}
           {qsSchema : Vector.t RawHeading n}
           (idx : Fin.t n)
           (NewOccurence : prod string (Attributes (Vector.nth qsSchema idx)))
           (AttrCount : OccurencesCountT qsSchema)
  : OccurencesCountT qsSchema :=
  (InsertOccurence idx NewOccurence (fst AttrCount), snd AttrCount).

Definition InsertOccurenceOfLast {n}
           {qsSchema : Vector.t RawHeading n}
           (idx : Fin.t n)
           (NewOccurence : prod string (Attributes (Vector.nth qsSchema idx)))
           (AttrCount : OccurencesCountT qsSchema)
  : OccurencesCountT qsSchema :=
  (fst AttrCount, InsertOccurence idx NewOccurence (snd AttrCount)).

Arguments InsertOccurence [_ _ _] _ _.
Fixpoint MergeOccurence {n}
         (qsSchema : Vector.t RawHeading n)
         (AttrCount1 AttrCount2 : OccurenceCountT qsSchema)
         {struct qsSchema}
  : OccurenceCountT qsSchema :=
  match qsSchema return
        forall (AttrCount1 AttrCount2 : OccurenceCountT qsSchema),
          OccurenceCountT qsSchema with
  | Vector.nil => fun AttrCount1 AttrCount2 => inil3
  | Vector.cons _ _ qsSchema' =>
    fun AttrCount1 AttrCount2 =>
      icons3 (ilist3_hd AttrCount1 ++ ilist3_hd AttrCount2)
             (MergeOccurence qsSchema' (ilist3_tl AttrCount1) (ilist3_tl AttrCount2))
  end AttrCount1 AttrCount2.

Definition MergeOccurences {n}
           (qsSchema : Vector.t RawHeading n)
           (AttrCount1 AttrCount2 : OccurencesCountT qsSchema)
  : OccurencesCountT qsSchema :=
  (MergeOccurence qsSchema (fst AttrCount1) (fst AttrCount2),
   MergeOccurence qsSchema (snd AttrCount1) (snd AttrCount2)).

Arguments MergeOccurence [_ _] _ _.

Fixpoint InitOccurence {n}
         (qsSchema : Vector.t RawHeading n)
         {struct qsSchema}
  : OccurenceCountT qsSchema :=
  match qsSchema return OccurenceCountT qsSchema with
  | Vector.nil => inil3
  | Vector.cons _ _ qsSchema' =>
    icons3 nil (InitOccurence qsSchema')
  end.

Definition InitOccurences {n}
           (qsSchema : Vector.t RawHeading n)
  : OccurencesCountT qsSchema :=
  (InitOccurence qsSchema, InitOccurence qsSchema).

Definition GetOccurence {n}
           {qsSchema : Vector.t RawHeading n}
           (AttrCount : OccurenceCountT qsSchema)
           (idx : Fin.t n)
  : list (prod string (Attributes (Vector.nth qsSchema idx))) :=
  ith3 AttrCount idx.

Class TermAttributeCounter {A : Type}
      (qsSchema : RawQueryStructureSchema)
      (a : A)
      (Ridx : Fin.t _)
      (BAidx : @Attributes (Vector.nth (Vector.map rawSchemaHeading (qschemaSchemas qsSchema)) Ridx))
  := { }.

Global Instance GetAttributeRawTermCounter {qsSchema}
       {Ridx : Fin.t _}
       {tup : @RawTuple (Vector.nth _ Ridx)}
       {BAidx : _ }
  : (TermAttributeCounter qsSchema (@GetAttributeRaw _ tup BAidx) Ridx BAidx) | 0 := Build_TermAttributeCounter qsSchema _ Ridx BAidx.

(*Ltac TermAttributes Term k :=
  match Term with
  | fun tups => @GetAttributeRaw _ (@?f tups) ?BAidx =>
    let Aidx := eval simpl in BAidx in
        match type of f with
        | _ -> @RawTuple (Vector.nth _ ?Ridx) =>
          k Ridx Aidx
        end
  end. *)

Class ExpressionAttributeCounter
      {A : Type}
      (qsSchema : RawQueryStructureSchema)
      (a : A)
      (occCount : OccurencesCountT (Vector.map rawSchemaHeading (qschemaSchemas qsSchema))) := { }.

(*Instance ExpressionAttributeCounterAnyT {A}
         {qsSchema}
         {a : A}
  : @ExpressionAttributeCounter _ qsSchema a
                                (InitOccurences _) | 100 :=
  @Build_ExpressionAttributeCounter A qsSchema a (InitOccurences _). *)

Global Instance ExpressionAttributeCounter_And
       {qsSchema : RawQueryStructureSchema}
       {A B}
       {OccCountL OccCountR}
       (ExpCountL : @ExpressionAttributeCounter _ qsSchema A OccCountR)
       (ExpCountR : @ExpressionAttributeCounter _ qsSchema B OccCountL)
  : @ExpressionAttributeCounter _ qsSchema (A /\ B) (MergeOccurences OccCountL OccCountR) := { }.

Instance ExpressionAttributeCounterEqLR {A }
         {qsSchema : RawQueryStructureSchema}
         {a a' : A}
         (RidxL RidxR : Fin.t _)
         (BAidxL : @Attributes (Vector.nth _ RidxL))
         (BAidxR : @Attributes (Vector.nth _ RidxR))
         (ExpCountL : @TermAttributeCounter _ qsSchema a RidxL BAidxL)
         (ExpCountR : @TermAttributeCounter _ qsSchema a' RidxR BAidxR)
  : @ExpressionAttributeCounter _ qsSchema (a = a')
                                (@InsertOccurenceOfAny _ _ RidxL (EqualityIndex, BAidxL) (@InsertOccurenceOfAny _ _ RidxR (EqualityIndex, BAidxR) (InitOccurences _))) | 0 := { }.

Instance ExpressionAttributeCounterEqL {A }
         {qsSchema}
         {a a' : A}
         (RidxL : Fin.t _)
         (BAidxL : @Attributes (Vector.nth _ RidxL))
         (ExpCountL : @TermAttributeCounter _ qsSchema a RidxL BAidxL)
  : @ExpressionAttributeCounter _ qsSchema (a = a')
                                (@InsertOccurenceOfAny _ _ RidxL (EqualityIndex, BAidxL) (InitOccurences _)) | 10 := { }.

Instance ExpressionAttributeCounterEqR {A }
         {qsSchema}
         {a a' : A}
         (RidxR : Fin.t _)
         (BAidxR : @Attributes (Vector.nth _ RidxR))
         (ExpCountL : @TermAttributeCounter _ qsSchema a' RidxR BAidxR)
  : @ExpressionAttributeCounter _ qsSchema (a = a')
                                (@InsertOccurenceOfAny _ _ RidxR (EqualityIndex, BAidxR) (InitOccurences _)) | 10 := { }.

Instance ExpressionAttributeCounterWhere {ResultT}
         {qsSchema : RawQueryStructureSchema}
         (P : Prop)
         (WhereBody : Comp (list ResultT))
         OccCountCond
         OccCountBody
         (ExpCountCond : @ExpressionAttributeCounter _ qsSchema P OccCountCond)
         (ExpCountBody : @ExpressionAttributeCounter _ qsSchema WhereBody OccCountBody)
  : @ExpressionAttributeCounter _ qsSchema
                                (Query_Where P WhereBody) (MergeOccurences OccCountCond OccCountBody) | 0 := { }.

Definition ExpressionAttributeCounterPick {A}
           {qsSchema : QueryStructureSchema}
           (P : Ensemble A)
  : ExpressionAttributeCounter qsSchema (Pick P)
                               (InitOccurences _) :=
  Build_ExpressionAttributeCounter qsSchema (Pick P) (InitOccurences _).

#[export]
Hint Extern 10 (ExpressionAttributeCounter ?qsSchema (Pick ?P) _) =>
apply ExpressionAttributeCounterPick : core.

#[export]
Hint Extern 0 (@TermAttributeCounter _ ?qsSchema (@GetAttributeRaw _ ?tup ?BAidx) ?Ridx' ?BAidx') =>
match type of tup with
| @RawTuple (@GetNRelSchemaHeading _ _ ?Ridx) =>
  unify Ridx Ridx'; unify BAidx BAidx'; (* have to unify these evars for the lemma to apply*)
  eapply (@GetAttributeRawTermCounter qsSchema Ridx tup BAidx)
end : typeclass_instances.

#[export]
Hint Extern 0 (@TermAttributeCounter
                 _ ?qsSchema
                 (GetAttribute ?tup {| bindex := _;
                                       indexb := {| ibound := ?BAidx;
                                                    boundi := _ |} |} ) ?Ridx' ?BAidx') =>
match type of tup with
| @RawTuple (@GetNRelSchemaHeading _ _ ?Ridx) =>
  unify Ridx Ridx'; unify BAidx BAidx'; (* have to unify these evars for the lemma to apply*)
  eapply (@GetAttributeRawTermCounter qsSchema Ridx tup BAidx)
end : typeclass_instances.

Instance ExpressionAttributeCounterQueryIn {ResultT}
         {qsSchema : RawQueryStructureSchema}
         {qs : UnConstrQueryStructure qsSchema}
         (Ridx : Fin.t _)
         (QueryBody : RawTuple -> Comp (list ResultT))
         OccCount
         (ExpCountBod : forall tup,
             @ExpressionAttributeCounter _ qsSchema (QueryBody tup) OccCount)
  : @ExpressionAttributeCounter _ qsSchema
                                (@UnConstrQuery_In ResultT qsSchema qs Ridx QueryBody) OccCount | 0 := { }.

Instance ExpressionAttributeCounterBind {A B}
         {qsSchema : RawQueryStructureSchema}
         (ca : Comp A)
         (cb : A -> Comp B)
         OccCountA OccCountB
         (ExpCountA : @ExpressionAttributeCounter _ qsSchema ca OccCountA)
         (ExpCountB : forall a, @ExpressionAttributeCounter _ qsSchema (cb a) OccCountB)
  : @ExpressionAttributeCounter _ qsSchema
                                (Bind ca cb)
                                (MergeOccurences OccCountA OccCountB) | 0 := { }.

Instance ExpressionAttributeCounterFor {A}
         {qsSchema : RawQueryStructureSchema}
         (c : Comp (list A))
         OccCountA
         (ExpCountA : @ExpressionAttributeCounter _ qsSchema c OccCountA)
  : @ExpressionAttributeCounter _ qsSchema
                                (For c)
                                OccCountA | 0 := { }.

Instance ExpressionAttributeCounterCount {A}
         {qsSchema : RawQueryStructureSchema}
         (c : Comp (list A))
         OccCountA
         (ExpCountA : @ExpressionAttributeCounter _ qsSchema c OccCountA)
  : @ExpressionAttributeCounter _ qsSchema
                                (Count c)
                                OccCountA | 0 := { }.

Instance ExpressionAttributeCounterMaxN
         {qsSchema : RawQueryStructureSchema}
         (c : Comp (list N))
         OccCountA
         (ExpCountA : @ExpressionAttributeCounter _ qsSchema c OccCountA)
  : @ExpressionAttributeCounter _ qsSchema
                                (MaxN c)
                                OccCountA | 0 := { }.

Instance ExpressionAttributeCounterMaxZ
         {qsSchema : RawQueryStructureSchema}
         (c : Comp (list Z))
         OccCountA
         (ExpCountA : @ExpressionAttributeCounter _ qsSchema c OccCountA)
  : @ExpressionAttributeCounter _ qsSchema
                                (MaxZ c)
                                OccCountA | 0 := { }.

Instance ExpressionAttributeCounterSumN
         {qsSchema : RawQueryStructureSchema}
         (c : Comp (list N))
         OccCountA
         (ExpCountA : @ExpressionAttributeCounter _ qsSchema c OccCountA)
  : @ExpressionAttributeCounter _ qsSchema
                                (SumN c)
                                OccCountA | 0 := { }.

Instance ExpressionAttributeCounterSumZ
         {qsSchema : RawQueryStructureSchema}
         (c : Comp (list Z))
         OccCountA
         (ExpCountA : @ExpressionAttributeCounter _ qsSchema c OccCountA)
  : @ExpressionAttributeCounter _ qsSchema
                                (SumZ c)
                                OccCountA | 0 := { }.

Instance ExpressionAttributeCounterIfThenElse {A}
         {qsSchema : RawQueryStructureSchema}
         (ci : bool)
         (ct ce : Comp A)
         OccCountT OccCountE
         (ExpCountT : @ExpressionAttributeCounter _ qsSchema ct OccCountT)
         (ExpCountE : @ExpressionAttributeCounter _ qsSchema ce OccCountE)
  : @ExpressionAttributeCounter _ qsSchema
                                (If_Then_Else ci ct ce)
                                (MergeOccurences OccCountT OccCountE) | 0 := { }.

Instance ExpressionAttributeCounterifthenelse {A}
         {qsSchema : RawQueryStructureSchema}
         (ci : bool)
         (ct ce : Comp A)
         OccCountT OccCountE
         (ExpCountT : @ExpressionAttributeCounter _ qsSchema ct OccCountT)
         (ExpCountE : @ExpressionAttributeCounter _ qsSchema ce OccCountE)
  : @ExpressionAttributeCounter _ qsSchema
                                (if ci then ct else ce)
                                (MergeOccurences OccCountT OccCountE) | 0 := { }.

Instance ExpressionAttributeCounterIfOptThenElse {A B}
         {qsSchema : RawQueryStructureSchema}
         (ci : option A)
         (ct : A -> Comp B)
         (ce : Comp B)
         OccCountT OccCountE
         (ExpCountT : forall a,
             @ExpressionAttributeCounter _ qsSchema (ct a) OccCountT)
         (ExpCountE : @ExpressionAttributeCounter _ qsSchema ce OccCountE)
  : @ExpressionAttributeCounter _ qsSchema
                                (If_Opt_Then_Else ci ct ce)
                                (MergeOccurences OccCountT OccCountE) | 0 := { }.

Instance ExpressionAttributeCounterReturn {A}
         {qsSchema}
         {a : A}
  : ExpressionAttributeCounter qsSchema (Return a)
                               (InitOccurences _) | 0 :=
  Build_ExpressionAttributeCounter qsSchema (Return a) (InitOccurences _).

Instance ExpressionAttributeCounterRet {A}
         {qsSchema}
         {a : A}
  : ExpressionAttributeCounter qsSchema (ret a)
                               (InitOccurences _) | 0 :=
  Build_ExpressionAttributeCounter qsSchema (ret a) (InitOccurences _).

Instance ExpressionAttributeCounterEmpty
         {qsSchema : QueryStructureSchema}
  : ExpressionAttributeCounter qsSchema (QSEmptySpec qsSchema)
                               (InitOccurences _) | 0 :=
  Build_ExpressionAttributeCounter qsSchema (QSEmptySpec qsSchema) (InitOccurences _).

Instance ExpressionAttributeCounterConstructorsCons
         {qsSchema : RawQueryStructureSchema}
         {Dom}
         {n n'}
         (consSigs : Vector.t consSig n)
         (methSigs : Vector.t methSig n')
         (consDefs : @ilist consSig (@consDef (UnConstrQueryStructure qsSchema)) n consSigs)
         (methDefs : @ilist methSig (@methDef (UnConstrQueryStructure qsSchema)) n' methSigs)
         (con : @consDef _ Dom)
         OccCountC OccCountRest
         (ExpCountC :
            Lift_Constructor1P _
             (fun cons => @ExpressionAttributeCounter _ qsSchema cons OccCountC) (consBody con))
         (ExpCountRest : @ExpressionAttributeCounter _ qsSchema
                                                     (BuildADT (Rep := UnConstrQueryStructure qsSchema) consDefs methDefs)
                                                     OccCountRest)
  : @ExpressionAttributeCounter _ qsSchema
                                (BuildADT (Rep := UnConstrQueryStructure qsSchema) (icons con consDefs) methDefs)
                                (MergeOccurences OccCountC OccCountRest) | 0 := { }.

Instance ExpressionAttributeCounterMethodsCons
         {qsSchema : RawQueryStructureSchema}
         {mSig}
         {n'}
         (methSigs : Vector.t methSig n')
         (methDefs : @ilist methSig (@methDef (UnConstrQueryStructure qsSchema)) n' methSigs)
         (meth : @methDef (UnConstrQueryStructure qsSchema) mSig)
         OccCountM OccCountRest
         (ExpCountM : forall r,
             Lift_Method1P _ _
                           (fun _ meth => @ExpressionAttributeCounter _ qsSchema meth OccCountM)
                           (fun meth => @ExpressionAttributeCounter _ qsSchema meth OccCountM)
                           (methBody meth r))
         (ExpCountRest : @ExpressionAttributeCounter _ qsSchema
                                                     (BuildADT (Rep := UnConstrQueryStructure qsSchema) inil methDefs)
                                                     OccCountRest)
  : @ExpressionAttributeCounter _ qsSchema
                                (BuildADT (Rep := UnConstrQueryStructure qsSchema) inil (icons meth methDefs))
                                (MergeOccurences OccCountM OccCountRest) | 0 := { }.

Instance ExpressionAttributeCounterMethodsNil
         {qsSchema : RawQueryStructureSchema}
  : @ExpressionAttributeCounter _ qsSchema
                                (BuildADT (Rep := UnConstrQueryStructure qsSchema) inil inil)
                                (InitOccurences _) | 0 := { }.

Instance ExpressionAttributeCounter_True
         {qsSchema : RawQueryStructureSchema}
  : @ExpressionAttributeCounter _ qsSchema True (InitOccurences _) := { }.

Instance ExpressionAttributeCounter_Not
         {qsSchema : RawQueryStructureSchema}
         (P : Prop)
  : @ExpressionAttributeCounter _ qsSchema (~ P) (InitOccurences _) := { }.

(* BFS attribute use counter  *)

Definition ExpressionAttributeCounter_Any {A}
           {a : A}
           {qsSchema : RawQueryStructureSchema}
  : @ExpressionAttributeCounter _ qsSchema a (InitOccurences _) :=
  Build_ExpressionAttributeCounter qsSchema a (InitOccurences _).

Ltac GetAttributeRawTermCounterTac t :=
  lazymatch goal with
  _ => match goal with
         |- @TermAttributeCounter _ ?qsSchema (@GetAttributeRaw _ ?tup ?BAidx) ?Ridx' ?BAidx' =>
         match type of tup with
         | @RawTuple (@GetNRelSchemaHeading _ _ ?Ridx) =>
           unify Ridx Ridx'; unify BAidx BAidx'; (* have to unify these evars for the lemma to apply*)
           eapply (@GetAttributeRawTermCounter qsSchema Ridx tup BAidx)
         end
       end
end.

Ltac GetAttributeRawTermCounterTacBindex t :=
  lazymatch goal with
  _ => match goal with
         |- @TermAttributeCounter
              _ ?qsSchema
              (GetAttribute ?tup {| bindex := _;
                                    indexb := {| ibound := ?BAidx;
                                                 boundi := _ |} |} ) ?Ridx' ?BAidx' =>
         match type of tup with
         | @RawTuple (@GetNRelSchemaHeading _ _ ?Ridx) =>
           unify Ridx Ridx'; unify BAidx BAidx'; (* have to unify these evars for the lemma to apply*)
           eapply (@GetAttributeRawTermCounter qsSchema Ridx tup BAidx)
         end
       end
end.

Ltac EqExpressionAttributeCounter :=
  psearch_lazy_combine
    ltac:(GetAttributeRawTermCounterTacBindex)
  ltac:(psearch_lazy_combine
    ltac:(GetAttributeRawTermCounterTac)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounter_And; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterEqLR; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterEqL; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterEqR; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterWhere; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterQueryIn; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterBind; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterFor; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterCount; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterMaxN; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterMaxZ; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterIfThenElse; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterifthenelse; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterIfOptThenElse; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterConstructorsCons; simpl Lift_Constructor1P; intros)
  ltac:(psearch_combine
    ltac:(eapply @ExpressionAttributeCounterMethodsCons; simpl Lift_Method1P; intros)
  ltac:(fun _ => eapply @ExpressionAttributeCounter_Any)))))))))))))))))).

Ltac GenerateIndexesForAll FindAttributeUses k :=
  match goal with
    |- context [@BuildADT (UnConstrQueryStructure ?qsSchema) _ _ ?consSigs ?methSigs ?consDefs ?methDefs ] =>
    makeEvar (OccurencesCountT
                (Vector.map rawSchemaHeading (qschemaSchemas qsSchema)))
             ltac:(fun e => let H := fresh in
                            assert (@ExpressionAttributeCounter _ qsSchema (@BuildADT _ _ _ consSigs methSigs consDefs methDefs) e) as H by psearch 200 FindAttributeUses ();
                   clear H;
                   k e
                  )
  end.

Ltac GenerateIndexesForOne FindAttributeUses idx k :=
  match goal with
    |- context [ @BuildADT (UnConstrQueryStructure ?qsSchema) _ _ ?consSigs ?methSigs ?consDefs ?methDefs ] =>
    let meth := eval simpl in
    (callMeth (@BuildADT (UnConstrQueryStructure qsSchema) _ _ consSigs methSigs consDefs methDefs) idx) in  makeEvar (OccurencesCountT
                                                                                (Vector.map rawSchemaHeading (qschemaSchemas qsSchema)))
                                                                                ltac:(fun e => let H := fresh in
                                                                                assert (forall r d, @ExpressionAttributeCounter _ qsSchema (meth r d) e) as H by psearch 200 FindAttributeUses ();
                                                                                clear H;
                                                                                k e
                                                                                )
  end.

(*Lemma refineADT_DelegateToBag_refine_All
      (qsSchema : RawQueryStructureSchema)
      (BagIndexKeys : ilist3 (qschemaSchemas qsSchema))
  : forall (n n' : nat) (consSigs : Vector.t consSig n)
           (methSigs : Vector.t methSig n')
           (consDefs : @ilist consSig consDef n consSigs)
           (methDefs : @ilist methSig methDef n' methSigs)
           attributeCount attributeCount'
           (refined_consDefs : @ilist consSig consDef n consSigs)
           (refined_methDefs : @ilist methSig methDef n' methSigs),
    ExpressionAttributeCounter qsSchema (BuildADT consDefs methDefs) attributeCount
    -> attributeCount' = CountAttributes' attributeCount
    -> BuildIndexSearchUpdateTerms (schemas:= qschemaSchemas qsSchema)
                                   (PickIndexes (qschemaSchemas qsSchema) attributeCount')
                                   BagIndexKeys

    -> refine_Constructors (@DelegateToBag_AbsR qsSchema BagIndexKeys) consDefs refined_consDefs ->
    refine_Methods (@DelegateToBag_AbsR qsSchema BagIndexKeys) methDefs refined_methDefs ->
    refineADT
      (BuildADT consDefs methDefs)
      (BuildADT refined_consDefs refined_methDefs).
Proof.
  eauto using refineADT_BuildADT_Rep_refine_All.
Qed.

Global Opaque IndexSearchTerm.
Global Opaque IndexUpdateTerm.

Ltac BuildEqIndexSearchTerms :=
  psearch_combine
    ltac:(apply (@EqualityIndexSearchTerm {| AttrList := _ |}))
           ltac:(fun _ => apply (@DefaultIndexSearchTerm {| AttrList := _ |})).

Ltac BuildEqIndexUpdateTerms :=
  fun _ => apply DefaultIndexUpdateTerm.

Ltac select_indexes FindAttributeUses BuildSearchIndexes BuildUpdateIndexes :=
  match goal with
  | [ |- Sharpened (@BuildADT (UnConstrQueryStructure ?qsSchema) _ _ _ _ _ _ ) ] =>
    let index := fresh in
    makeEvar (ilist3 (B := fun sch => SearchUpdateTerms (rawSchemaHeading sch))
                     (qschemaSchemas qsSchema))
             ltac:(fun l => pose l as index;
                   pose_string_hyps; pose_heading_hyps;
                   eapply SharpenStep;
                   [ eapply refineADT_DelegateToBag_refine_All with (BagIndexKeys := index);
                     [ (* Gather attribute uses using hints in [CountAttributes]. *)
                       psearch 200 FindAttributeUses ()
                     | compute; reflexivity
                     | simpl; repeat (* Select indexes for each relation. *)
                                first [eapply BuildIndexSearchUpdateTerms_cons;
                                        [ (* Convert attribute uses to search terms *)
                                          (* using hints in [BuildSearchIndexes]. *)
                                          psearch 200 BuildSearchIndexes ()
                                        | (* Convert attribute uses to update terms *)
                                        (* using hints in [BuildUpdateIndexes]. *)
                                        psearch 200 BuildUpdateIndexes ()
                                        | ]
                                      | eapply BuildIndexSearchUpdateTerms_nil]
                     | (* Spawn refinement goals for each constructor. *)
                     repeat (first [eapply refine_Constructors_nil
                                   | eapply refine_Constructors_cons;
                                     [ intros;
                                       match goal with
                                       |  |- refine _ (?E _) => let H := fresh in set (H := E)
                                       | _ => idtac
                                       end | ] ])

                     | (* Spawn refinement goals for each method. *)
                     repeat (first [eapply refine_Methods_nil
                                   | eapply refine_Methods_cons;
                                     [ intros;
                                       match goal with
                                       |  |- refine _ (?E _ _) => let H := fresh in set (H := E)
                                       | _ => idtac
                                       end | ]
                            ])
                     ]
                   | ])
  end. *)

Ltac make_simple_indexes attrlist BuildEarlyIndex BuildLastIndex:=
  match goal with
  | [ |- Sharpened (@BuildADT (UnConstrQueryStructure ?sch) _ _ _ _ _ _ ) ] =>
    let sch' := eval simpl in (qschemaSchemas sch) in
        makeIndex' sch' attrlist
                   BuildEarlyIndex BuildLastIndex
                   ltac:(fun l =>
                           pose_string_hyps; pose_heading_hyps;
                         let index := fresh "Index" in
                         pose l as index;
                         simpl in index;
                         pose_string_hyps_in index; pose_heading_hyps_in index;
                         pose_search_term_in index;
                         pose_SearchUpdateTerms_in index;
                         hone representation using (@DelegateToBag_AbsR sch index))
  end.

(* Recurse over [fds] to find an attribute matching s *)
Ltac findMatchingTerm fds kind s k :=
  match fds with
  | ({| KindIndexKind := ?IndexType;
        KindIndexIndex := ?fd |}, ?X) =>
    (* Check if this field name is equal to s; process [X] with [k] if so. *)
    let H := fresh in
    assert (H : s = fd) by reflexivity; clear H;
    assert (H : kind = IndexType) by reflexivity; clear H;
    k X
  | (?fds1, ?fds2) => findMatchingTerm fds1 kind s k || findMatchingTerm fds2 kind s k
  end.


Generalizable Variables T A.

Inductive path `(a: A): A -> Type := idpath: path a a.

Class TMonad (T: Type -> Type) := {
  bind: forall {A B: Type}, (T A) -> (A -> T B) -> T B;
  ret: forall {A: Type}, A -> T A;
  ret_unit_left: forall {A B: Type} (k: A -> T B) (a: A),
                 path (bind (ret a) k) (k a)
  }.

Let T_fzip `{TMonad T} := fun (A B: Type) (f: T (A -> B)) (t: T A)
                  => bind t (fun a => bind f (fun g => ret (g a) )).
Let T_pure `{TMonad T} := @ret _ _.

Let T_pure_id `{TMonad T} {A: Type} (t: A -> A) (x: T A):
        path (T_fzip A A (T_pure (A -> A) t) x) x.
  unfold T_fzip, T_pure.
  Fail rewrite (ret_unit_left (fun g a => ret (g a)) (fun x => x)).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C Cprime : Universe, ((wd_ B A /\ (wd_ B Cprime /\ (wd_ A C /\ (wd_ B C /\ (col_ A B Cprime /\ col_ A B C))))) -> col_ B Cprime C)).
Proof.
  time tac.
Qed.

End FOFProblem.