Require Import Coq.ZArith.ZArith.
Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Named.GetNames.
Require Crypto.Compilers.Named.Syntax.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.Notations.

Local Open Scope Z_scope.

Section named.
  Context {Name : Type}
          (name_beq : Name -> Name -> bool).
  Import Named.Syntax.
  Local Notation flat_type := (flat_type base_type).
  Local Notation type := (type base_type).
  Local Notation exprf := (@exprf base_type op Name).
  Local Notation expr := (@expr base_type op Name).

  Local Notation tZ := (Tbase TZ).
  Local Notation ADC bw c x y := (Op (@AddWithGetCarry bw TZ TZ TZ TZ TZ)
                                     (Pair (Pair (t1:=tZ) c (t2:=tZ) x) (t2:=tZ) y)).
  Local Notation ADD bw x y := (ADC bw (Op (OpConst 0) TT) x y).
  Local Notation ADX x y := (Op (@Add TZ TZ TZ) (Pair (t1:=tZ) x (t2:=tZ) y)).
  Local Infix "=Z?" := Z.eqb.
  Local Infix "=n?" := name_beq.

  Definition is_const_or_var {t} (v : exprf t)
    := match v with
       | Var _ _ => true
       | Op _ _ (OpConst _ _) TT => true
       | _ => false
       end.

  Fixpoint name_list_has_duplicate (ls : list Name) : bool
    := match ls with
       | nil => false
       | cons n ns
         => orb (name_list_has_duplicate ns)
                (List.fold_left orb (List.map (name_beq n) ns) false)
       end.

  Definition invertT t
    := option ((Name * Name * Z * exprf tZ * exprf tZ)
               * (Name * Name * Z * exprf tZ * Name)
               * (((Name * Name * Name) * exprf t)
                  + exprf t)).

  Definition invert_for_do_rewrite_step1 {t} (e : exprf t)
    : option ((Name * Name * Z * exprf tZ * exprf tZ) * exprf t)
    := match e in Named.exprf _ _ _ t return option ((Name * Name * Z * exprf tZ * exprf tZ) * exprf t) with
       | (nlet (a2, c1) : tZ * tZ := (ADD bw1 a b as ex0) in P0)
         => Some ((a2, c1, bw1, a, b), P0)
       | _ => None
       end%core%nexpr%bool.
  Definition invert_for_do_rewrite_step2 {t} (e : exprf t)
    : option ((Name * Name * Z * exprf tZ * Name) * exprf t)
    := match e in Named.exprf _ _ _ t return option ((Name * Name * Z * exprf tZ * Name) * exprf t) with
       | (nlet (s , c2) : tZ * tZ := (ADD bw2 c0 (Var TZ a2') as ex1) in P1)
         => Some ((s, c2, bw2, c0, a2'), P1)
       | _ => None
       end%core%nexpr%bool.
  Definition invert_for_do_rewrite_step3 {t} (e : exprf t)
    : option ((Name * Name * Name) * exprf t)
    := match e in Named.exprf _ _ _ t return option ((Name * Name * Name) * exprf t) with
       | (nlet c        : tZ      := (ADX (Var TZ c1') (Var TZ c2') as ex2) in P)
         => Some ((c, c1', c2'), P)
       | _ => None
       end%core%nexpr%bool.

  Definition invert_for_do_rewrite {t} (e : exprf t)
    : invertT t
    := match invert_for_do_rewrite_step1 e with
       | Some ((a2, c1, bw1, a, b), P0)          (* (nlet (a2, c1) : tZ * tZ := (ADD bw1 a b as ex0) in P0) *)
         => match invert_for_do_rewrite_step2 P0 with
            | Some ((s, c2, bw2, c0, a2'), P1)   (* (nlet (s , c2) : tZ * tZ := (ADD bw2 c0 (Var TZ a2') as ex1) in P1) *)
              => match match invert_for_do_rewrite_step3 P1 with
                       | Some ((c, c1', c2'), P) (* (nlet c        : tZ      := (ADX (Var TZ c1') (Var TZ c2') as ex2) in P) as P1' *)
                         => if (((bw1 =Z? bw2) && (a2 =n? a2') && (c1 =n? c1') && (c2 =n? c2'))
                                  && (is_const_or_var c0 && is_const_or_var a && is_const_or_var b)
                                  && negb (name_list_has_duplicate (a2::c1::s::c2::c::nil ++ get_namesf c0 ++ get_namesf a ++ get_namesf b)%list))
                            then Some ((a2, c1, bw1, a, b),
                                       (s, c2, bw2, c0, a2'),
                                       inl ((c, c1', c2'), P))
                            else None
                       | None => None
                       end with
                 | Some v => Some v
                 | None => if (((bw1 =Z? bw2) && (a2 =n? a2'))
                                 && (is_const_or_var c0 && is_const_or_var a && is_const_or_var b)
                                 && negb (name_list_has_duplicate (a2::c1::s::c2::nil ++ get_namesf c0 ++ get_namesf a ++ get_namesf b)%list))
                           then Some ((a2, c1, bw1, a, b),
                                      (s, c2, bw2, c0, a2'),
                                      inr P1)
                           else None
                 end
            | None => None
            end
       | None => None
       end%core%nexpr%bool.

  Definition do_rewrite {t} (e : exprf t)
    : exprf t
    := match invert_for_do_rewrite e with
       | Some ((a2, c1, bw1, a, b),
               (s, c2, bw2, c0, a2'),
               inl ((c, c1', c2'), P))
         => (nlet (a2, c1) : tZ * tZ := ADD bw1 a b in
             nlet (s , c2) : tZ * tZ := ADD bw2 c0 (Var a2') in
             nlet c        : tZ      := ADX (Var c1') (Var c2') in
             nlet (s, c)   : tZ * tZ := ADC bw1 c0 a b in
             P)
       | Some ((a2, c1, bw1, a, b),
               (s, c2, bw2, c0, a2'),
               inr P)
         => (nlet (a2, c1) : tZ * tZ := ADD bw1 a b in
             nlet (s , c2) : tZ * tZ := ADD bw2 c0 (Var a2') in
             nlet s        : tZ      := (nlet (s, c1) : tZ * tZ := ADC bw1 c0 a b in Var s) in
             P)
       | None
         => e
       end%core%nexpr.

  Definition rewrite_exprf_prestep
             (rewrite_exprf : forall {t} (e : exprf t), exprf t)
             {t} (e : exprf t)
    : exprf t
    := match e in Named.exprf _ _ _ t return exprf t with
       | TT => TT
       | Var _ n => Var n
       | Op _ _ opc args
         => Op opc (@rewrite_exprf _ args)
       | (nlet nx := ex in eC)
         => (nlet nx := @rewrite_exprf _ ex in @rewrite_exprf _ eC)
       | Pair tx ex ty ey
         => Pair (@rewrite_exprf tx ex) (@rewrite_exprf ty ey)
       end%nexpr.

  Fixpoint rewrite_exprf {t} (e : exprf t) : exprf t
    := do_rewrite (@rewrite_exprf_prestep (@rewrite_exprf) t e).

  Definition rewrite_expr {t} (e : expr t) : expr t
    := match e in Named.expr _ _ _ t return expr t with
       | Abs _ _ n f => Abs n (rewrite_exprf f)
       end.
End named.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                                 Zbase.v                                  *)
(****************************************************************************)

(* Basic definitions on type Z *)

(*************)
Inductive Z : Set :=
  | OZ : Z
  | pos : nat -> Z
  | neg : nat -> Z.

(***********)
Definition IZ := pos 0.

(****************)
(* was
Fixpoint is_posn [x,z :Z] : Prop :=
Cases x z of
  OZ       y => False
| (pos n) OZ => False
| (pos n) (pos m) => (eq nat n m)
| (pos n) (neg m) => False
| (neg n) y => False
end .
*)

Definition is_posn (x z : Z) :=
  match x, z with
  | pos n, pos m => n = m :>nat
  | _, _ => False
  end.

(**********************)
Lemma tech_pos_not_posZ : forall n m : nat, n <> m -> pos n <> pos m.

unfold not in |- *; intros.
cut (is_posn (pos n) (pos m)).
simpl in |- *; exact H. rewrite H0; simpl in |- *; reflexivity.
Qed.

(**************)
Lemma eq_OZ_dec : forall x : Z, {x = OZ} + {x <> OZ}.

intros; elim x.
left; reflexivity.
intros; right; discriminate.
intros; right; discriminate.
Qed.

(**************)
Definition posOZ (n : nat) :=
  match n return Z with
  | O =>
      (* O *)  OZ
      (* S n' *)
  | S n' => pos n'
  end.

(**************)
Definition negOZ (n : nat) :=
  match n return Z with
  | O =>
      (* O *)  OZ
      (* S n' *)
  | S n' => neg n'
  end.

(*************)
Definition absZ (x : Z) :=
  match x return Z with
  | OZ =>
      (* OZ *)  OZ
      (* pos n *)
  | pos n => pos n
      (* neg n *)
  | neg n => pos n
  end.

(*************)
Definition sgnZ (x : Z) :=
  match x return Z with
  | OZ =>
      (* OZ *)  OZ
      (* pos n *)
  | pos n => pos 0
      (* neg n *)
  | neg n => neg 0
  end.


From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import Coq.Program.Equality.

Require Import Notations.
Require Import Logic.
Require Import List.
Require Import helper.
Require Import Arith.

Inductive vector (A : Type) : nat -> Type :=
  |insert : forall (n : nat), A -> vector A n -> vector A (S n)
  |empty : vector A 0.

Definition case0 {A} (P: vector A 0 -> Type) (H:P (empty A)) v:P v :=
match v with
  |empty _ => H
  |_ => fun devil => False_ind (@IDProp) devil
end.

Definition rect (A : Type) (P:forall {n}, vector A (S n) -> Type)
 (bas: forall (a : A), P (insert a (empty _)))
 (rect: forall a {n} (v: vector A (S n)) , P v -> P (insert a v)) :
   forall {n} (v: vector A (S n)), P v.
 refine (fix rectS_fix {n} (v: vector A (S n)) {struct v} : P _ v :=
 match v in (vector _ (S n)) return P _ v with
 |@insert _ 0 a v' =>
   (match v' in vector _ 0 with
     |@empty _ => bas a
     |@insert _ l _ _ => _
   end)
 |@insert _ (S nn') a v1 => _
 |_ => fun devil => False_ind (@IDProp) devil
 end).

exact idProp.
exact (rect a _ v1 (rectS_fix _ v1)).
Defined.

Compute _leb.

Ltac unfold_to_leb_definition := unfold ">" in *; unfold "<" in *.

Definition rect_leb (A : Type) (P:forall {n} {y}, vector A (S n) -> y < S n -> Type)
 (out_of_gas: forall a {n} (H : 0 < (S (S n))) (v: vector A (S n)), P (insert a v) H)
 (min_length : forall a (H : 0 < 1) (v: vector A 0), P (insert a v) H)
 (rect: forall a {n} {y} (H : S y < (S (S n))) (v: vector A (S n)), P v (_leb' H) -> P (insert a v) H) :
   forall {n} {y} (H : y < S n) (v: vector A (S n)), P v H.
 refine (fix rectS_fix {n} {y} (H : y < S n) (v: vector A (S n)) {struct v} : P _ _ v H :=
 (match v in vector _ (S n) return (forall (H : y < S n),  P n _ v H) with
 |@insert _ 0 a v' =>
   (match v' in vector _ 0 with
     |@empty _ => _
     |@insert _ l _ _ => _
   end)
 |@insert _ (S nn') a v1 => _
 |_ => fun devil => False_ind (@IDProp) devil
 end) _).

exact idProp.
intros.
destruct y.
(*that's the fun case*)
refine (min_length a H0 (empty A)).
  have : ~ S _ < 1.
    case.
    move => // h.
    unfold_to_leb_definition; apply le_not_lt in h.
    assert (2 <= 2).
    auto with arith.
    tauto.
    cbv; intros.
    apply le_S_n in H1; apply le_not_lt in H1.
    assert(0 < S (S n1)).
    auto with arith.
    auto.
intros; destruct (x _ H0).
intros; destruct y.
refine (out_of_gas a _ H0 v1).
  have : y < S nn'.
  auto with arith.
move => H1.
refine (rect a _ _ H0 v1 (rectS_fix _ _ (_leb' H0) v1)).
Defined.

Definition vector_ind_with_leb : forall (A : Type) (P : forall n y: nat, y <= n -> vector A n -> Prop),
       (forall (n : nat) (y : nat) (H : S y <= S n) (a : A) (v : vector A n),
        P n y (le_S_n _ _ H) v -> P (S n) (S y) H (insert a v)) ->
       (forall (n : nat) (H : 0 <= S n) (a : A) (v : vector A n),
         P (S n) 0 H (insert a v)) ->
        (forall (H : 0 <= 0), P 0 0 H (empty A)) -> forall (n : nat) (y : nat) (Heq : y <= n) (v : vector A n), P n y Heq v.

have : forall n, 0 <= S n -> 0 <= n.
auto with arith.

move => P' A P H K K'.
refine ( fix Ffix (x : nat) (y : nat) (Heq : y <= x) (x0 : vector _ x) {struct x0} :
       P x y Heq x0 := _).

destruct x0.
destruct y.

refine (K n Heq a _).
refine (H n _ Heq a _ (Ffix _ y _ x0)).
destruct y.
refine (K' Heq).
inversion Heq.
Show Proof.
Defined.

Example vectorBiggerThan1Empty : forall {A} {y : nat} {n : nat}
   (h : vector A (S n)),
  ~ let len x := match x with
     |insert _ _ => true
     |_ => false
  end = false in len h.
intros;elim/rect : h.
intros;simpl;move => H1;inversion H1.
intros;simpl in *;auto.
Qed.

Fixpoint cut' {A}{n}{y} (x : vector A (S n)) (len : y < S n) : vector A y.
  elim/rect_leb : x/len.
  intros;exact (empty _).
  intros;exact (empty _).
  intros;refine (insert a (cut' _ _ _ v (_leb' H))).
  Show Proof.
Defined.

(*cut a n+1 position vector*)
Fixpoint cut_list {A}{n}{y} (x : vector A (S n)) (len : y < S n) : list A.
  elim/rect_leb : x/len.
  intros.
  exact nil.
  intros;exact nil.
  intros;refine (cons a (cut_list _ _ _ v (_leb' H))).
  Show Proof.
Defined.

Fixpoint drop {A}{n}{y} (x : vector A (S n)) (len : y < S n) : vector A ((S n) - y).
  elim/rect_leb : x/len.
  intros.
  simpl.
  exact (insert a v).
  intros.
  exact (insert a (empty _)).
  intros.
  set (drop _ _ _ v (_leb' H)).
  rewrite (succ_eq_pred _ _).
  exact v0.
  Show Proof.
Defined.

Fixpoint to_list a n (x : vector a n) : list a :=
  match x with
    | insert x x0 => cons x (to_list x0)
    | empty _ => nil
  end.

Fixpoint drop_list {A}{n}{y} (x : vector A (S n)) (len : y < S n) : list A.
  elim/rect_leb : x/len.
  intros.
  simpl.
  exact (to_list v).
  intros.
  exact nil.
  intros.
  set (drop_list _ _ _ v (_leb' H)).
  exact l.
  Show Proof.
Defined.

Fixpoint set_value' {A}{n} (x : vector A (S n)) (u : nat) (v' : A) {struct x} : u < S n -> vector A (S n).
move => c'.
elim/rect_leb : x/c'.
intros.
refine (insert v' v).
intros.
refine (insert v' v).
intros.
refine (insert a (set_value' _ _ v _ v' (_leb' H))).
Defined.

Fixpoint get_value' {A}{n} (x : vector A (S n)) (u : nat) : u < S n -> A.
move => c'.
elim/rect_leb : x/c'.
intros; refine a.
intros; refine a.
intros; refine (get_value' _ _ v _ (_leb' H)).
Defined.

Fixpoint set_value {A}{n} (x : vector A n) (u : nat) (v' : A) {struct x} : vector A n :=
  match x with
    |insert a x => (if Nat.eqb n u then
      insert v' (set_value x u v') else insert a (set_value x u v'))
     |empty _ => empty A
 end.

Fixpoint get_value {A}{n} (x : vector A n) (u : nat) {struct x} : option A :=
  match x with
    |insert a x => (if Nat.eqb n u then
      Some a else (get_value x u))
     |empty _ => None
 end.

(*the induction scheme can lost some information, a "remember" tatic should solve this problem just use the induction before and pull over the arguments to intro*)

Ltac strong_memorization k name := let H := fresh "HeqIden" in remember k as Iden; move : H; rename Iden into name.

Fixpoint length {A}{n} (x : vector A n) :=
   match x with
     |insert _ x => S (length x)
     |empty _ => 0
   end.

Theorem sized_length_equal_length : forall {A} {n} (x : vector A n), length x = n.
move => A n; elim.
move => n0 a v H /=; rewrite H; move => //.
done.
Qed.

Fixpoint update_vector_correctly {A} n y v (x : vector A (S n)) (H : y < S n) : get_value' (set_value' x v H) H = v.
  intros.
  elim/rect_leb : x/H.
  intros; simpl in *; trivial.
  intros; elim/(@case0) : v0; simpl in *; trivial.
  intros; simpl; unfold ssr_have; trivial.
Qed.

Definition head : forall (A : Type) (n : nat) (x : vector A (S n)), A.
  intros.
  elim/rect : x.
  intros; exact a.
  intros; exact a.
  Show Proof.
Defined.

Definition head' :=
(fun (A : Type) (n : nat) (x : vector A (S n)) =>
 (fun
    (h : forall a : A,
                (fun (n0 : nat) (_ : vector A (S n0)) => A) 0
                  (insert a (empty A))) => rect h (fun a n0 (_ : vector A (S n0)) (_ : A) => a) x) id).

Fixpoint last (A : Type) (n : nat) (x : vector A (S n)) {struct x} : A.
elim/rect : x.
intros; exact a.
intros;refine (last _ _ v).
Defined.

Theorem conservation_last : forall A n (v : vector A (S n)) a, last v = last (insert a v).
intros.
elim/rect : v.
intros; simpl in *; trivial.
intros;simpl in *;trivial.
Defined.

Definition tail : forall (A : Type) (n : nat) (x : vector A (S n)), vector A n.
 intros.
 refine (match x in (vector _ n) with
           |insert x y => _
           |empty _ => _
         end).
  exact y.
  apply idProp.
  Defined.

Fixpoint take {A}{n}{y} (x : vector A (S n)) (len : y < S n) : vector A (S y).
  elim/rect_leb : x/len.
  intros;exact (insert a (empty _)).
  intros;exact (insert a (empty _)).
  intros;refine (insert a (take _ _ _ v (_leb' H))).
  Show Proof.
Defined.
(*the behavouir of take is different of cut, the "cut" of take remains the nth
  element found, take [1, 2, 3] of 1 returns [1, 2] in other hand cut using the
  same paremeters returns [1]*, besides that take always returns a non-empty vector
  and cut not) *)

Theorem head_is_a_cut {A} n y (x : vector A (S n)) (H : y < S n) : get_value' x H = last (take x H).
  intros.
  elim/rect_leb : x/H.
  intros; simpl in *; trivial.
  intros; elim/@case0 : v; trivial.
  intros; simpl in *;unfold ssr_have.
  assumption.
Qed.

Fixpoint concat {A} n n' (x : vector A n) (y : vector A n') {struct x}: vector A (n + n').
induction x.
refine (insert a (concat _ _ _ x y)).
exact y.
Show Proof.
Defined.

Lemma identy_length_vec : forall A n, vector A (n + 0) -> vector A n.
intros.
rewrite (symmetry_nat _) in X.
rewrite (plus_O_n _) in X.
exact X.
Defined.

Lemma identy_length_vec_inv : forall A n, vector A n -> vector A (n + 0).
intros.
rewrite (symmetry_nat _).
simpl.
exact X.
Defined.

Theorem length_identy_concat : forall A n (x : vector A n) (y : vector A 0),
   length (concat x y) = n.
intros.
induction x.
simpl in *;auto with arith.
elim/@case0 : y;trivial.
Qed.

Definition size := List.length.

Theorem length_to_list : forall a n (x : vector a n), size (to_list x) = n.
  intros.
  induction x.
  simpl; auto with arith.
  auto with arith.
Qed.

Definition caseS' {A} {n : nat} (v : vector A (S n)) : forall (P : vector A (S n) -> Type)
  (H : forall h t, P (insert h t)), P v :=
  match v with
  | insert h t => fun P H => H h t
  | _ => fun devil => False_rect (@IDProp) devil
  end.

Definition vector_2ind {A B} (P:forall {n}, vector A n -> vector B n -> Type)
  (bas : P (empty _) (empty _)) (rect : forall {n v2} {v1 : vector A n} , P v1 v2 ->
    forall a b, P (insert a v1) (insert b v2)) : forall {n} (v1 : vector A n), forall v2 : vector B n, P v1 v2.

  refine (fix rect2_fix {n} (v1 : vector A n) {struct v1}: forall v2 : vector B n, P n v1 v2 :=
  match v1 with
  | empty _ => fun v2 => case0 bas v2
  | @insert  _ h1 n' t1 => fun v2 => _
  end).

elim/@caseS' : v2.
intros.
refine (rect h1 t t1 (rect2_fix h1 t1 t) n' h).
Defined.

Theorem _vec_to_list : forall a n (x : vector a n) (y : vector a n),
  (to_list x) = (to_list y) -> x = y.
  move => a n x y.
  elim/@vector_2ind : x/y.
  trivial.
  intros.
  simpl in *;injection H0.
  move => I c.
  apply H in I;rewrite I;rewrite c.
  trivial.
Qed.

Theorem injection_vec_to_list' : forall a n (x : vector a n) (y : vector a n),
  x = y -> (to_list x) = (to_list y).
  intros; move : H.
  elim/@vector_2ind : x/y.
  trivial.
  intros;rewrite H0;trivial.
Qed.

Definition ind2_vector (A : Type) (P:forall {n} {m}, vector A n -> vector A m -> Type)
(*induction for two vectors that non-necessarily have the same length
  you should notice that this induction doesn't fit well for all cases of
  theorems of double vectors, because it's always halts in the cases :
     (empty, empty)
     (insert _ _, empty) or
     (empty _, insert _ _)
  this should be okay for a comparasion proof for example, but not proofs that still perfoming recursion in thouse cases *)

 (bas0: P (empty _) (empty _))
 (cons2 : forall n m (x : vector A n) (y : vector A m) a a', P x y ->
    P (insert a x) (insert a' y))
 (cons' : forall n (x : vector A n) a, P (insert a x) (empty _))
 (cons'1 : forall n (y : vector A n) a, P (empty _) (insert a y)) :
    forall {n} (v: vector A n) {m} (v' : vector A m), P v v'.
 refine (fix v_fix {n} (v: vector A n) {struct v} : forall {m}
  (v' : vector A m), P _ _ v v' := _).
destruct v.
intros.
destruct v'.
refine (cons2 _ _  v v' a a0 (v_fix _ v _ v')).
refine (cons' _ v a).
intros.
destruct v'.
refine (cons'1 _ v' a).
refine bas0.
Defined.

Theorem injection_len_to_list : forall a n n' (x : vector a n) (y : vector a n'),
  (to_list x) = (to_list y) -> n = n'.
  move => a n n' x y.
  elim/ind2_vector : x/y.
  trivial.
  intros; simpl in *. injection H0; move => I'; set (H I').
  auto with arith.
  intros; inversion H.
  intros; inversion H.
Qed.

Theorem take_always_returns_non_empty_vector :
   forall {A} n y (x : vector A (S n)) (x' : vector A 0) (H : y < S n), ~  to_list (take x H) = to_list x'.
move => a n y x; elim/@case0.
move : x; elim/rect.
move => a0 H.
move => H'.
set (injection_len_to_list H').
inversion e.
move => a0 n0 v H K' vec_absurd.
set (injection_len_to_list vec_absurd).
inversion e.
Qed.

Theorem head_is_take2 : forall a n (I : 0 < S n) (x : vector a (S n)),
  head x = head (take x I).
intros.
elim/rect_leb : x/I.
trivial.
intros; elim/@case0 : v; trivial.
intros; trivial.
Qed.

Theorem empty_vec_identy_concat : forall A n (x : vector A n) (y : vector A 0),
   concat y x = x.
move => A n x y.
elim/@case0 : y.
simpl in *.
trivial.
Qed.

Theorem empty_vec_identy_concat' : forall A n (x : vector A n) (y : vector A 0),
   to_list (concat x y) = to_list x.
move => A n x y.
elim/@case0 : y.
induction x.
simpl in *.
rewrite IHx; trivial.
trivial.
Qed.

Theorem pred_injectivity : forall A (a : A)
   n (v : vector A n) v' a', insert a v = insert a' v' -> v = v' \/ a = a'.

intros.
(*god wish that injection H will given a simply a = a' -> v = v', but
  it returns a sigma type :( so, this way is the more easy to prove injectiviy of vectors*)

pose (let get_v A n (v' : vector A (S n)) :=
   match v' in (vector _ (S n)) return (vector _ n) with
     |insert a v => v
   end in get_v A n).

constructor.

apply (@eq_rect _ (insert a v) (fun x => v = (v0 x)) eq_refl (insert a' v') H).
Qed.

Export ListNotations.

Theorem cut_drop_vec' : forall a n y (v : vector a (S n)) (I : y < S n), to_list v =
    (cut_list v I) ++ [(get_value' v I)] ++ (drop_list v I)  .

intros.
elim/rect_leb : v/I.
simpl; trivial.
intros.
elim/@case0 : v.
simpl; trivial.
intros;simpl in *; unfold ssr_have; rewrite H0; trivial.
Qed.

Theorem cut_drop_set_vec' : forall a n y x (v : vector a (S n)) (I : y < S n), to_list (set_value' v x I) =
    (cut_list v I) ++ [x] ++ (drop_list v I)  .

intros.
replace [x] with [(get_value' (set_value' v x I) I)].

elim/rect_leb : v/I.
intros;simpl; trivial.
intros.
elim/@case0 : v; simpl; trivial.
intros;simpl in *; unfold ssr_have; rewrite H0; trivial.
set (@update_vector_correctly a _ _ x v I).
symmetry in e.
rewrite <- e.
trivial.
Qed.

Fixpoint to_vector {A} (x : list A) {struct x} : vector A (size x).
induction x.
refine (empty _).
refine (insert a (to_vector _ x)).
Defined.

Theorem to_list_vector : forall a n (v : vector a n) (P : forall n, vector a n -> Prop),
 to_list (to_vector (to_list v)) = to_list v.

intros.
induction n.
elim/@case0 : v.
trivial.
  have : forall v, to_list (to_vector (to_list v)) = to_list v.
  intros.
  induction v0.
  simpl.
  rewrite IHv0; trivial.
  trivial.
move => H'.
rewrite H'.
apply : eq_refl.
Qed.

(*Theorem to_list_holds : forall a n m v (x : vector a n) (y : vector a m) (P : forall n, vector a n -> Prop),
 (P _ x -> P _ y) -> P _ (insert v x) -> P _ (insert v' x).
*)

Theorem to_list_holds : forall a n m (x : vector a n) (y : vector a m) (P : forall n, vector a n -> Prop),
 to_list x = to_list y -> P _ (to_vector (to_list x)) -> P _ (to_vector (to_list y)).

intros.
move : H H0.
elim/@ind2_vector : x/y.
trivial.
intros.
injection H0.
intros.
set (H H2).
simpl in *.
rewrite <- H2.
rewrite <- H3.
assumption.

intros.
inversion H.
intros.
inversion H.
Show Proof.
Qed.

Fixpoint fold n a b (x : vector a (S n)) (f : a -> b -> b) (i : b) {struct x} : b.
elim/@rect : x.
intros.
apply (f a0 i).
intros.
apply (f a0 (fold _ _ _ v f i)).
Qed.

Theorem to_list_holds2 : forall a ls (x : vector a (size ls))
  (P : forall n, vector a n -> Prop), ls = to_list x -> P _ (to_vector ls)  -> P _ x.
Admitted.


Require Import GraphBasics.Graphs.
Require Import GraphBasics.Trees.
Require Import Coq.Logic.Classical_Prop.

Load Bipartition_related.
Require Export Coq.Bool.BoolEq.

Section Checker.

Definition nldlist := list (Component * Component * nat).

(*CA_list: all arcs of a Connected-graph*)
Fixpoint CA_list (v : V_set) (a : A_set) (c : Connected v a) {struct c} : A_list :=
  match c with
  | C_isolated x => A_nil
  | C_leaf v' a' c' x y _ _ => A_ends x y :: A_ends y x :: CA_list v' a' c'
  | C_edge v' a' c' x y _ _ _ _ _ => A_ends x y :: A_ends y x :: CA_list v' a' c'
  | C_eq v' _ a' _ _ _ c' => CA_list v' a' c'
  end.

Fixpoint is_not_in (x : Component) (l : nldlist) : Prop :=
  match l with
  | nil => True
  | (y,z,n) :: tl => if V_eq_dec x y then False else is_not_in x tl
  end.

Fixpoint is_in_once (x : Component) (l : nldlist) : Prop :=
  match l with
  | nil => False
  | (y,z,n) :: tl => if V_eq_dec x y then is_not_in x tl else is_in_once x tl
  end.

Fixpoint get_distance_in_list (x : Component) (l : nldlist) : nat :=
  match l with
  | nil => 0
  | (y,z,n) :: tl => if V_eq_dec x y then n else get_distance_in_list x tl
  end.

Fixpoint get_leader_in_list (x : Component) (l : nldlist) : Component :=
  match l with
  | nil => x
  | (y,z,n) :: tl => if V_eq_dec x y then z else get_leader_in_list x tl
  end.

Fixpoint leader_same (x : Component) (l : nldlist) : bool :=
  match l with
  | nil => true
  | (c1, c2, n) :: tl => if (V_eq_dec x c2) then leader_same x tl else false
  end.

Definition is_same (x : Component) (other : Component) : bool :=
  if V_eq_dec x other then true else false.

Fixpoint is_in (x : Component) (l : list Component) : bool :=
  match l with
  | nil => false
  | y :: tl => if V_eq_dec x y then true else is_in x tl
  end.

Definition Checker_tree (x : Component) (neigh_list : list Component) (leader parent : Component) (distance : nat) (nld : nldlist) : bool :=
  leader_same leader nld &&
  ((is_same x leader && is_same x parent && (distance =? 0)) ||
   (negb (is_same x leader) && (is_in parent neigh_list) &&
    Nat.eqb distance (get_distance_in_list parent nld + 1))).

Fixpoint Checker_local_bipartition (d : nat) (nld : nldlist) : bool :=
  match nld with
  | nil => true
  | (c1, c2, n) :: tl => if (eqb (Nat.odd d) (Nat.odd n)) then false else Checker_local_bipartition d tl
  end.

Fixpoint is_not_in_b (x : Component) (l : nldlist) : bool :=
  match l with
  | nil => true
  | (y,z,n) :: tl => if V_eq_dec x y then false else is_not_in_b x tl
  end.

Fixpoint is_in_once_b (x : Component) (l : nldlist) : bool :=
  match l with
  | nil => false
  | (y,z,n) :: tl => if V_eq_dec x y then is_not_in_b x tl else is_in_once_b x tl
  end.

Fixpoint NoDup_b (l: nldlist) : bool :=
  match l with
  | nil => true
  | (a, b, c) :: tl => is_in_once_b a l && NoDup_b tl
  end.

Fixpoint each_neighbor_is_in_nld (neigh_list : list Component) (nld : nldlist) : bool :=
  match neigh_list with
  | nil => true
  | a :: tl => is_in_once_b a nld && each_neighbor_is_in_nld tl nld
  end.

Fixpoint each_nld_is_in_neighbor (neigh_list : list Component) (nld : nldlist) : bool :=
  match nld with
  | nil => true
  | (a,b,c) :: tl => is_in a neigh_list && each_nld_is_in_neighbor neigh_list tl
  end.

Definition Checker_local_output_consistent (neigh_list : list Component) (nld : nldlist) : bool :=
  NoDup_b nld &&
  each_neighbor_is_in_nld neigh_list nld &&
  each_nld_is_in_neighbor neigh_list nld.

Definition Local_checker (x : Component) (neigh_list : list Component) (leader parent : Component) (distance : nat) (nld : nldlist) (local_bipartite global_output_consistent: bool): bool :=
  eqb (Checker_local_bipartition distance nld) local_bipartite &&
  Checker_local_output_consistent neigh_list nld &&
  Checker_tree x neigh_list leader parent distance nld &&
  global_output_consistent.

End Checker.

Require Extraction.
Extraction Language Haskell.
(*Extraction Language Scheme.*)
(*Extraction Language Ocaml.*)
Extraction "Local_checker" Local_checker.


(*==========================================================
============================================================
                 TOPOLOGICAL FMAPS, HMAPS -

                 WITH TAGS AND EMBEDDINGS

                          PART 4:

               MAPS, OPERATIONS, PROPERTIES / B, L_B...

COMPLETE: OK!
============================================================
==========================================================*)

Require Export Jordan3.

(*==========================================================
                   expf_B : expf on B
===========================================================*)

(* OK: *)

Lemma inv_hmap_L_B:forall (m:fmap)(k:dim)(x:dart),
 inv_hmap m -> succ m k x ->
   inv_hmap (L (B m k x) k x (A m k x)).
Proof.
intros.
simpl in |- *.
unfold prec_L in |- *.
split.
 generalize (inv_hmap_B m k x).
   tauto.
 split.
  generalize (exd_B m k x x).
    generalize (succ_exd m k x).
    tauto.
  split.
   generalize (exd_B m k x (A m k x)).
     generalize (succ_exd_A m k x).
     tauto.
   split.
    unfold succ in |- *.
      rewrite A_B.
     tauto.
     tauto.
    split.
     unfold pred in |- *.
       rewrite A_1_B.
      tauto.
      tauto.
     unfold succ in H0.
       rewrite cA_B.
      elim (eq_dart_dec x x).
       intro.
   apply succ_bottom.
        tauto.
        unfold succ in |- *.
          tauto.
       tauto.
      tauto.
      unfold succ in |- *.
       tauto.
Qed.

(* OK: *)

Lemma exd_L_B:forall (m:fmap)(k:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     exd (L (B m k x) k x y) z <-> exd m z.
Proof.
simpl in |- *.
intros.
generalize (exd_B m k x z).
tauto.
Qed.

(* OK: *)

Lemma A_L_B:forall (m:fmap)(k j:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     A (L (B m k x) k x y) j z = A m j z.
Proof.
induction m.
 simpl in |- *.
   intros.
   unfold succ in H0.
   simpl in H0.
   tauto.
 simpl in |- *.
   unfold prec_I in |- *.
   unfold succ in |- *.
   intros.
   elim (eq_dim_dec k j).
  elim (eq_dart_dec x z).
   intro.
     rewrite a.
     intro.
     rewrite a0.
     tauto.
   intros.
     rewrite a.
     rewrite A_B_bis.
    tauto.
    intro.
      symmetry  in H1.
      tauto.
  intro.
    rewrite A_B_ter.
   tauto.
   tauto.
 simpl in |- *.
   unfold prec_L in |- *.
   unfold succ in |- *.
   unfold pred in |- *.
   intros.
   elim (eq_dim_dec k j).
  elim (eq_dim_dec d k).
   intros.
     rewrite a.
     rewrite a0.
     elim (eq_dim_dec j j).
    intro.
      elim (eq_dart_dec x z).
     intro.
       rewrite a2.
       tauto.
     elim (eq_dart_dec d0 x).
      elim (eq_dart_dec d0 z).
       intros.
         rewrite a3 in a2.
         tauto.
       tauto.
      simpl in |- *.
        elim (eq_dim_dec j j).
       intros.
         rewrite A_B_bis.
        tauto.
        intro.
          symmetry  in H1.
          tauto.
       tauto.
    tauto.
   simpl in |- *.
     elim (eq_dart_dec x z).
    intros.
      rewrite <- a0.
      elim (eq_dim_dec d k).
     tauto.
     rewrite a.
       tauto.
    intros.
      rewrite <- a.
      rewrite A_B_bis.
     tauto.
     intro.
       symmetry  in H1.
       tauto.
  elim (eq_dim_dec d k).
   elim (eq_dim_dec d j).
    intros.
      rewrite a0 in a.
      tauto.
    elim (eq_dart_dec d0 x).
     tauto.
     simpl in |- *.
       elim (eq_dim_dec d j).
      tauto.
      intros.
        rewrite A_B_ter.
       tauto.
       tauto.
   simpl in |- *.
     intros.
     rewrite A_B_ter.
    tauto.
    tauto.
Qed.

(* IDEM: *)

Lemma A_1_L_B:forall (m:fmap)(k j:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     A_1 (L (B m k x) k x y) j z = A_1 m j z.
Proof.
induction m.
 simpl in |- *.
   intros.
   unfold succ in H0.
   simpl in H0.
    tauto.
simpl in |- *.
  unfold prec_I in |- *.
  unfold succ in |- *.
  intros.
  elim (eq_dim_dec k j).
 elim (eq_dart_dec (A m k x) z).
  intro.
    rewrite <- a in |- *.
    intro.
    rewrite <- a0 in |- *.
    rewrite A_1_A in |- *.
   auto.
   tauto.
  simpl in H0; unfold succ in |- *.
     tauto.
 intros.
   simpl in H0.
   rewrite <- a in |- *.
   rewrite A_1_B_bis in |- *.
  auto.
 auto.
    tauto.
 intro.
   symmetry  in H1.
    tauto.
simpl in H0.
  intro.
  rewrite A_1_B_ter in |- *.
  tauto.
 tauto.
simpl in |- *.
  unfold prec_L in |- *.
  unfold succ in |- *.
  unfold pred in |- *.
  intros.
  simpl in H0.
  generalize H0.
  clear H0.
  elim (eq_dim_dec k j).
 elim (eq_dim_dec d k).
  intros a b.
    rewrite a in |- *.
    rewrite <- b in |- *.
    rewrite a in H.
    elim (eq_dart_dec d0 x).
   elim (eq_dart_dec d1 z).
    elim (eq_dim_dec k k).
     symmetry  in |- *.
        tauto.
     tauto.
   elim (eq_dim_dec k k).
     tauto.
    tauto.
  elim (eq_dart_dec (A m k x) z).
   elim (eq_dim_dec k k).
    elim (eq_dart_dec d1 z).
     intros.
       rewrite <- a0 in a2.
       rewrite <- a2 in H.
       rewrite A_1_A in H.
       absurd (x <> nil).
        tauto.
      apply exd_not_nil with m.
        tauto.
      apply succ_exd with k.
        tauto.
      unfold succ in |- *.
         tauto.
      tauto.
     unfold succ in |- *.
        tauto.
    intros.
      rewrite <- a1 in |- *.
      rewrite A_1_A in |- *.
      tauto.
     tauto.
    unfold succ in |- *.
       tauto.
    tauto.
  simpl in |- *.
    elim (eq_dim_dec k k).
   elim (eq_dart_dec d1 z).
     tauto.
   intros.
     rewrite A_1_B_bis in |- *.
     tauto.
    tauto.
   intro.
     symmetry  in H1.
      tauto.
   tauto.
 elim (eq_dart_dec (A m k x) z).
  elim (eq_dim_dec d j).
   elim (eq_dart_dec d1 z).
    intros.
      rewrite <- a2 in a0.
       tauto.
   intros.
     rewrite <- a1 in |- *.
     rewrite <- a0 in |- *.
     rewrite A_1_A in |- *.
     tauto.
    tauto.
   unfold succ in |- *.
      tauto.
  intros.
    rewrite <- a0 in |- *.
    rewrite <- a in |- *.
    rewrite A_1_A in |- *.
    tauto.
   tauto.
  unfold succ in |- *.
     tauto.
 simpl in |- *.
   intros.
   elim (eq_dim_dec d j).
  intro.
    rewrite <- a in a0.
     tauto.
 intro.
   rewrite <- a in |- *.
   rewrite A_1_B_bis in |- *.
   tauto.
  tauto.
 intro.
   symmetry  in H1.
    tauto.
elim (eq_dim_dec d k).
 elim (eq_dart_dec d0 x).
  elim (eq_dim_dec d j).
   intros.
     rewrite a1 in a.
      tauto.
   tauto.
 simpl in |- *.
   elim (eq_dim_dec d j).
  intros.
    rewrite a0 in a.
     tauto.
 intros.
   rewrite A_1_B_ter in |- *.
   tauto.
  tauto.
simpl in |- *.
  elim (eq_dim_dec d j).
 elim (eq_dart_dec d1 z).
   tauto.
 intros.
   rewrite A_1_B_ter in |- *.
   tauto.
  tauto.
intros.
  rewrite A_1_B_ter in |- *.
  tauto.
 tauto.
Qed.

(* OK: *)

Lemma F_L_B:forall (m:fmap)(k:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     F (L (B m k x) k x y) z = F m z.
Proof.
intros.
unfold F in |- *.
unfold y in |- *.
rewrite A_1_L_B.
 rewrite A_1_L_B.
  tauto.
  tauto.
  tauto.
 tauto.
 tauto.
Qed.

(* OK!! *)

Lemma cA_L_B:forall (m:fmap)(k j:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     cA (L (B m k x) k x y) j z = cA m j z.
Proof.
simpl in |- *.
intros.
elim (eq_dim_dec k j).
 intro.
   elim (eq_dart_dec x z).
  rewrite a.
    intro.
    rewrite a0.
    rewrite a0 in H0.
    generalize (A_cA m j z (A m j z)).
    intros.
    symmetry  in |- *.
    apply H1.
   tauto.
   apply succ_exd with k.
    tauto.
    tauto.
   apply succ_exd_A.
    tauto.
    rewrite <- a.
      tauto.
   tauto.
  intro.
    elim (eq_dart_dec (cA_1 (B m k x) j (A m k x)) z).
   intro.
     rewrite <- a.
     rewrite <- a in a0.
     rewrite cA_1_B in a0.
    generalize a0.
      clear a0.
      elim (eq_dart_dec (A m k x) (A m k x)).
     intros.
       rewrite <- a1.
       rewrite cA_top.
      rewrite cA_B.
       elim (eq_dart_dec x x).
        tauto.
        tauto.
       tauto.
       tauto.
      tauto.
      apply succ_exd with k.
       tauto.
       tauto.
     tauto.
    tauto.
    tauto.
   intro.
     rewrite <- a.
     rewrite cA_B.
    elim (eq_dart_dec x z).
     tauto.
     intro.
       elim (eq_dart_dec (top m k x) z).
      intro.
        rewrite <- a in b0.
        rewrite cA_1_B in b0.
       generalize b0.
         elim (eq_dart_dec (A m k x) (A m k x)).
        tauto.
        tauto.
       tauto.
       tauto.
      tauto.
    tauto.
    tauto.
 intro.
   rewrite cA_B_ter.
  tauto.
  tauto.
  tauto.
Qed.

(* IDEM: *)

Lemma cA_1_L_B:forall(m : fmap)(k j : dim)(x z : dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     cA_1 (L (B m k x) k x y) j z = cA_1 m j z.
Proof.
simpl in |- *.
intros.
elim (eq_dim_dec k j).
 intro.
   elim (eq_dart_dec (A m k x) z).
  rewrite a in |- *.
    intro.
    rewrite <- a0 in |- *.
    assert (cA m j x = A m j x).
   apply A_cA.
     tauto.
   apply succ_exd with k.
     tauto.
    tauto.
   rewrite <- a in |- *.
     apply succ_exd_A.
     tauto.
    tauto.
    tauto.
  rewrite <- H1 in |- *.
    rewrite cA_1_cA in |- *.
    tauto.
   tauto.
  apply succ_exd with k.
    tauto.
   tauto.
 elim (eq_dart_dec (cA (B m k x) j x) z).
  intros.
    rewrite <- a in |- *.
    rewrite cA_1_B in |- *.
   elim (eq_dart_dec (A m k x) (A m k x)).
    intros.
      generalize a0.
      clear a0.
      rewrite <- a in |- *.
      rewrite cA_B in |- *.
     elim (eq_dart_dec x x).
      intros.
        rewrite <- a2 in |- *.
        rewrite cA_1_bottom in |- *.
        tauto.
       tauto.
      apply succ_exd with k.
        tauto.
       tauto.
      tauto.
     tauto.
     tauto.
    tauto.
   tauto.
   tauto.
 intros.
   rewrite <- a in |- *.
   rewrite cA_1_B in |- *.
  elim (eq_dart_dec (A m k x) z).
    tauto.
  elim (eq_dart_dec (bottom m k x) z).
   intros.
     rewrite <- a in b.
     rewrite cA_B in b.
    generalize b.
      elim (eq_dart_dec x x).
      tauto.
     tauto.
    tauto.
   unfold succ in |- *.
     unfold succ in H0.
      tauto.
   tauto.
  tauto.
  tauto.
intro.
  rewrite cA_1_B_ter in |- *.
  tauto.
 tauto.
 tauto.
Qed.

Lemma cF_L_B:forall (m:fmap)(k:dim)(x z:dart),
 inv_hmap m -> succ m k x ->
   let y:= A m k x in
     cF (L (B m k x) k x y) z = cF m z.
Proof.
simpl in |- *.
unfold cF in |- *.
intros.
rewrite cA_1_L_B.
 rewrite cA_1_L_B.
  tauto.
  tauto.
  tauto.
 tauto.
 tauto.
Qed.

(* WITH Iter: *)

Lemma Iter_cF_L_B:
 forall (m:fmap)(k:dim)(x:dart)(i:nat)( z:dart),
  inv_hmap m -> succ m k x ->
   let y:= A m k x in
    Iter (cF (L (B m k x) k x (A m k x))) i z
      =   Iter (cF m) i z.
Proof.
 intros.
induction i.
 simpl in |- *.
   tauto.
 simpl in |- *.
   rewrite IHi.
   rewrite cF_L_B.
  tauto.
  tauto.
tauto.
Qed.

Definition expfo(m:fmap)(x:dart)(z t:dart):=
  expf (L (B m zero x) zero x (A m zero x)) z t.

Lemma expfo_expf:forall(m:fmap)(x:dart)(z t:dart),
  inv_hmap m -> succ m zero x ->
    (expfo m x z t <-> expf m z t).
Proof.
unfold expfo in |- *.
unfold expf in |- *.
unfold MF.expo in |- *.
simpl in |- *.
unfold prec_L in |- *.
unfold succ in |- *.
unfold pred in |- *.
intros.
unfold MF.f in |- *.
unfold McF.f in |- *.
assert (exd m x).
 apply succ_exd with zero.
  tauto.
  unfold succ in |- *.
    tauto.
 split.
  intros.
    decompose [and] H2.
    clear H2.
    split.
   tauto.
   generalize (exd_B m zero x z).
     split.
    tauto.
    elim H11.
      intros i Hi.
      split with i.
      rewrite Iter_cF_L_B in Hi.
     tauto.
     tauto.
     tauto.
  unfold succ in |- *.
    intro.
    decompose [and] H2.
    clear H2.
    split.
   split.
    apply inv_hmap_B.
      tauto.
    split.
     generalize (exd_B m zero x x).
       tauto.
     split.
      generalize (exd_B m zero x (A m zero x)).
        assert (exd m (A m zero x)).
       apply succ_exd_A.
        tauto.
        tauto.
       tauto.
      split.
       rewrite A_B.
        tauto.
        tauto.
       split.
        rewrite A_1_B.
         tauto.
         tauto.
        rewrite cA_B.
         elim (eq_dart_dec x x).
          intro.
            apply succ_bottom.
           tauto.
           unfold succ in |- *.
             tauto.
          tauto.
         tauto.
         unfold succ in |- *.
           tauto.
   split.
    generalize (exd_B m zero x z).
      tauto.
    elim H6.
      intros i Hi.
      split with i.
      rewrite Iter_cF_L_B.
     tauto.
     tauto.
     tauto.
Qed.

(*==========================================================
                   eqc_B : eqc on B, L_B
===========================================================*)

(* RECALL:
eqc =
fix eqc (m : fmap) (x y : dart) {struct m} : Prop :=
  match m with
  | V => False
  | I m0 x0 => x = x0 /\ y = x0 \/ eqc m0 x y
  | L m0 _ x0 y0 =>
      eqc m0 x y \/ eqc m0 x x0 /\ eqc m0 y0 y
     \/ eqc m0 x y0 /\ eqc m0 x0 y
  end
*)

(* OK: LONG... *)

Lemma eqc_B_CN: forall(m:fmap)(k:dim)(x z t:dart),
 inv_hmap m -> succ m k x ->
  let xk:= A m k x in
  let m0:= B m k x in
    eqc m z t ->
      (eqc m0 z t \/
       eqc m0 z x /\ eqc m0 xk t \/
       eqc m0 z xk /\ eqc m0 x t).
Proof.
induction m.
 simpl in |- *.
   unfold succ in |- *.
   simpl in |- *.
   tauto.
 rename t into u.
 unfold succ in |- *.
   simpl in |- *.
   intros.
   unfold succ in IHm.
   intros.
   unfold prec_I in H.
   decompose [and] H.
   clear H.
   generalize (IHm k x z t H2 H0).
   intros.
   intuition.
 unfold succ in |- *.
   simpl in |- *.
   unfold prec_L in |- *.
   intros.
   generalize H0.
   clear H0.
   decompose [and] H.
   clear H.
   rename d into j.
   elim (eq_dim_dec j k).
  elim (eq_dart_dec d0 x).
   intros.
     rewrite <- a.
     tauto.
   simpl in |- *.
     intros.
     unfold succ in IHm.
     elim H1.
    intro.
      generalize (IHm k x z t H0 H6 H).
      tauto.
    intro.
      elim H.
     intros.
       decompose [and] H8.
       clear H8.
       clear H1.
       generalize (IHm k x z d0 H0 H6 H9).
       generalize (IHm k x d1 t H0 H6 H10).
       intros.
       elim H1.
      elim H8.
       intros.
         tauto.
       intros.
         elim H11.
        intros.
          clear H11.
          tauto.
        intro.
          clear H11.
          tauto.
      intros.
        elim H11.
       clear H11.
         intro.
         elim H8.
        intro.
          tauto.
        intro.
          elim H12.
         clear H12.
           intro.
           tauto.
         intro.
           clear H12.
           assert (eqc (B m k x) z t).
          apply eqc_trans with (A m k x).
           tauto.
           tauto.
          tauto.
       intro.
         clear H11.
         elim H8.
        intro.
          tauto.
        intro.
          elim H11.
         clear H11.
           intro.
           assert (eqc (B m k x) z t).
          apply eqc_trans with x.
           tauto.
           tauto.
          tauto.
         intro.
           clear H11.
           tauto.
     intro.
       clear H.
       clear H1.
       decompose [and] H8.
       clear H8.
       generalize (IHm k x z d1 H0 H6 H).
       generalize (IHm k x d0 t H0 H6 H1).
       intros.
       elim H8.
      intro.
        elim H9.
       intro.
         tauto.
       intro.
         elim H11.
        clear H11.
          intro.
          tauto.
        clear H11.
          intro.
          tauto.
      intro.
        elim H10.
       clear H10.
         intro.
         elim H9.
        intro.
          tauto.
        intro.
          elim H11.
         clear H11.
           intro.
           tauto.
         clear H11.
           intro.
           assert (eqc (B m k x) z t).
          apply eqc_trans with (A m k x).
           tauto.
           tauto.
          tauto.
       intro.
         clear H10.
         elim H9.
        intro.
          tauto.
        intro.
          elim H10.
         clear H10.
           intro.
           assert (eqc (B m k x) z t).
          apply eqc_trans with x.
           tauto.
           tauto.
          tauto.
         elim H10.
          clear H10.
            intro.
            tauto.
          tauto.
  simpl in |- *.
    intros.
    unfold succ in IHm.
    elim H1.
   intro.
     generalize (IHm k x z t H0 H6 H).
     tauto.
   intro.
     elim H.
    intros.
      decompose [and] H8.
      clear H8.
      clear H1.
      generalize (IHm k x z d0 H0 H6 H9).
      generalize (IHm k x d1 t H0 H6 H10).
      intros.
      elim H1.
     elim H8.
      intros.
        tauto.
      intros.
        elim H11.
       intros.
         clear H11.
         tauto.
       intro.
         clear H11.
         tauto.
     intros.
       elim H11.
      clear H11.
        intro.
        elim H8.
       intro.
         tauto.
       intro.
         elim H12.
        clear H12.
          intro.
          tauto.
        intro.
          clear H12.
          assert (eqc (B m k x) z t).
         apply eqc_trans with (A m k x).
          tauto.
          tauto.
         tauto.
      intro.
        clear H11.
        elim H8.
       intro.
         tauto.
       intro.
         elim H11.
        clear H11.
          intro.
          assert (eqc (B m k x) z t).
         apply eqc_trans with x.
          tauto.
          tauto.
         tauto.
        intro.
          clear H11.
          tauto.
    intro.
      clear H.
      clear H1.
      decompose [and] H8.
      clear H8.
      generalize (IHm k x z d1 H0 H6 H).
      generalize (IHm k x d0 t H0 H6 H1).
      intros.
      elim H8.
     intro.
       elim H9.
      intro.
        tauto.
      intro.
        elim H11.
       clear H11.
         intro.
         tauto.
       clear H11.
         intro.
         tauto.
     intro.
       elim H10.
      clear H10.
        intro.
        elim H9.
       intro.
         tauto.
       intro.
         elim H11.
        clear H11.
          intro.
          tauto.
        clear H11.
          intro.
          assert (eqc (B m k x) z t).
         apply eqc_trans with (A m k x).
          tauto.
          tauto.
         tauto.
      intro.
        clear H10.
        elim H9.
       intro.
         tauto.
       intro.
         elim H10.
        clear H10.
          intro.
          assert (eqc (B m k x) z t).
         apply eqc_trans with x.
          tauto.
          tauto.
         tauto.
        elim H10.
         clear H10.
           intro.
           tauto.
         tauto.
Qed.

(* OK! IDEM *)

Lemma eqc_B_CS: forall(m:fmap)(k:dim)(x z t:dart),
 inv_hmap m -> succ m k x ->
  let xk:= A m k x in
  let m0:= B m k x in
      (eqc m0 z t \/
       eqc m0 z x /\ eqc m0 xk t \/
       eqc m0 z xk /\ eqc m0 x t) ->
    eqc m z t.
Proof.
induction m.
 simpl in |- *.
   unfold succ in |- *.
   simpl in |- *.
   tauto.
  rename t into u.
 unfold succ in |- *.
   simpl in |- *.
   intros.
   unfold prec_I in H.
   decompose [and] H.
   clear H.
   generalize (IHm k x z t H2 H0).
   simpl in |- *.
   intros.
   assert (x <> d).
  intro.
    rewrite <- H3 in H5.
    apply H5.
    apply succ_exd with k.
   tauto.
   tauto.
  assert (A m k x <> d).
   intro.
     rewrite <- H6 in H5.
     elim H5.
     apply succ_exd_A.
    tauto.
    unfold succ in |- *.
      tauto.
   intuition.
 unfold succ in |- *.
   simpl in |- *.
   unfold prec_L in |- *.
   intros k x z t H.
   unfold succ in IHm.
   decompose [and] H.
   clear H.
   rename d into j.
   elim (eq_dim_dec j k).
  elim (eq_dart_dec d0 x).
   intros.
     rewrite a.
     tauto.
   simpl in |- *.
     intros.
     rewrite a in H6.
     elim H5.
    intro.
      elim H7.
     generalize (IHm k x z t H0 H).
       tauto.
     intro.
       elim H8.
      intro.
        generalize (IHm k x z d0 H0 H).
        generalize (IHm k x d1 t H0 H).
        tauto.
      intro.
        clear H8.
        generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
    clear H5.
      intro.
      elim H5.
     clear H5.
       intro.
       decompose [and or] H5.
      clear H5.
        generalize (IHm k x z t H0 H).
        tauto.
      generalize (IHm k x z d0 H0 H).
        generalize (IHm k x d1 t H0 H).
        tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
      generalize (IHm k x z d0 H0 H).
        generalize (IHm k x d1 t H0 H).
        tauto.
      generalize (IHm k x d1 t H0 H).
        generalize (IHm k x z d0 H0 H).
        tauto.
      assert (eqc (B m k x) z t).
       apply eqc_trans with d0.
        tauto.
        tauto.
       generalize (IHm k x z t H0 H).
         tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
      assert (eqc (B m k x) z t).
       apply eqc_trans with d1.
        tauto.
        tauto.
       generalize (IHm k x z t H0 H).
         tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
     intro.
       clear H5.
       intuition.
      generalize (IHm k x z t H0 H).
        tauto.
      generalize (IHm k x z d0 H0 H).
        generalize (IHm k x d1 t H0 H).
        tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
      generalize (IHm k x z d0 H0 H).
        generalize (IHm k x d1 t H0 H).
        tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
      generalize (IHm k x d1 t H0 H).
        generalize (IHm k x z d0 H0 H).
        tauto.
      assert (eqc (B m k x) z t).
       apply eqc_trans with d0.
        tauto.
        tauto.
       generalize (IHm k x z t H0 H).
         tauto.
      assert (eqc (B m k x) z t).
       apply eqc_trans with d1.
        tauto.
        tauto.
       generalize (IHm k x z t H0 H).
         tauto.
      generalize (IHm k x z d1 H0 H).
        generalize (IHm k x d0 t H0 H).
        tauto.
  simpl in |- *.
    intros.
    elim H5.
   intro.
     elim H7.
    generalize (IHm k x z t H0 H).
      tauto.
    intro.
      elim H8.
     intro.
       generalize (IHm k x z d0 H0 H).
       generalize (IHm k x d1 t H0 H).
       tauto.
     intro.
       clear H8.
       generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
   clear H5.
     intro.
     elim H5.
    clear H5.
      intro.
      decompose [and or] H5.
     clear H5.
       generalize (IHm k x z t H0 H).
       tauto.
     generalize (IHm k x z d0 H0 H).
       generalize (IHm k x d1 t H0 H).
       tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
     generalize (IHm k x z d0 H0 H).
       generalize (IHm k x d1 t H0 H).
       tauto.
     generalize (IHm k x d1 t H0 H).
       generalize (IHm k x z d0 H0 H).
       tauto.
     assert (eqc (B m k x) z t).
      apply eqc_trans with d0.
       tauto.
       tauto.
      generalize (IHm k x z t H0 H).
        tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
     assert (eqc (B m k x) z t).
      apply eqc_trans with d1.
       tauto.
       tauto.
      generalize (IHm k x z t H0 H).
        tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
    intro.
      clear H5.
      intuition.
     generalize (IHm k x z t H0 H).
       tauto.
     generalize (IHm k x z d0 H0 H).
       generalize (IHm k x d1 t H0 H).
       tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
     generalize (IHm k x z d0 H0 H).
       generalize (IHm k x d1 t H0 H).
       tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
     generalize (IHm k x d1 t H0 H).
       generalize (IHm k x z d0 H0 H).
       tauto.
     assert (eqc (B m k x) z t).
      apply eqc_trans with d0.
       tauto.
       tauto.
      generalize (IHm k x z t H0 H).
        tauto.
     assert (eqc (B m k x) z t).
      apply eqc_trans with d1.
       tauto.
       tauto.
      generalize (IHm k x z t H0 H).
        tauto.
     generalize (IHm k x z d1 H0 H).
       generalize (IHm k x d0 t H0 H).
       tauto.
Qed.

(* OK: *)

Theorem eqc_B: forall(m:fmap)(k:dim)(x z t:dart),
 inv_hmap m -> succ m k x ->
  let xk:= A m k x in
  let m0:= B m k x in
    (eqc m z t <->
      (eqc m0 z t \/
       eqc m0 z x /\ eqc m0 xk t \/
       eqc m0 z xk /\ eqc m0 x t)).
Proof.
simpl in |- *.
intros.
split.
 apply eqc_B_CN.
  tauto.
  tauto.
 apply eqc_B_CS.
  tauto.
  tauto.
Qed.

(* DEFINITION OF eqco WHICH ALLOWS TO PUT AHEAD
ANY 0-LINK: *)

Definition eqco(m:fmap)(k:dim)(x z t:dart):=
  eqc (L (B m k x) k x (A m k x)) z t.

Lemma eqco_eqc:forall(m:fmap)(k:dim)(x z t:dart),
  inv_hmap m -> succ m k x ->
    (eqco m k x z t <-> eqc m z t).
Proof.
unfold eqco in |- *.
simpl in |- *.
intros.
generalize (eqc_B m k x z t H H0).
simpl in |- *.
tauto.
Qed.

(* OK: *)

Lemma eqc_B_eqc :forall(m:fmap)(k:dim)(x z t:dart),
  inv_hmap m -> succ m k x ->
    eqc (B m k x) z t -> eqc m z t.
Proof.
unfold succ in |- *.
induction m.
 simpl in |- *.
   tauto.
rename t into u.
 simpl in |- *.
   unfold prec_I in |- *.
   intros.
   decompose [and] H.
   clear H.
   elim H1.
  intro.
    tauto.
  intro.
    right.
    apply (IHm k x z t H2 H0 H).
 simpl in |- *.
   unfold prec_L in |- *.
   intros k x z t H.
   decompose [and] H.
   clear H.
   rename d into j.
   elim (eq_dim_dec j k).
  elim (eq_dart_dec d0 x).
   intros.
     tauto.
   simpl in |- *.
     intros.
     intuition.
    left.
      apply (IHm k x z t).
     tauto.
     tauto.
     tauto.
    right.
      left.
      generalize (IHm k x z d0 H0 H).
      generalize (IHm k x d1 t H0 H).
      tauto.
    generalize (IHm k x z d1 H0 H).
      generalize (IHm k x d0 t H0 H).
      tauto.
  simpl in |- *.
    intros.
    generalize (IHm k x z d0 H0 H).
    generalize (IHm k x d1 t H0 H).
    generalize (IHm k x z d1 H0 H).
    generalize (IHm k x d0 t H0 H).
    generalize (IHm k x z t H0 H).
    tauto.
Qed.

(* OK, USEFUL IN nc/B,L: *)

Lemma eqc_eqc_B : forall(m:fmap)(k:dim)(x z t:dart),
  inv_hmap m -> succ m k x ->
     eqc (B m k x) x (A m k x) ->
        eqc m z t -> eqc (B m k x) z t.
Proof.
intros.
generalize (eqc_B_CN m k x z t H H0 H2).
intro.
elim H3.
  tauto.
clear H3.
  intro.
  elim H3.
 clear H3.
   intro.
   apply eqc_trans with x.
   tauto.
 apply eqc_trans with (A m k x).
   tauto.
  tauto.
clear H3.
  intro.
   eapply eqc_trans with (A m k x).
  tauto.
apply eqc_trans with x.
 apply eqc_symm.
    tauto.
 tauto.
Qed.

(*=========================================================
============================================================
                     END OF PART 4
===========================================================
==========================================================*)


(** * Converting between combinatory algebra and lambda-calculus *)

Require Import Coq.Program.Basics.
Require Import Coq.Program.Equality.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Codes.
Require Import Combinators.
Require Export DeBruijn.

Fixpoint compile {Var : Set} (t : Term Var) : Code Var :=
  match t with
  | TOP%term => TOP%code
  | BOT%term => BOT%code
  | x || y => (compile x || compile y)%code
  | x (+) y => (compile x (+) compile y)%code
  | x * y => (compile x * compile y)%code
  | term_var v => code_var v
  | term_lambda x => code_abs id (compile x)
  end.

Inductive compiles_to {Var : Set} : Term Var -> Code Var -> Prop :=
  | compiles_to_top : compiles_to TOP%term TOP%code
  | compiles_to_bot : compiles_to BOT%term BOT%code
  | compiles_to_join x x' y y' :
     compiles_to x x' -> compiles_to y y' ->
     compiles_to (x || y) (x' || y')%code
  | compiles_to_rand x x' y y' :
     compiles_to x x' -> compiles_to y y' ->
     compiles_to (x (+) y) (x' (+) y')%code
  | compiles_to_app x x' y y' :
     compiles_to x x' -> compiles_to y y' ->
     compiles_to (x * y) (x' * y')%code
  | compiles_to_var v : compiles_to (term_var v) (code_var v)
  | compiles_to_lambda x x' :
      @compiles_to (option Var) x x' ->
      compiles_to (term_lambda x) (code_abs id x')
.
Hint Constructors compiles_to.

Section compiles_to_compile.
  Local Ltac compiles_to_compiles :=
    simpl;
    repeat match goal with
    | [ H' : forall c : _, compiles_to ?t c -> compile ?t = c |- _] =>
      match goal with
      | [ H : compiles_to t _ |- _] =>
        apply H' in H; rewrite H; clear H H'; simpl
      end
    end;
    auto.

  Lemma compiles_to_compile (Var : Set) (t : Term Var) (c : Code Var) :
    compiles_to t c <-> compile t = c.
  Proof.
    split.
    - intro H; induction t; inversion H; compiles_to_compiles.
    - intro H; induction t; simpl in H; rewrite <- H; auto.
  Qed.
End compiles_to_compile.

Definition code_protect {Var : Set} : Code Var -> Code (option' Var) :=
  code_sub (fun v : Var => code_var (Some v)).

Definition term_protect {Var : Set} : Term Var -> Term (option' Var) :=
  term_map (@Some Var).

(* TODO this needs to be changed to get [decompile_compile] to hold,
   at least when restricted to Bohm trees. *)
Fixpoint decompile {Var : Set} (c : Code Var) : Term Var :=
  match c with
  | TOP%code => TOP
  | BOT%code => BOT
  | (J * x * y)%code => decompile x || decompile y
  | (R * x * y)%code => decompile x (+) decompile y
  | I => DeBruijn.I
  | (K * x)%code =>
      let x' := term_protect (decompile x) in
      LAMBDA x'
  | (B * x * y)%code =>
      (* should this be [decompile (term_protect x * v)] ? *)
      let x' := term_protect (decompile x) in
      let y' := term_protect (decompile y) in
      let v := VAR None in
      LAMBDA (x' * (y' * v))
  | (C * x * y)%code =>
      let x' := term_protect (decompile x) in
      let y' := term_protect (decompile y) in
      let v := VAR None in
      LAMBDA (x' * v * y')
  | (S * x * y)%code =>
      let x' := term_protect (decompile x) in
      let y' := term_protect (decompile y) in
      let v := VAR None in
      LAMBDA (x' * v * (y' * v))
  | (x * y)%code => (decompile x * decompile y)
  | code_var v => term_var v
  (* these cases never arise as [decompile (compile t)] *)
  | K => DeBruijn.K
  | B => DeBruijn.B
  | C => DeBruijn.C
  | S => DeBruijn.S
  | J => DeBruijn.K || DeBruijn.F
  | R => DeBruijn.K (+) DeBruijn.F
  end.

Inductive decompiles_to {Var : Set} : Code Var -> Term Var -> Prop :=
  | decompiles_to_top : decompiles_to TOP%code TOP
  | decompiles_to_bot : decompiles_to BOT%code BOT
  | decompiles_to_join x x' y y' :
     decompiles_to x x' -> decompiles_to y y' ->
     decompiles_to (J * x * y)%code (x' || y')
  | decompiles_to_rand x x' y y' :
     decompiles_to x x' -> decompiles_to y y' ->
     decompiles_to (R * x * y)%code (x' (+) y')
  | decompiles_to_i : decompiles_to I DeBruijn.I
  | decompiles_to_k1 x x' :
      decompiles_to x x' ->
      let x'' := term_protect x' in
      decompiles_to (K * x)%code (LAMBDA x'')
  | decompiles_to_b2 x x' y y' :
      decompiles_to x x' ->
      decompiles_to y y' ->
      let x'' := term_protect x' in
      let y'' := term_protect y' in
      let v := VAR None in
      decompiles_to (B * x * y)%code (LAMBDA (x'' * (y'' * v)))
  | decompiles_to_c2 x x' y y' :
      decompiles_to x x' ->
      decompiles_to y y' ->
      let x'' := term_protect x' in
      let y'' := term_protect y' in
      let v := VAR None in
      decompiles_to (C * x * y)%code (LAMBDA (x'' * v * y''))
  | decompiles_to_s2 x x' y y' :
      decompiles_to x x' ->
      decompiles_to y y' ->
      let x'' := term_protect x' in
      let y'' := term_protect y' in
      let v := VAR None in
      decompiles_to (S * x * y)%code (LAMBDA (x'' * v * (y'' * v)))
  | decompiles_to_app x x' y y':
      decompiles_to x x' ->
      decompiles_to y y' ->
      decompiles_to (x * y)%code (x' * y')
  | decompiles_to_var v : decompiles_to (code_var v) (term_var v)
  (* these cases never arise as [decompile (compile t)] *)
  | decompiles_to_k : decompiles_to K DeBruijn.K
  | decompiles_to_b : decompiles_to B DeBruijn.B
  | decompiles_to_c : decompiles_to C DeBruijn.C
  | decompiles_to_s : decompiles_to S DeBruijn.S
  | decompiles_to_j : decompiles_to J (DeBruijn.K || DeBruijn.F)
  | decompiles_to_r : decompiles_to R (DeBruijn.K (+) DeBruijn.F)
.
Hint Constructors decompiles_to.

Section decompiles_to_decompile.
  Local Ltac decompiles_to_decompiles :=
    simpl;
    repeat match goal with
    | [ H' : forall c : _, decompiles_to c ?t -> decompile c = ?t |- _] =>
      match goal with
      | [ H : decompiles_to _ t |- _] =>
        apply H' in H; rewrite H; clear H H'; simpl
      end
    end;
    auto.

  Lemma decompiles_to_decompile (Var : Set) (c : Code Var) (t : Term Var) :
    decompiles_to c t <-> decompile c = t.
  Proof.
    split.
    - intro H; induction t; inversion H; decompiles_to_decompiles;
      admit.
    - intro H; dependent induction c;
      try (simpl in H; rewrite <- H; auto; reflexivity).
      admit.
  Qed.
End decompiles_to_decompile.

Lemma compile_app (Var : Set) (x y : Term Var) :
  (compile (x * y) = (compile x) * (compile y))%code.
Proof.
  simpl; reflexivity.
Qed.

Lemma compile_lambda_app (Var : Set) (x : Term (option Var)) (y : Term Var) :
  (compile (lambda_app_sub x y) == code_abs id (compile x) * compile y)%code.
Proof.
  dependent induction x.
  - simpl; code_simpl; reflexivity.
  - simpl; code_simpl; reflexivity.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
Qed.

Section compile_decompile.
  Lemma compile_protect (Var : Set) (t : Term Var) :
    compile (term_protect t) = code_protect (compile t).
  Proof.
    apply compiles_to_compile.
    induction t; try (compute; auto; reflexivity).
    admit.
  Qed.

  Lemma protect_decompile (Var : Set) (c : Code Var) :
    decompile (code_protect c) = term_protect (decompile c).
  Proof.
    apply decompiles_to_decompile.
    admit.
  Qed.

  Lemma code_abs_protect (Var : Set) (c : Code Var) :
    code_abs id (code_protect c) = (K * c)%code.
  Proof.
    induction c; try (simpl; auto; reflexivity).
    admit. (* TODO this should be true *)
  Qed.

  Lemma compile_decompile (Var : Set) (c : Code Var) :
    (compile (decompile c) == c)%code.
  Proof.
    induction c; simpl; auto.
    - case_eq c1; intros; try (simpl; auto; reflexivity).
      + admit.
      + simpl; rewrite IHc2; beta_eta.
      + simpl; rewrite IHc2; beta_eta.
      + simpl; rewrite compile_protect.
        rewrite code_abs_protect.
        monotonicity; assumption.
    - beta_eta.
    - beta_eta.
  Qed.
End compile_decompile.

(* ------------------------------------------------------------------------ *)
(** We can now define convergence and ordering in terms of [compile] *)

Definition term_conv {Var : Set} (t : Term Var) := code_conv (compile t).
Definition term_le {Var : Set} (x y : Term Var) := compile x [= compile y.
Definition term_eq {Var : Set} (x y : Term Var) := compile x == compile y.

Notation "x == y" := (term_eq x y)%term : term_scope.
Notation "x [= y" := (term_le x y)%term : term_scope.
Notation "x :: a" := (term_app a x == x)%term : term_scope.

Lemma compile_conv (Var : Set) (x : Term Var) :
  code_conv (compile x) <-> term_conv x.
Proof.
  unfold term_conv; tauto.
Qed.

Lemma compile_le (Var : Set) (x y : Term Var) :
  (compile x [= compile y)%code <-> x [= y.
Proof.
  unfold term_le; repeat rewrite compile_decompile; tauto.
Qed.

Lemma compile_eq (Var : Set) (x y : Term Var) :
  (compile x == compile y)%code <-> x == y.
Proof.
  unfold term_eq; repeat rewrite compile_decompile; tauto.
Qed.

Lemma decompile_conv (Var : Set) (x : Code Var) :
  term_conv (decompile x) <-> code_conv x.
Proof.
  unfold term_conv; rewrite compile_decompile; tauto.
Qed.

Lemma decompile_le (Var : Set) (x y : Code Var) :
  decompile x [= decompile y <-> (x [= y)%code.
Proof.
  unfold term_le; repeat rewrite compile_decompile; tauto.
Qed.

Lemma decompile_eq (Var : Set) (x y : Code Var) :
  decompile x == decompile y <-> (x == y)%code.
Proof.
  unfold term_eq; repeat rewrite compile_decompile; tauto.
Qed.

Instance term_le_reflexive (Var : Set) : Reflexive (@term_le Var).
Proof.
  simpl_relation; intros; auto.
Qed.

Instance term_le_transitive (Var : Set) : Transitive (@term_le Var).
Proof.
  unfold term_le; intros x y z xy yz; transitivity (compile y); auto.
Qed.

Instance term_eq_reflexive (Var : Set) : Reflexive (@term_eq Var).
Proof.
  simpl_relation; intros; auto.
Qed.

Instance term_eq_transitive (Var : Set) : Transitive (@term_eq Var).
Proof.
  unfold term_eq; intros x y z xy yz; transitivity (compile y); auto.
Qed.

Instance term_eq_symmetric (Var : Set) : Symmetric (@term_eq Var).
Proof.
  unfold term_eq; intros x y xy; symmetry; assumption.
Qed.

Instance term_eq_le_subrelation (Var : Set) :
  subrelation term_eq (@term_le Var).
Proof.
  unfold term_le, term_eq; intros x y [xy yx]; simpl; auto.
Qed.

(* why is this needed? *)
Instance term_le_proper_eq (Var : Set) :
  Proper (term_eq ==> term_eq ==> iff) (@term_le Var).
Proof.
  intros x x' [xx' x'x] y y' [yy' y'y].
  split; intro H; unfold term_le.
  - transitivity (compile x); auto.
    transitivity (compile y); auto.
  - transitivity (compile x'); auto.
    transitivity (compile y'); auto.
Qed.

Instance term_conv_proper_eq (Var : Set) :
  Proper (term_eq ==> iff) (@term_conv Var).
Proof.
  unfold term_conv, term_eq; intros x x' xx'; rewrite xx'; reflexivity.
Qed.

Instance term_conv_proper_le (Var : Set) :
  Proper (term_le ==> impl) (@term_conv Var).
Proof.
  unfold term_conv, term_le, flip, impl; intros x x' xx'; rewrite xx'; tauto.
Qed.

Instance compile_proper_eq (Var : Set) :
  Proper (term_eq ==> code_eq) (@compile Var).
Proof.
  simpl_relation.
Qed.

Instance compile_proper_le (Var : Set) :
  Proper (term_le ==> code_le) (@compile Var).
Proof.
  intros x x' xx'; unfold term_le; assumption.
Qed.

Instance decompile_proper_eq (Var : Set) :
  Proper (code_eq ==> term_eq) (@decompile Var).
Proof.
  intros x x' xx'; unfold term_eq;
  repeat rewrite compile_decompile; assumption.
Qed.

Instance decompile_proper_le (Var : Set) :
  Proper (code_le ==> term_le) (@decompile Var).
Proof.
  intros x x' xx'; unfold term_le;
  repeat rewrite compile_decompile; assumption.
Qed.

Instance term_join_proper_eq (Var : Set) :
  Proper (term_eq ==> term_eq ==> term_eq) (@term_join Var).
Proof.
  intros x x' xx' y y' yy'; transitivity (x' || y);
  unfold term_eq in *; simpl; auto.
Qed.

Instance term_rand_proper_eq (Var : Set) :
  Proper (term_eq ==> term_eq ==> term_eq) (@term_rand Var).
Proof.
  intros x x' xx' y y' yy'; transitivity (x' (+) y);
  unfold term_eq in *; simpl; auto.
Qed.

Instance term_app_proper_eq (Var : Set) :
  Proper (term_eq ==> term_eq ==> term_eq) (@term_app Var).
Proof.
  intros x x' xx' y y' yy'; transitivity (x' * y);
  unfold term_eq in *; simpl; auto.
Qed.

Instance term_lambda_proper_eq (Var : Set) :
  Proper (term_eq ==> term_eq) (@term_lambda Var).
Proof.
  intros x x' xx'; unfold term_eq in *; simpl; rewrite xx'; auto.
Qed.

Instance term_join_proper_le (Var : Set) :
  Proper (term_le ==> term_le ==> term_le) (@term_join Var).
Proof.
  intros x x' xx' y y' yy'; transitivity (x' || y);
  unfold term_le in *; simpl; auto.
Qed.

Instance term_rand_proper_le (Var : Set) :
  Proper (term_le ==> term_le ==> term_le) (@term_rand Var).
Proof.
  intros x x' xx' y y' yy'; transitivity (x' (+) y);
  unfold term_le in *; simpl; auto.
Qed.

Instance term_app_proper_le (Var : Set) :
  Proper (term_le ==> term_le ==> term_le) (@term_app Var).
Proof.
  intros x x' xx' y y' yy'; transitivity (x' * y);
  unfold term_le in *; simpl; auto.
Qed.

Instance term_lambda_proper_le (Var : Set) :
  Proper (term_le ==> term_le) (@term_lambda Var).
Proof.
  intros x x' xx'; unfold term_le in *; simpl; rewrite xx'; auto.
Qed.

(** Some useful lemmas transferred from [Code]. *)

Ltac term_to_code := unfold term_conv, term_le, term_le; simpl; auto.
Tactic Notation "term_to_code" "in" hyp(H) :=
  unfold term_conv, term_le, term_le in H; simpl in H.

Lemma decompile_app (Var : Set) (x y : Code Var) :
  decompile (x * y)%code == (decompile x) * (decompile y).
Proof.
  apply decompile_eq;
  rewrite compile_app;
  repeat rewrite compile_decompile;
  reflexivity.
Qed.

Lemma term_le_join (Var : Set) (x y z : Term Var) :
  x || y [= z <-> x [= z /\ y [= z.
Proof.
  term_to_code.
Qed.

Lemma term_le_join_left (Var : Set) (x y : Term Var) : x [= x || y.
Proof.
  term_to_code.
Qed.

Lemma term_le_join_right (Var : Set) (x y : Term Var) : y [= x || y.
Proof.
  term_to_code.
Qed.


Require Import Ensembles List Coq.Lists.SetoidList Program
        Common Computation.Core
        ADTNotation.BuildADTSig ADTNotation.BuildADT
        GeneralBuildADTRefinements QueryQSSpecs QueryStructure
        SetEq Omega String Arith.

Unset Implicit Arguments.

Ltac generalize_all :=
  repeat match goal with
             [ H : _ |- _ ] => generalize H; clear H
         end.

Section AdditionalDefinitions.
  Open Scope list_scope.

End AdditionalDefinitions.

Section AdditionalNatLemmas.
  Lemma le_r_le_max :
    forall x y z,
      x <= z -> x <= max y z.
  Proof.
    intros x y z;
    destruct (Max.max_spec y z) as [ (comp, eq) | (comp, eq) ];
    rewrite eq;
    omega.
  Qed.

  Lemma le_l_le_max :
    forall x y z,
      x <= y -> x <= max y z.
  Proof.
    intros x y z.
    rewrite Max.max_comm.
    apply le_r_le_max.
  Qed.

  Lemma le_neq_impl :
    forall m n, m < n -> m <> n.
  Proof.
    intros; omega.
  Qed.

  Lemma gt_neq_impl :
    forall m n, m > n -> m <> n.
  Proof.
    intros; omega.
  Qed.

  Lemma lt_refl_False :
    forall x,
      lt x x -> False.
  Proof.
    intros; omega.
  Qed.

  Lemma beq_nat_eq_nat_dec :
    forall x y,
      beq_nat x y = if eq_nat_dec x y then true else false.
  Proof.
    intros; destruct (eq_nat_dec _ _); [ apply beq_nat_true_iff | apply beq_nat_false_iff ]; assumption.
  Qed.
End AdditionalNatLemmas.

Section AdditionalLogicLemmas.
  Lemma or_false :
    forall (P: Prop), P \/ False <-> P.
  Proof.
    tauto.
  Qed.

  Lemma false_or :
    forall (P Q: Prop),
      (False <-> P \/ Q) <-> (False <-> P) /\ (False <-> Q).
  Proof.
    tauto.
  Qed.

  Lemma false_or' :
    forall (P Q: Prop),
      (P \/ Q <-> False) <-> (False <-> P) /\ (False <-> Q).
  Proof.
    tauto.
  Qed.

  Lemma equiv_false :
    forall P,
      (False <-> P) <-> (~ P).
  Proof.
    tauto.
  Qed.

  Lemma equiv_false' :
    forall P,
      (P <-> False) <-> (~ P).
  Proof.
    tauto.
  Qed.

  Lemma and_True :
    forall P,
      (P /\ True) <-> P.
  Proof.
    tauto.
  Qed.

  Lemma not_exists_forall :
    forall {A} (P: A -> Prop),
      (~ (exists a, P a)) <-> (forall a, ~ P a).
  Proof.
    firstorder.
  Qed.

  Lemma not_and_implication :
    forall (P Q: Prop),
      ( ~ (P /\ Q) ) <-> (P -> ~ Q).
  Proof.
    firstorder.
  Qed.

  Lemma eq_sym_iff :
    forall {A} x y, @eq A x y <-> @eq A y x.
  Proof.
    split; intros; symmetry; assumption.
  Qed.
End AdditionalLogicLemmas.

Section AdditionalBoolLemmas.
  Lemma collapse_ifs_dec :
    forall P (b: {P} + {~P}),
      (if (if b then true else false) then true else false) =
      (if b then true else false).
  Proof.
    destruct b; reflexivity.
  Qed.

  Lemma collapse_ifs_bool :
    forall (b: bool),
      (if (if b then true else false) then true else false) =
      (if b then true else false).
  Proof.
    destruct b; reflexivity.
  Qed.

  Lemma string_dec_bool_true_iff :
    forall s1 s2,
      (if string_dec s1 s2 then true else false) = true <-> s1 = s2.
  Proof.
    intros s1 s2; destruct (string_dec s1 s2); simpl; intuition.
  Qed.

  Lemma eq_nat_dec_bool_true_iff :
    forall n1 n2,
      (if eq_nat_dec n1 n2 then true else false) = true <-> n1 = n2.
  Proof.
    intros n1 n2; destruct (eq_nat_dec n1 n2); simpl; intuition.
  Qed.

  Lemma eq_N_dec_bool_true_iff :
    forall n1 n2 : N, (if N.eq_dec n1 n2 then true else false) = true <-> n1 = n2.
  Proof.
    intros; destruct (N.eq_dec _ _); intuition.
  Qed.

  Lemma eq_Z_dec_bool_true_iff :
    forall n1 n2 : Z, (if Z.eq_dec n1 n2 then true else false) = true <-> n1 = n2.
  Proof.
    intros; destruct (Z.eq_dec _ _); intuition.
  Qed.

  Lemma bool_equiv_true:
    forall (f g: bool),
      (f = true <-> g = true) <-> (f = g).
  Proof.
    intros f g; destruct f, g; intuition.
  Qed.

  Lemma if_negb :
    forall {A} (b: bool) (x y: A), (if negb b then x else y) = (if b then y else x).
  Proof.
    intros; destruct b; simpl; reflexivity.
  Qed.
End AdditionalBoolLemmas.

Section AdditionalEnsembleLemmas.
  Lemma weaken :
    forall {A: Type} ensemble condition,
    forall (x: A),
      Ensembles.In _ (fun x => Ensembles.In _ ensemble x /\ condition x) x
      -> Ensembles.In _ ensemble x.
  Proof.
    unfold Ensembles.In; intros; intuition.
  Qed.
End AdditionalEnsembleLemmas.

Section AdditionalListLemmas.
  Lemma map_id :
    forall {A: Type} (seq: list A),
      (map (fun x => x) seq) = seq.
  Proof.
    intros A seq; induction seq; simpl; congruence.
  Qed.

  Lemma app_singleton :
    forall {A} (x: A) s,
      [x] ++ s = x :: s.
  Proof.
    reflexivity.
  Qed.

  Lemma app_eq_nil_iff :
    forall {A} s1 s2,
      @nil A = s1 ++ s2 <-> ([] = s1 /\ [] = s2).
  Proof.
    intros; split; intro H.
    - symmetry in H; apply app_eq_nil in H; intuition.
    - intuition; subst; intuition.
  Qed.

  Lemma singleton_neq_nil :
    forall {A} (a: A),
      [a] = [] <-> False.
  Proof.
    intuition discriminate.
  Qed.

  Lemma in_nil_iff :
    forall {A} (item: A),
      List.In item [] <-> False.
  Proof.
    intuition.
  Qed.

  Lemma in_not_nil :
    forall {A} x seq,
      @List.In A x seq -> seq <> nil.
  Proof.
    intros A x seq in_seq eq_nil.
    apply (@in_nil _ x).
    subst seq; assumption.
  Qed.

  Lemma in_seq_false_nil_iff :
    forall {A} (seq: list A),
      (forall (item: A), (List.In item seq <-> False)) <->
      (seq = []).
  Proof.
    intros.
    destruct seq; simpl in *; try tauto.
    split; intro H.
    exfalso; specialize (H a); rewrite <- H; eauto.
    discriminate.
  Qed.

  Lemma filter_comm :
    forall {A: Type} (pred1 pred2: A -> bool),
    forall (seq: list A),
      List.filter pred1 (List.filter pred2 seq) =
      List.filter pred2 (List.filter pred1 seq).
  Proof.
    intros A pred1 pred2 seq;
    induction seq as [ | hd tl];
    [ simpl
    | destruct (pred1 hd) eqn:eq1;
      destruct (pred2 hd) eqn:eq2;
      repeat progress (simpl;
                       try rewrite eq1;
                       try rewrite eq2)
    ]; congruence.
  Qed.

  Lemma InA_In:
    forall (A : Type) (x : A) (l : list A),
      InA eq x l -> List.In x l.
  Proof.
    intros ? ? ? H;
    induction H;
    simpl;
    intuition.
  Qed.

  Lemma not_InA_not_In :
    forall {A: Type} l eqA (x: A),
      Equivalence eqA ->
      not (InA eqA x l) -> not (List.In x l).
  Proof.
    intros A l;
    induction l;
    intros ? ? equiv not_inA in_l;
    simpl in *;

    [ trivial
    | destruct in_l as [eq | in_l];
      subst;
      apply not_inA;
      pose proof equiv as (?,?,?);
      eauto using InA_cons_hd, InA_cons_tl, (In_InA equiv)
    ].
  Qed.

  Lemma NoDupFilter {A}
  : forall (f : A -> bool) (l : list A),
      NoDup l -> NoDup (filter f l).
  Proof.
    induction l; simpl; intros; eauto.
    inversion H; subst; find_if_inside; try constructor; eauto.
    unfold not; intros H'; apply H2; revert H'; clear; induction l;
    simpl; eauto; find_if_inside; simpl; intuition.
  Qed.

  Lemma NoDupA_stronger_than_NoDup :
    forall {A: Type} (seq: list A) eqA,
      Equivalence eqA ->
      NoDupA eqA seq -> NoDup seq.
  Proof.
    intros ? ? ? ? nodupA;
    induction nodupA;
    constructor ;
    [ apply (not_InA_not_In _ _ _ _ H0)
    | trivial].
  (* Alternative proof: red; intros; apply (In_InA (eqA:=eqA)) in H2; intuition. *)
  Qed.

  Definition ExtensionalEq {A B} f g :=
    forall (a: A), @eq B (f a) (g a).

  Lemma filter_by_equiv :
    forall {A} f g,
      ExtensionalEq f g ->
      forall seq, @List.filter A f seq = @List.filter A g seq.
  Proof.
    intros A f g obs seq; unfold ExtensionalEq in obs; induction seq; simpl; try rewrite obs; try rewrite IHseq; trivial.
  Qed.

  Lemma filter_by_equiv_meta :
    forall {A B : Type} (f g : A -> B -> bool),
      (forall (a: A), ExtensionalEq (f a) (g a)) ->
      (forall (a: A) (seq : list B), filter (f a) seq = filter (g a) seq).
  Proof.
    intros * equiv *;
    rewrite (filter_by_equiv _ _ (equiv _));
    reflexivity.
  Qed.

  Lemma filter_and :
    forall {A} pred1 pred2,
    forall (seq: list A),
      List.filter (fun x => andb (pred1 x) (pred2 x)) seq =
      List.filter pred1 (List.filter pred2 seq).
  Proof.
    intros;
    induction seq;
    simpl;
    [ | destruct (pred1 a) eqn:eq1;
        destruct (pred2 a) eqn:eq2];
    simpl;
    try rewrite eq1;
    try rewrite eq2;
    trivial;
    f_equal;
    trivial.
  Qed.

  Lemma filter_and' :
    forall {A} pred1 pred2,
    forall (seq: list A),
      List.filter (fun x => andb (pred1 x) (pred2 x)) seq =
      List.filter pred2 (List.filter pred1 seq).
  Proof.
    intros;
    induction seq;
    simpl;
    [ | destruct (pred1 a) eqn:eq1;
        destruct (pred2 a) eqn:eq2];
    simpl;
    try rewrite eq1;
    try rewrite eq2;
    trivial;
    f_equal;
    trivial.
  Qed.

  Definition flatten {A} seq := List.fold_right (@app A) [] seq.

  Lemma flat_map_flatten :
    forall {A B: Type},
    forall comp seq,
      @flat_map A B comp seq = flatten (map comp seq).
  Proof.
    intros; induction seq; simpl; try rewrite IHseq; reflexivity.
  Qed.

  Lemma in_flatten_iff :
    forall {A} x seqs,
      @List.In A x (flatten seqs) <->
      exists seq, List.In x seq /\ List.In seq seqs.
  Proof.
    intros; unfold flatten.
    induction seqs; simpl.

    firstorder.
    rewrite in_app_iff.
    rewrite IHseqs.

    split.
    intros [ in_head | [seq (in_seqs & in_seq) ] ]; eauto.
    intros [ seq ( in_seq & [ eq_head | in_seqs ] ) ]; subst; eauto.
  Qed.

  Lemma flatten_filter :
    forall {A} (seq: list (list A)) pred,
      List.filter pred (flatten seq) =
      flatten (List.map (List.filter pred) seq).
  Proof.
    intros; induction seq; trivial.
    unfold flatten; simpl.
    induction a; trivial.
    simpl;
      destruct (pred a); simpl; rewrite IHa; trivial.
  Qed.

  Lemma map_flatten :
    forall {B C} (f: B -> C) (xs: list (list B)),
      map f (flatten xs) = flatten (map (fun x => map f x) xs).
  Proof.
    induction xs; simpl;
    [ | rewrite map_app, IHxs ]; reflexivity.
  Qed.

  Lemma map_flat_map :
    forall {A B C} (f: B -> C) (g: A -> list B) (xs: list A),
      map f (flat_map g xs) = flat_map (fun x : A => map f (g x)) xs.
  Proof.
    intros;
    rewrite flat_map_flatten, map_flatten, map_map, <- flat_map_flatten;
    reflexivity.
  Qed.

  Lemma map_map :
    forall { A B C } (f: A -> B) (g: B -> C),
    forall seq,
      List.map g (List.map f seq) = List.map (fun x => g (f x)) seq.
  Proof.
    intros; induction seq; simpl; f_equal; trivial.
  Qed.

  Lemma filter_all_true :
    forall {A} pred (seq: list A),
      (forall x, List.In x seq -> pred x = true) ->
      List.filter pred seq = seq.
  Proof.
    induction seq as [ | head tail IH ]; simpl; trivial.
    intros all_true.
    rewrite all_true by eauto.
    f_equal; intuition.
  Qed.

  Lemma filter_all_false :
    forall {A} seq pred,
      (forall item : A, List.In item seq -> pred item = false) ->
      List.filter pred seq = [].
  Proof.
    intros A seq pred all_false; induction seq as [ | head tail IH ]; simpl; trivial.
    rewrite (all_false head) by (simpl; eauto).
    intuition.
  Qed.

  Lemma map_filter_all_false :
    forall {A} pred seq,
      (forall subseq, List.In subseq seq ->
                      forall (item: A), List.In item subseq ->
                                        pred item = false) ->
      (List.map (List.filter pred) seq) = (List.map (fun x => []) seq).
  Proof.
    intros A pred seq all_false;
    induction seq as [ | subseq subseqs IH ] ; simpl; trivial.

    f_equal.

    specialize (all_false subseq (or_introl eq_refl)).
    apply filter_all_false; assumption.

    apply IH; firstorder.
  Qed.

  Lemma foldright_compose :
    forall {TInf TOutf TAcc}
           (g : TOutf -> TAcc -> TAcc) (f : TInf -> TOutf)
           (seq : list TInf) (init : TAcc),
      List.fold_right (compose g f) init seq =
      List.fold_right g init (List.map f seq).
  Proof.
    intros;
    induction seq;
    simpl;
    [  | rewrite IHseq ];
    reflexivity.
  Qed.

  Lemma flatten_nils :
    forall {A} (seq: list (list A)),
      flatten (List.map (fun _ => []) seq) = @nil A.
  Proof.
    induction seq; intuition.
  Qed.

  Lemma flatten_app :
    forall {A} (seq1 seq2: list (list A)),
      flatten (seq1 ++ seq2) = flatten seq1 ++ flatten seq2.
  Proof.
    unfold flatten; induction seq1; simpl; trivial.
    intros; rewrite IHseq1; rewrite app_assoc; trivial.
  Qed.

  Lemma flatten_head :
    forall {A} head tail,
      @flatten A (head :: tail) = head ++ flatten tail.
  Proof.
    intuition.
  Qed.

  Require Import Permutation.

  Lemma flat_map_rev_permutation :
    forall {A B} seq (f: A -> list B),
      Permutation (flat_map f seq) (flat_map f (rev seq)).
  Proof.
    induction seq; simpl; intros.

    - reflexivity.
    - rewrite !flat_map_flatten, map_app.
      rewrite flatten_app, <- !flat_map_flatten.
      simpl; rewrite app_nil_r.
      rewrite Permutation_app_comm.
      apply Permutation_app; eauto.
  Qed.

  Lemma length_flatten_aux :
    forall {A} seq,
    forall n,
      n + List.length (flatten seq) = List.fold_right (compose plus (@List.length A)) n seq.
  Proof.
    induction seq; simpl; intros.

    - auto with arith.
    - unfold compose;
      rewrite app_length, <- IHseq;
      omega.
  Qed.

  Lemma length_flatten :
    forall {A} seq,
      List.length (flatten seq) = List.fold_right (compose plus (@List.length A)) 0 seq.
  Proof.
    intros.
    pose proof (length_flatten_aux seq 0) as H; simpl in H; eauto.
  Qed.

  Lemma in_map_unproject :
    forall {A B} projection seq,
    forall item,
      @List.In A item seq ->
      @List.In B (projection item) (List.map projection seq).
  Proof.
    intros ? ? ? seq;
    induction seq; simpl; intros item in_seq.

    trivial.
    destruct in_seq;
      [ left; f_equal | right ]; intuition.
  Qed.

  Lemma refold_map :
    forall {A B} (f: A -> B) x seq,
      f x :: map f seq = map f (x :: seq).
  Proof.
    simpl; reflexivity.
  Qed.

  Lemma refold_in :
    forall {A} a b l,
      @List.In A a (b :: l) <-> List.In a l \/ a = b.
  Proof.
    intros; simpl; intuition.
  Qed.

  Lemma app_map_inv :
    forall {A B} seq l1 l2 (f: A -> B),
      l1 ++ l2 = map f seq ->
      exists l1' l2',
        seq = l1' ++ l2' /\ l1 = map f l1' /\ l2 = map f l2'.
  Proof.
    induction seq; simpl; intros.

    exists (@nil A) (@nil A); simpl.
    apply app_eq_nil in H; intuition.

    destruct l1.
    rewrite app_nil_l in H.
    exists (@nil A) (a :: seq); simpl; intuition.

    rewrite <- app_comm_cons in H.
    inversion H.
    specialize (IHseq _ _ _ H2).
    destruct IHseq as [l1' [l2' (seq_eq_app & l1l1' & l2l2') ] ].
    exists (a :: l1') (l2'); subst; intuition.
  Qed.

  Lemma cons_map_inv :
    forall {A B} seq x1 l2 (f: A -> B),
      x1 :: l2 = map f seq ->
      exists x1' l2',
        seq = x1' :: l2' /\ x1 = f x1' /\ l2 = map f l2'.
  Proof.
    intros * _eq.
    destruct seq as [ | x1' l2' ]; simpl in *; try discriminate.
    inversion _eq.
    exists x1' l2'; subst; intuition.
  Qed.

  Lemma map_eq_nil_inv :
    forall {A B} (f: A -> B) seq,
      map f seq = [] -> seq = [].
  Proof.
    intros; destruct seq; simpl in *; try discriminate; trivial.
  Qed.

  Lemma filter_app :
    forall {A} (f: A -> _) s1 s2,
      List.filter f (s1 ++ s2) =
      List.filter f s1 ++ List.filter f s2.
  Proof.
    induction s1; simpl; intros.

    - reflexivity.
    - destruct (f a); simpl; congruence.
  Qed.

  Lemma filter_map :
    forall {A B} f g seq,
      List.filter f (@List.map A B g seq) =
      List.map g (List.filter (fun x => f (g x)) seq).
  Proof.
    induction seq; simpl; intros.

    - reflexivity.
    - destruct (f (g a)); simpl; [ f_equal | ]; assumption.
  Qed.

  Lemma filter_true :
    forall {A} s,
      @filter A (fun _ => true) s = s.
  Proof.
    induction s; simpl; try rewrite IHs; reflexivity.
  Qed.

  Lemma filter_false :
    forall {A} s,
      @filter A (fun _ => false) s = [].
  Proof.
    induction s; simpl; try rewrite IHs; reflexivity.
  Qed.

  Lemma filter_flat_map :
    forall {A B} g (f: B -> bool) xs,
      filter f (flat_map g xs) =
      flat_map (fun x : A => filter f (g x)) xs.
  Proof.
    intros; rewrite !flat_map_flatten.
    rewrite flatten_filter, map_map; reflexivity.
  Qed.

  Lemma filter_flat_map_join_snd :
    forall {A B} f s1 s2,
      flat_map (filter (fun x : A * B => f (snd x)))
               (map (fun a1 : A => map (fun b : B => (a1, b)) s2) s1) =
      flat_map (fun a1 : A => map (fun b : B => (a1, b)) (filter f s2)) s1.
  Proof.
    induction s1; simpl; intros; trivial.
    rewrite IHs1; f_equiv.
    rewrite filter_map; simpl; reflexivity.
  Qed.

  Lemma flat_map_empty :
    forall {A B} s,
      @flat_map A B (fun _ => []) s = [].
  Proof.
    induction s; firstorder.
  Qed.

  Lemma filter_commute :
    forall {A} f g seq,
      @filter A f (filter g seq) = filter g (filter f seq).
  Proof.
    induction seq; simpl; intros; trivial.
    destruct (f a) eqn:eqf; destruct (g a) eqn:eqg;
    simpl; rewrite ?eqf, ?eqg, ?IHseq; trivial.
  Qed.

  Lemma fold_right_id {A} :
    forall seq,
      @List.fold_right (list A) A (fun elem acc => elem :: acc) [] seq = seq.
  Proof.
    induction seq; simpl; try rewrite IHseq; congruence.
  Qed.

  Lemma fold_left_id {A} :
    forall seq,
      @List.fold_left (list A) A (fun acc elem => elem :: acc) seq [] = rev seq.
  Proof.
    intros.
    rewrite <- fold_left_rev_right.
    apply fold_right_id.
  Qed.

  Lemma In_partition {A}
  : forall f (l : list A) a,
      List.In a l <-> (List.In a (fst (List.partition f l))
                       \/ List.In a (snd (List.partition f l))).
  Proof.
    split; induction l; simpl; intros; intuition; simpl; subst;
    first [destruct (f a0); destruct (List.partition f l); simpl in *; intuition
          | destruct (f a); destruct (List.partition f l); simpl; intuition].
  Qed.

  Lemma In_partition_matched {A}
  : forall f (l : list A) a,
      List.In a (fst (List.partition f l)) ->
      f a = true.
  Proof.
    induction l; simpl; intros; intuition; simpl; subst; eauto.
    case_eq (f a); destruct (List.partition f l); simpl; intuition;
    rewrite H0 in H; eauto; inversion H; subst; eauto.
  Qed.

  Lemma In_partition_unmatched {A}
  : forall f (l : list A) a,
      List.In a (snd (List.partition f l)) ->
      f a = false.
  Proof.
    induction l; simpl; intros; intuition; simpl; subst; eauto.
    case_eq (f a); destruct (List.partition f l); simpl; intuition;
    rewrite H0 in H; eauto; inversion H; subst; eauto.
  Qed.

  Lemma nil_in_false :
    forall {A} seq,
      seq = nil <-> ~ exists (x: A), List.In x seq.
  Proof.
    split; intro H.
    intros [ x in_seq ]; subst; eauto using in_nil.
    destruct seq as [ | a ]; trivial.
    exfalso; apply H; exists a; simpl; intuition.
  Qed.

  Lemma In_InA :
    forall (A : Type) (l : list A) (eqA : relation A) (x : A),
      Equivalence eqA -> List.In x l -> InA eqA x l.
  Proof.
    induction l; intros; simpl in *.
    exfalso; eauto using in_nil.
    destruct H0.
    apply InA_cons_hd; subst; reflexivity.
    apply InA_cons_tl, IHl; trivial.
  Qed.

  Lemma fold_map :
      forall {A B C} seq f g init,
        @List.fold_left C A (fun acc x => f acc (g x)) seq init =
        @List.fold_left C B (fun acc x => f acc (  x)) (@List.map A B g seq) init.
  Proof.
    induction seq; simpl; intros; trivial; try rewrite IHseq; intuition.
  Qed.

  Lemma fold_plus_sym :
    forall (seq: list nat) (default: nat),
      List.fold_right plus default seq =
      List.fold_left plus seq default.
  Proof.
    intros; rewrite <- fold_left_rev_right.
    revert default; induction seq; simpl; eauto; intros.
    rewrite fold_right_app; simpl; rewrite <- IHseq.
    clear IHseq; revert a default; induction seq;
    simpl; intros; auto with arith.
    rewrite <- IHseq; omega.
  Qed.

  Lemma map_snd {A B C} :
    forall (f : A -> B) (l : list (C * A)),
      List.map f (List.map snd l) =
      List.map snd (List.map (fun ca => (fst ca, f (snd ca))) l).
  Proof.
    intros; repeat rewrite List.map_map; induction l; simpl; eauto.
  Qed.

  Lemma partition_app {A} :
    forall f (l1 l2 : list A),
      List.partition f (l1 ++ l2) =
      (fst (List.partition f l1) ++ fst (List.partition f l2),
       snd (List.partition f l1) ++ snd (List.partition f l2)).
  Proof.
    induction l1; simpl.
    - intros; destruct (List.partition f l2); reflexivity.
    - intros; rewrite IHl1; destruct (f a); destruct (List.partition f l1);
      simpl; f_equal.
  Qed.

  Lemma partition_filter_eq {A} :
    forall (f : A -> bool) l,
      fst (List.partition f l) = List.filter f l.
  Proof.
    induction l; simpl; eauto.
    destruct (List.partition f l); destruct (f a); simpl in *; congruence.
  Qed.

  Lemma partition_filter_neq {A} :
    forall (f : A -> bool) l,
      snd (List.partition f l) = List.filter (fun a => negb (f a)) l.
  Proof.
    induction l; simpl; eauto.
    destruct (List.partition f l); destruct (f a); simpl in *; congruence.
  Qed.

End AdditionalListLemmas.

Section AdditionalComputeationLemmas.
  Require Import Computation.Refinements.Tactics.

  Lemma ret_computes_to :
    forall {A: Type} (a1 a2: A),
      ret a1 ↝ a2 <-> a1 = a2.
  Proof.
    t_refine.
  Qed.
End AdditionalComputeationLemmas.

Section AdditionalQueryLemmas.
  Require Import InsertQSSpecs StringBound.
  Lemma get_update_unconstr_iff {db_schema qs table new_contents} :
    forall x,
      Ensembles.In _ (GetUnConstrRelation (@UpdateUnConstrRelation db_schema qs table new_contents) table) x <->
      Ensembles.In _ new_contents x.
  Proof.
    unfold GetUnConstrRelation, UpdateUnConstrRelation, EnsembleInsert;
    intros; rewrite ith_replace_BoundIndex_eq;
    reflexivity.
  Qed.

  Lemma decides_negb :
    forall b P,
      decides (negb b) P -> decides b (~ P).
  Proof.
    unfold decides; setoid_rewrite if_negb; simpl; intros.
    destruct b; simpl in *; intuition.
  Qed.
End AdditionalQueryLemmas.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e379m19_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e196m15_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e196m15_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


(**
Biadjunction when adding a 2-cell to the algebra structure
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.Whiskering.
Require Import UniMath.Bicategories.Transformations.Examples.Unitality.
Require Import UniMath.Bicategories.Transformations.Examples.Associativity.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Add2Cell.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispDepProd.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub.
Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor.
Require Import UniMath.Bicategories.DisplayedBicats.DispTransformation.
Require Import UniMath.Bicategories.DisplayedBicats.DispModification.
Require Import UniMath.Bicategories.DisplayedBicats.DispBuilders.
Require Import UniMath.Bicategories.DisplayedBicats.DispBiadjunction.

Require Import signature.hit_signature.
Require Import prelude.all.
Require Import algebra.one_types_polynomials.
Require Import algebra.groupoid_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.groupoid_endpoints.
Require Import algebra.one_types_homotopies.
Require Import algebra.groupoid_homotopies.
Require Import biadjunctions.all.
Require Import hit_biadjunction.path_groupoid_commute.
Require Import hit_biadjunction.gquot_commute.
Require Import hit_biadjunction.gquot_natural.
Require Import hit_biadjunction.hit_prealgebra_biadj.
Require Import hit_biadjunction.hit_path_algebra_biadj.
Require Import hit_biadjunction.hit_algebra_biadj.lift_gquot.
Require Import hit_biadjunction.hit_algebra_biadj.lift_path_groupoid.

Local Open Scope cat.

Definition hit_algebra_biadjunction
           (Σ : hit_signature)
  := total_left_biadj_data
       _
       _
       (disp_fullsub_biadjunction
          (hit_path_algebra_biadjunction Σ)
          (is_hit_algebra_grpd Σ)
          (is_hit_algebra_one_types Σ)
          (gquot_is_hit_algebra Σ)
          (path_groupoid_is_hit_algebra Σ)).