Require Import Nijn.Prelude.
Require Import Nijn.Syntax.
Require Import Nijn.TerminationTechniques.RuleRemoval.
Require Import Nijn.Interpretation.OrderInterpretation.
Require Import Nijn.TerminationTechniques.PolynomialMethod.
Require Import Nijn.TerminationTechniques.NoRules.

Local Open Scope compat.

(** * Certificates *)

(** A certificate is a representation of a proof of strong normalization. As such, the core specification is that from a certificate, one must get a proof of strong normalization. Our certificates allow the following steps:
 - If there are no rewrite rules, then the system is strongly normalizing
 - The polynomial method
 - Rule removal
 Note that for rule removal, we also need another notion of certificate, which we call a rule removal certificate. From this notion of certificate, one must obtain a strong reduction pair that respects the rule selection. For this kind of certificate, we allow the following steps:
 - The polynomial method
 *)
Inductive rule_removal_certificate
          {B F : Type}
          `{decEq B} `{decEq F}
          (X : afs B F)
          (P : selector X)
  : Type
  :=
| PolySRP :
  forall (J : forall (f : F), poly ∙ (arity X f)),
    (forall (r : rewriteRules X)
            (x : sem_Con p_base (vars r)),
       selector_members P r
       ->
       sem_Tm p_base (p_fun_sym X J) p_app' (lhs r) x
       >
       sem_Tm p_base (p_fun_sym X J) p_app' (rhs r) x)
    ->
    (forall (r : rewriteRules X)
            (x : sem_Con p_base (vars r)),
       ~(selector_members P r)
       ->
       sem_Tm p_base (p_fun_sym X J) p_app' (lhs r) x
       >=
       sem_Tm p_base (p_fun_sym X J) p_app' (rhs r) x)
    -> rule_removal_certificate X P.

Definition rr_certificate_to_srp
           {B F : Type}
           `{decEq B} `{decEq F}
           {X : afs B F}
           {P : selector X}
           (C : rule_removal_certificate X P)
  : strong_reduction_pair (arity X).
Proof.
  induction C as [ J ].
  apply interpretation_to_strong_reduction_pair.
  apply poly_InterpretationData.
  exact J.
Defined.

Theorem rr_certificate_respects_srp
        {B F : Type}
        `{decEq B} `{decEq F}
        {X : afs B F}
        {P : selector X}
        (C : rule_removal_certificate X P)
  : respects_selector X (rr_certificate_to_srp C) P.
Proof.
  induction C as [ J H_gt H_ge ].
  refine (interpretation_respects_selector
            P
            (poly_SelectorInterpretation X J P H_gt H_ge)).
Defined.

Inductive certificate
          {B F : Type}
          `{decEq B} `{decEq F}
          (X : afs B F)
  : Type
  :=
| EmptySN : isNil (list_of_rewriteRules X) -> certificate X
| PolySN :
  forall (J : forall (f : F), poly ∙ (arity X f)),
         (forall (r : rewriteRules X)
                 (x : sem_Con p_base (vars r)),
           sem_Tm p_base (p_fun_sym X J) p_app' (lhs r) x
           >
           sem_Tm p_base (p_fun_sym X J) p_app' (rhs r) x)
         ->
         certificate X
| RuleRemovalSN :
  forall (P : selector X),
    rule_removal_certificate X P
    -> certificate (remove_afs X P)
    -> certificate X.

Theorem certificate_to_isSN
        {B F : Type}
        `{decEq B}
        `{decEq F}
        {X : afs B F}
        (C : certificate X)
  : isSN X.
Proof.
  induction C as [ ? HX | ? J HJ | ? P srp C IHC ].
  - apply empty_list_SN.
    exact HX.
  - apply afs_is_SN_from_Interpretation.
    exact (poly_Interpretation _ J HJ).
  - simple refine (rule_removal P _ _ IHC).
    + exact (rr_certificate_to_srp srp).
    + apply rr_certificate_respects_srp.
Defined.


Require Import Coq.Program.Basics.
Require Import Coq.Lists.List.
Require Import Leapfrog.FinType.
Require Import Leapfrog.ConfRel.
Require Import Leapfrog.P4automaton.
Require Import MirrorSolve.FirstOrder.
Require Import MirrorSolve.HLists.
Require Import Leapfrog.Ntuple.

Import ListNotations.
Import HListNotations.
Local Open Scope program_scope.

Set Universe Polymorphism.

Section AutModel.
  Set Implicit Arguments.
  (* State identifiers. *)
  Variable (St: Type).
  Context `{St_eq_dec: EquivDec.EqDec St eq}.
  Context `{St_finite: @Finite St _ St_eq_dec}.

  (* Header identifiers. *)
  Variable (Hdr: Type).
  Context `{Hdr_eq_dec: EquivDec.EqDec Hdr eq}.
  Context `{Hdr_finite: @Finite Hdr _ Hdr_eq_dec}.
  Variable (Hdr_sz: Hdr -> nat).

  Variable (a: P4A.t St Hdr_sz).

  Inductive sorts: Type :=
  | Bits (n: nat)
  | Store.
  Derive NoConfusion for sorts.

  Inductive funs: arity sorts -> sorts -> Type :=
  | BitsLit: forall n, n_tuple bool n -> funs [] (Bits n)
  | Concat: forall n m, funs [Bits n; Bits m] (Bits (n + m))
  | Slice: forall n hi lo, funs [Bits n] (Bits (Nat.min (1 + hi) n - lo))
  | Lookup: forall h, funs [Store] (Bits (Hdr_sz h)).

  Inductive rels: arity sorts -> Type :=.

  Definition sig: signature :=
    {| sig_sorts := sorts;
       sig_funs := funs;
       sig_rels := rels |}.

  Definition fm ctx := fm sig ctx.
  Definition tm ctx := tm sig ctx.

  Definition mod_sorts (s: sig_sorts sig) : Type :=
    match s with
    | Bits n => n_tuple bool n
    | Store => store (P4A.interp a)
    end.

  Obligation Tactic := idtac.
  Equations mod_fns
             params ret
             (f: sig_funs sig params ret)
             (args: HList.t mod_sorts params)
    : mod_sorts ret :=
    { mod_fns (BitsLit n xs) hnil := xs;
      mod_fns (Concat n m) (xs ::: ys ::: hnil) :=
        n_tuple_concat xs ys;
      mod_fns (Slice n hi lo) (xs ::: hnil) :=
        n_tuple_slice hi lo xs;
      mod_fns (Lookup k) (store ::: hnil) :=
        match P4A.find Hdr Hdr_sz k store with
        | P4A.VBits _ v => v
        end
    }.

  Definition mod_rels params
    (args: sig_rels sig params)
    (env: HList.t mod_sorts params) : Prop :=
    match args with
    end.

  (* Instantiation of abstract first-order logic to FOL(BV). *)
  Program Definition fm_model : model sig := {|
    FirstOrder.mod_sorts := mod_sorts;
    FirstOrder.mod_fns := mod_fns;
    FirstOrder.mod_rels := mod_rels;
  |}.

  Obligation Tactic := intros.

  (* Removes concatenations where the left operand is empty. *)
  Equations simplify_concat_zero {ctx srt} (e: tm ctx srt) : tm ctx srt :=
    { simplify_concat_zero (TFun sig (Concat 0 m) (_ ::: x ::: hnil)) :=
        simplify_concat_zero x;
      simplify_concat_zero (TFun sig (Concat (S n) m) (x ::: y ::: hnil)) :=
        TFun sig (Concat (S n) m)
                 (simplify_concat_zero x :::
                  simplify_concat_zero y ::: hnil);
      simplify_concat_zero (TFun sig (Slice n hi lo) (x ::: hnil)) :=
        TFun sig (Slice n hi lo) (simplify_concat_zero x ::: hnil);
      simplify_concat_zero (TFun sig f args) :=
        TFun sig f args;
      simplify_concat_zero (TVar x) := TVar x;
    }.

  Import Coq.Program.Equality.

  Lemma concat_emp' :
    forall n (t: n_tuple bool n), n_tuple_concat (tt: n_tuple _ 0) t = t.
  Proof.
    intros.
    apply JMeq_eq.
    eapply concat_emp.
  Qed.

  Lemma interp_zero_tm:
     forall c (t: tm c (Bits 0)) v,
       interp_tm (m := fm_model) v t = tt
  .
  Proof.
    intros; now destruct (interp_tm v t).
  Qed.

  Lemma simplify_concat_zero_corr :
    forall ctx srt (t : tm ctx srt) v,
      interp_tm (m := fm_model) v t = interp_tm v (simplify_concat_zero (ctx := ctx) t).
  Proof.
    intros.
    dependent induction t using tm_ind'.
    - now autorewrite with simplify_concat_zero.
    - destruct srt;
      repeat dependent destruction hl.
      + now autorewrite with simplify_concat_zero.
      + destruct n.
        * autorewrite with simplify_concat_zero.
          autorewrite with interp_tm; simpl.
          autorewrite with mod_fns.
          destruct (interp_tm v t).
          rewrite concat_emp'.
          apply H.
        * autorewrite with simplify_concat_zero.
          autorewrite with interp_tm; simpl.
          autorewrite with mod_fns.
          f_equal; apply H.
      + autorewrite with simplify_concat_zero.
        autorewrite with interp_tm; simpl.
        do 2 f_equal.
        apply H.
      + now autorewrite with simplify_concat_zero.
  Qed.

  (* Pass that removes concatenations where the left operand is empty;
     the real work is done in simplify_concat_zero above. *)
  Equations simplify_concat_zero_fm {ctx} (e: fm ctx) : fm ctx := {
    simplify_concat_zero_fm FTrue := FTrue;
    simplify_concat_zero_fm FFalse := FFalse;
    simplify_concat_zero_fm (FEq e1 e2) := FEq (simplify_concat_zero e1) (simplify_concat_zero e2);
    simplify_concat_zero_fm (FNeg f) := FNeg _ (simplify_concat_zero_fm f);
    simplify_concat_zero_fm (FOr f1 f2) := FOr _ (simplify_concat_zero_fm f1) (simplify_concat_zero_fm f2);
    simplify_concat_zero_fm (FAnd f1 f2) := FAnd _ (simplify_concat_zero_fm f1) (simplify_concat_zero_fm f2);
    simplify_concat_zero_fm (FImpl f1 f2) := FImpl (simplify_concat_zero_fm f1) (simplify_concat_zero_fm f2);
    simplify_concat_zero_fm (FForall f) := FForall _ (simplify_concat_zero_fm f);
  }.

  (* Removing zero concatenations is a correct transformation. *)
  Lemma simplify_concat_zero_fm_corr:
    forall ctx (f: fm ctx) valu,
      interp_fm valu f <-> interp_fm (m := fm_model) valu (simplify_concat_zero_fm f)
  .
  Proof.
    intros.
    induction f; autorewrite with simplify_concat_zero_fm;
    (try now split; intros; auto);
    autorewrite with interp_fm;
    repeat erewrite <- simplify_concat_zero_corr;
    (try now split; intros; auto).
    - split; unfold "~"; intros; apply H; eapply IHf; auto.
    - erewrite IHf1. erewrite IHf2. split; intros; auto.
    - erewrite IHf1. erewrite IHf2. split; intros; auto.
    - erewrite IHf1. erewrite IHf2. split; intros; auto.
    - setoid_rewrite IHf. split; intros; auto.
  Qed.

  Equations simplify_eq_zero_fm {ctx} (e: fm ctx) : fm ctx := {
    simplify_eq_zero_fm FTrue := FTrue;
    simplify_eq_zero_fm FFalse := FFalse;
    simplify_eq_zero_fm (@FEq _ _ (Bits 0) _ _) := FTrue;
    simplify_eq_zero_fm (@FEq _ _ _ e1 e2) := FEq e1 e2;
    simplify_eq_zero_fm (FNeg f) := FNeg _ (simplify_eq_zero_fm f);
    simplify_eq_zero_fm (FOr f1 f2) := FOr _ (simplify_eq_zero_fm f1) (simplify_eq_zero_fm f2);
    simplify_eq_zero_fm (FAnd f1 f2) := FAnd _ (simplify_eq_zero_fm f1) (simplify_eq_zero_fm f2);
    simplify_eq_zero_fm (FImpl f1 f2) := FImpl (simplify_eq_zero_fm f1) (simplify_eq_zero_fm f2);
    simplify_eq_zero_fm (FForall f) := FForall _ (simplify_eq_zero_fm f);
  }.

  Lemma simplify_eq_zero_fm_corr:
    forall ctx (f: fm ctx) valu,
      interp_fm valu f <-> interp_fm (m := fm_model) valu (simplify_eq_zero_fm f).
  Proof.
    intros.
    induction f; autorewrite with simplify_eq_zero_fm;
    (try now split; intros; auto);
    autorewrite with interp_fm;
    (try now split; intros; auto).
    - destruct s; autorewrite with simplify_eq_zero_fm.
      + destruct n; autorewrite with simplify_eq_zero_fm.
        * repeat erewrite interp_zero_tm; split; intros; autorewrite with interp_fm; autorewrite with interp_fm; auto.
        * autorewrite with interp_fm; split; intros; auto.
      + autorewrite with interp_fm; split; intros; auto.
    - split; unfold "~"; intros; apply H; eapply IHf; auto.
    - erewrite IHf1. erewrite IHf2. split; intros; auto.
    - erewrite IHf1. erewrite IHf2. split; intros; auto.
    - erewrite IHf1. erewrite IHf2. split; intros; auto.
    - setoid_rewrite IHf. split; intros; auto.
  Qed.

  (* It feels like this should be an instance of map_subst, but I can't get
     that to go through so here's a direct proof. *)
  Lemma interp_tm_rect:
    forall n1 n2 (c: ctx sig) valu (e: tm c (Bits n1)) (Heq: n1 = n2),
      eq_rect n1 (n_tuple bool) (interp_tm (m := fm_model) valu e) n2 Heq =
      interp_tm valu (eq_rect n1 (tm c ∘ Bits) e n2 Heq).
  Proof.
    intros; now rewrite <- Heq.
  Qed.

End AutModel.


Require Import Coqlib.
Require Import Asm.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

Definition peep_mul_4_to_sal_example := Pimul_ri EDX four :: nil.

Section MUL_4_TO_SAL.

  Variable concrete : code.
  Variable r1 : ireg.

  Definition peep_mul_4_to_sal_defs : rewrite_defs :=
    {|
      fnd :=
        Pimul_ri r1 four :: nil
      ; rpl :=
          Psal_ri r1 two :: nil
      ; lv_in := IR r1 :: PC :: nil
      ; lv_out := IR r1 :: PC :: nil
      ; clobbered := flags
    |}.

  Lemma peep_mul_4_to_sal_selr :
    StepEquiv.step_through_equiv_live (fnd peep_mul_4_to_sal_defs) (rpl peep_mul_4_to_sal_defs) (lv_in peep_mul_4_to_sal_defs) (lv_out peep_mul_4_to_sal_defs).
  Proof.
    prep_l.
    step_l.
    prep_r.
    step_r.
    finish_r.
    prep_eq'.
    - preg_simpl.
      unfold Val.shl.
      unfold Val.mul.
      repeat (break_match_sm); simpl; intros; try congruence.
      f_equal.
      P0 _simpl val_eq.
      inv_vint.
      eapply Int.mul_pow2.
      unfold two.
      unfold Int.one.
      erewrite <- Int.is_power2_two_p.
      simpl.
      f_equal.
      vm_compute.
      split; intros; congruence.
      clear -Heqb0.
      exfalso.
      vm_compute in *.
      congruence.
    - subst.
      preg_simpl.
      repeat find_rewrite_goal.
      simpl.
      auto.
  Qed.

  Definition peep_mul_4_to_sal_proofs : rewrite_proofs :=
    {|
      defs := peep_mul_4_to_sal_defs
      ; selr := peep_mul_4_to_sal_selr
    |}.

  Definition peep_mul_4_to_sal :
    concrete = fnd peep_mul_4_to_sal_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite peep_mul_4_to_sal_defs peep_mul_4_to_sal_proofs.
  Qed.

End MUL_4_TO_SAL.

Definition peep_mul_4_to_sal_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_mul_4_to_sal p.
  unfold peep_mul_4_to_sal_defs in p.
  simpl in p.
  specialize (p c).
  do 1 set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat peep_mul_4_to_sal_example.
  set_int_eq n (four).
  specialize (p _ eq_refl). exact (Some p).
Defined.

Definition mul_4_to_sal (c : code) : list StepEquiv.rewrite :=
  collect (map peep_mul_4_to_sal_rewrite (ParamSplit.matched_pat peep_mul_4_to_sal_example c)).


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

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

Print Assumptions add.


MacBook-Air:src billw$ coqtop
Welcome to Coq 8.4pl6 (January 2017)

Coq < Section Reality_Check03.

Coq < Require Import Classical.

Coq < Load CpdtTactics.

Coq < Goal forall b w m f g:Prop, (((m /\ f /\ b) /\ g) /\ ((m /\ f /\ w) /\ g)) -> ((f /\ w /\ b) /\ g).
1 subgoal

  ============================
   forall b w m f g : Prop,
   ((m /\ f /\ b) /\ g) /\ (m /\ f /\ w) /\ g -> (f /\ w /\ b) /\ g

Unnamed_thm < crush.
No more subgoals.

Unnamed_thm < Qed.
crush.

Unnamed_thm is defined


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(*     A development written by Pierre Castéran for Coq V6.1

Coq : A product of inria : "http://pauillac.inria.fr/coq/coq-eng.html"

Pierre Castéran : A product of LaBRI :

LaBRI, Universite Bordeaux-I      |    12 place Puy Paulin
351 Cours de la Liberation        |    33000 Bordeaux
F-33405 TALENCE Cedex             |    France
France                            |    (+ 33) 5 56 81 15 80
tel : (+ 33) 5 56 84 69 31
fax : (+ 33) 5 56 84 66 69
email: casteran@labri.u-bordeaux.fr
www: http://dept-info.labri.u-bordeaux.fr/~casteran

"Les rêves sont aussi beaux que la réalité, mais ils ne sont pas mieux".
( J.L.Borges )

*)

(* binary nat trees *)

Global Set Asymmetric Patterns.
Require Export Peano_dec.

(*       II The binary tree data structure
******************************************
******************************************

   We define here the "nat_tree" inductive data type.
   In the remaining of this file, the term "binary tree" will
   denote a complete binary tree, the internal nodes of which are
   labeled by natural integers.
*)

Inductive nat_tree : Set :=
  | NIL : nat_tree
  | bin : nat -> nat_tree -> nat_tree -> nat_tree.

(*
    Example:

         3
       /  \
      /    \
     7      8          Coq representation:
    / \    / \
   NIL \  NIL NIL      (bin three (bin seven NIL (bin nine NIL NIL))
        9                         (bin eight NIL NIL))
       / \             where three is the term (S (S (S O))) and so on ...
      /   \
     NIL  NIL
*)

(* II.1   Some definitions and lemmas
   ************************************)

(* (binp t) means "t is not NIL"  *)

Inductive binp : nat_tree -> Prop :=
    binp_intro : forall (n : nat) (t1 t2 : nat_tree), binp (bin n t1 t2).

Hint Resolve binp_intro: searchtrees.

Lemma NIL_not_bin : ~ binp NIL.
(******************************)
Proof.
 unfold not in |- *; intros H.
 inversion_clear H.
 Qed.
Hint Resolve NIL_not_bin: searchtrees.

Lemma diff_nil_bin : forall (n : nat) (t1 t2 : nat_tree), bin n t1 t2 <> NIL.
(************************************************************)
Proof.
 intros; discriminate.
Qed.

Hint Resolve diff_nil_bin: searchtrees.

(* II.2 membership
*******************************************
(occ t p) means: "t has an occurrence of p" *)

Inductive occ : nat_tree -> nat -> Prop :=
  | occ_root : forall (n : nat) (t1 t2 : nat_tree), occ (bin n t1 t2) n
  | occ_l :
      forall (n p : nat) (t1 t2 : nat_tree), occ t1 p -> occ (bin n t1 t2) p
  | occ_r :
      forall (n p : nat) (t1 t2 : nat_tree), occ t2 p -> occ (bin n t1 t2) p.

Hint Resolve occ_root occ_l occ_r: searchtrees.

Definition member (n : nat) (t : nat_tree) := occ t n.

Derive Inversion_clear OCC_INV with
 (forall (n p : nat) (t1 t2 : nat_tree), occ (bin n t1 t2) p).

(* Coq < Check OCC_INV.
OCC_INV : (P:nat->nat->nat_tree->nat_tree->Prop)
        (n,p:nat)(t1,t2:nat_tree)
            (P p p t1 t2)
             ->((occ t1 p)->(P n p t1 t2))
                ->((occ t2 p)->(P n p t1 t2))
                   ->(occ (bin n t1 t2) p)->(P n p t1 t2) *)

Lemma occ_inv :
 forall (n p : nat) (t1 t2 : nat_tree),
 occ (bin n t1 t2) p -> n = p \/ occ t1 p \/ occ t2 p.
(**********************************************)
Proof.
intros.
inversion H using OCC_INV; auto with searchtrees.
Qed.

Hint Resolve occ_inv: searchtrees.

Lemma not_occ_nil : forall p : nat, ~ occ NIL p.
(**************************************)
Proof.
unfold not in |- *; intros p H.
inversion_clear H.
Qed.

Hint Resolve not_occ_nil: searchtrees.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: ZArith_base.v 14641 2011-11-06 11:59:10Z herbelin $ *)

(** Library for manipulating integers based on binary encoding.
    These are the basic modules, required by [Omega] and [Ring] for instance.
    The full library is [ZArith]. *)

Require Export BinPos.
Require Export BinNat.
Require Export BinInt.
Require Export Zcompare.
Require Export Zorder.
Require Export Zeven.
Require Export Zminmax.
Require Export Zmin.
Require Export Zmax.
Require Export Zabs.
Require Export Znat.
Require Export auxiliary.
Require Export ZArith_dec.
Require Export Zbool.
Require Export Zmisc.
Require Export Wf_Z.

Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l
  Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l
  Zmult_plus_distr_r: zarith.

Require Export Zhints.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(* begin hide *)
Require Export CoRN.logic.CLogic.
Require Export Coq.Bool.Bool.

Section Syntactic_Expressions.

Definition varindex : Set := nat.
Definition pfunindex : Set := nat.
Definition unopindex : Set := nat.
Definition binopindex : Set := nat.

Inductive expr : Set :=
  | expr_var : varindex -> expr
  | expr_int : Z -> expr
  | expr_plus : expr -> expr -> expr
  | expr_mult : expr -> expr -> expr
  | expr_div : expr -> expr -> expr
  | expr_unop : unopindex -> expr -> expr
  | expr_binop : binopindex -> expr -> expr -> expr
  | expr_part : pfunindex -> expr -> expr.

Definition expr_zero : expr := expr_int 0.
Definition expr_one : expr := expr_int 1.
Definition expr_nat (n:nat) : expr := expr_int (Z_of_nat n).
Definition expr_inv (e:expr) : expr := expr_mult e (expr_int (-1)).
Definition expr_minus (e e':expr) : expr := expr_plus e (expr_inv e').
Fixpoint expr_power (n:nat) (e:expr) {struct n} : expr :=
  match n with
  | O => expr_one
  | S m => expr_mult e (expr_power m e)
  end.

End Syntactic_Expressions.

Section Normalization_Function.

Fixpoint eq_nat (n m:nat) {struct n} : bool :=
  match n, m with
  | S n', S m' => eq_nat n' m'
  | O, O => true
  | _, _ => false
  end.

Fixpoint lt_nat (n m:nat) {struct n} : bool :=
  match n, m with
  | S n', S m' => lt_nat n' m'
  | O, S _ => true
  | _, _ => false
  end.

Definition le_nat (n m:nat) := orb (eq_nat n m) (lt_nat n m).

Definition eq_int (z z':Z) : bool :=
  match z, z' with
  | Zpos n, Zpos m => eq_nat (nat_of_P n) (nat_of_P m)
  | Z0, Z0 => true
  | Zneg n, Zneg m => eq_nat (nat_of_P n) (nat_of_P m)
  | _, _ => false
  end.

Definition lt_int (z z':Z) : bool :=
  match z, z' with
  | Zpos n, Zpos m => lt_nat (nat_of_P n) (nat_of_P m)
  | Zpos n, _ => false
  | Z0, Zpos n => true
  | Z0, _ => false
  | Zneg n, Zneg m => lt_nat (nat_of_P m) (nat_of_P n)
  | Zneg n, _ => true
  end.

Definition le_int (z z':Z) := orb (eq_int z z') (lt_int z z').

Fixpoint eq_expr (e f:expr) {struct e} : bool :=
  match e, f with
  | expr_var n, expr_var m => eq_nat n m
  | expr_int z, expr_int z' => eq_int z z'
  | expr_plus e1 e2, expr_plus f1 f2 => andb (eq_expr e1 f1) (eq_expr e2 f2)
  | expr_mult e1 e2, expr_mult f1 f2 => andb (eq_expr e1 f1) (eq_expr e2 f2)
  | expr_div e1 e2, expr_div f1 f2 => andb (eq_expr e1 f1) (eq_expr e2 f2)
  | expr_unop n e', expr_unop m f' => andb (eq_nat n m) (eq_expr e' f')
  | expr_binop n e' e'', expr_binop m f' f'' =>
      andb (eq_nat n m) (andb (eq_expr e' f') (eq_expr e'' f''))
  | expr_part n e', expr_part m f' => andb (eq_nat n m) (eq_expr e' f')
  | _, _ => false
  end.

Fixpoint lt_expr (e f:expr) {struct e} : bool :=
  match e, f with
  | expr_var n, expr_var m => lt_nat n m
  | expr_var n, _ => true
  | _, expr_var n => false
  | expr_int z, expr_int z' => lt_int z z'
  | expr_int _, _ => true
  | _, expr_int _ => false
  | expr_plus e1 e2, expr_plus f1 f2 =>
      orb (lt_expr e1 f1) (andb (eq_expr e1 f1) (lt_expr e2 f2))
  | expr_plus _ _, _ => true
  | _, expr_plus _ _ => false
  | expr_mult e1 e2, expr_mult f1 f2 =>
      orb (lt_expr e1 f1) (andb (eq_expr e1 f1) (lt_expr e2 f2))
  | expr_mult _ _, _ => true
  | _, expr_mult _ _ => false
  | expr_div e1 e2, expr_div f1 f2 =>
      orb (lt_expr e1 f1) (andb (eq_expr e1 f1) (lt_expr e2 f2))
  | expr_div _ _, _ => true
  | _, expr_div _ _ => false
  | expr_unop n e', expr_unop m f' =>
      orb (lt_nat n m) (andb (eq_nat n m) (lt_expr e' f'))
  | expr_unop _ _, _ => true
  | _, expr_unop _ _ => false
  | expr_binop n e' e'', expr_binop m f' f'' =>
      orb (lt_nat n m)
        (orb (andb (eq_nat n m) (lt_expr e' f'))
           (andb (eq_nat n m) (andb (eq_expr e' f') (lt_expr e'' f''))))
  | expr_binop _ _ _, _ => true
  | _, expr_binop _ _ _ => false
  | expr_part n e', expr_part m f' =>
      orb (lt_nat n m) (andb (eq_nat n m) (lt_expr e' f'))
  end.

Definition le_expr (e f:expr) := orb (eq_expr e f) (lt_expr e f).

Fixpoint eq_monom (e f:expr) {struct e} : bool :=
  match e, f with
  | expr_mult (expr_var n) e', expr_mult (expr_var m) f' =>
      andb (eq_nat n m) (eq_monom e' f')
  | expr_mult (expr_unop n e1) e', expr_mult (expr_unop m f1) f' =>
      andb (eq_nat n m) (andb (eq_monom e' f') (eq_expr e1 f1))
  | expr_mult (expr_binop n e1 e2) e', expr_mult (expr_binop m f1 f2) f' =>
      andb (eq_nat n m)
        (andb (eq_monom e' f') (andb (eq_expr e1 f1) (eq_expr e2 f2)))
  | expr_mult (expr_part n e1) e', expr_mult (expr_part m f1) f' =>
      andb (eq_nat n m) (andb (eq_monom e' f') (eq_expr e1 f1))
  | expr_int _, expr_int _ => true
  | _, _ => false
  end.

Fixpoint lt_monom (e f:expr) {struct e} : bool :=
  match e, f with
  | expr_mult (expr_var n) e', expr_mult (expr_var m) f' =>
      ifb (eq_nat n m) (lt_monom e' f') (lt_nat n m)
  | expr_mult (expr_var _) _, expr_mult (expr_unop _ _) _ => true
  | expr_mult (expr_var _) _, expr_mult (expr_binop _ _ _) _ => true
  | expr_mult (expr_var _) _, expr_mult (expr_part _ _) _ => true
  | expr_mult (expr_unop n e1) e', expr_mult (expr_unop m f1) f' =>
      ifb (eq_expr (expr_unop n e1) (expr_unop m f1)) (
        lt_expr e' f') (lt_expr (expr_unop n e1) (expr_unop m f1))
  | expr_mult (expr_unop _ _) _, expr_mult (expr_binop _ _ _) _ => true
  | expr_mult (expr_unop _ _) _, expr_mult (expr_part _ _) _ => true
  | expr_mult (expr_binop n e1 e2) e', expr_mult (expr_binop m f1 f2) f' =>
      ifb (eq_expr (expr_binop n e1 e2) (expr_binop m f1 f2)) (
        lt_expr e' f') (lt_expr (expr_binop n e1 e2) (expr_binop m f1 f2))
  | expr_mult (expr_binop _ _ _) _, expr_mult (expr_part _ _) _ => true
  | expr_mult (expr_part n e1) e', expr_mult (expr_part m f1) f' =>
      ifb (eq_expr (expr_part n e1) (expr_part m f1)) (
        lt_expr e' f') (lt_expr (expr_part n e1) (expr_part m f1))
  | _, expr_int _ => true
  | _, _ => false
  end.

Fixpoint MI_mult (e f:expr) {struct e} : expr :=
  let d := expr_mult e f in
  match e, f with
  | e, expr_int Z0 => expr_int 0
  | expr_mult e1 e2, f => expr_mult e1 (MI_mult e2 f)
  | expr_int i, expr_int j => expr_int (i * j)
  | _, _ => d
  end.

Fixpoint MV_mult (e f:expr) {struct e} : expr :=
  let d := expr_mult e f in
  match e, f with
  | expr_mult (expr_var n) e', expr_var m =>
      match lt_nat n m with
      | true => expr_mult (expr_var n) (MV_mult e' f)
      | false => expr_mult f e
      end
  | expr_mult (expr_var n) e', expr_unop _ _ =>
      expr_mult (expr_var n) (MV_mult e' f)
  | expr_mult (expr_var n) e', expr_binop _ _ _ =>
      expr_mult (expr_var n) (MV_mult e' f)
  | expr_mult (expr_var n) e', expr_part _ _ =>
      expr_mult (expr_var n) (MV_mult e' f)
  | expr_mult (expr_unop _ _) e', expr_var _ => expr_mult f e
  | expr_mult (expr_unop n e') e0, expr_unop m f' =>
      match lt_expr (expr_unop n e') f with
      | true => expr_mult (expr_unop n e') (MV_mult e0 f)
      | false => expr_mult f e
      end
  | expr_mult (expr_unop n e1) e', expr_binop _ _ _ =>
      expr_mult (expr_unop n e1) (MV_mult e' f)
  | expr_mult (expr_unop n e1) e', expr_part _ _ =>
      expr_mult (expr_unop n e1) (MV_mult e' f)
  | expr_mult (expr_binop _ _ _) e', expr_var _ => expr_mult f e
  | expr_mult (expr_binop _ _ _) e', expr_unop _ _ => expr_mult f e
  | expr_mult (expr_binop n e' e'') e0, expr_binop m f' f'' =>
      match lt_expr (expr_binop n e' e'') f with
      | true => expr_mult (expr_binop n e' e'') (MV_mult e0 f)
      | false => expr_mult f e
      end
  | expr_mult (expr_binop n e1 e2) e', expr_part _ _ =>
      expr_mult (expr_binop n e1 e2) (MV_mult e' f)
  | expr_mult (expr_part _ _) e', expr_var _ => expr_mult f e
  | expr_mult (expr_part _ _) e', expr_unop _ _ => expr_mult f e
  | expr_mult (expr_part _ _) e', expr_binop _ _ _ => expr_mult f e
  | expr_mult (expr_part n e') e0, expr_part m f' =>
      match lt_expr (expr_part n e') f with
      | true => expr_mult (expr_part n e') (MV_mult e0 f)
      | false => expr_mult f e
      end
  | expr_int i, f => MI_mult (expr_mult f expr_one) e
  | _, _ => d
  end.

Fixpoint MM_mult (e f:expr) {struct e} : expr :=
  let d := expr_mult e f in
  match e, f with
  | expr_mult e1 e2, f => MV_mult (MM_mult e2 f) e1
  | expr_int i, f => MI_mult f e
  | _, _ => d
  end.

Fixpoint MM_plus (e f:expr) {struct e} : expr :=
  let d := expr_plus e f in
  match e, f with
  | expr_mult (expr_var n) e', expr_mult (expr_var m) f' =>
      match eq_nat n m with
      | true => MV_mult (MM_plus e' f') (expr_var n)
      | false => d
      end
  | expr_mult (expr_unop g arg) e', expr_mult (expr_unop h arg') f' =>
      match eq_expr (expr_unop g arg) (expr_unop h arg') with
      | true => MV_mult (MM_plus e' f') (expr_unop g arg)
      | false => d
      end
  | expr_mult (expr_binop g e1 e2) e', expr_mult (expr_binop h f1 f2) f' =>
      match eq_expr (expr_binop g e1 e2) (expr_binop h f1 f2) with
      | true => MV_mult (MM_plus e' f') (expr_binop g e1 e2)
      | false => d
      end
  | expr_mult (expr_part g arg) e', expr_mult (expr_part h arg') f' =>
      match andb (eq_nat g h) (eq_expr arg arg') with
      | true => MV_mult (MM_plus e' f') (expr_part g arg)
      | false => d
      end
  | expr_int i, expr_int j => expr_int (i + j)
  | _, _ => d
  end.

Fixpoint PM_plus (e f:expr) {struct e} : expr :=
  let d := expr_plus e f in
  match e, f with
  | expr_plus e1 e2, expr_int _ => expr_plus e1 (PM_plus e2 f)
  | expr_int i, expr_int j => MM_plus e f
  | expr_plus e1 e2, f =>
      match eq_monom e1 f with
      | true => PM_plus e2 (MM_plus e1 f)
      | false =>
          match lt_monom e1 f with
          | true => expr_plus e1 (PM_plus e2 f)
          | false => expr_plus f e
          end
      end
  | expr_int i, f => expr_plus f e
  | _, _ => d
  end.

Fixpoint PP_plus (e f:expr) {struct e} : expr :=
  let d := expr_plus e f in
  match e, f with
  | expr_plus e1 e2, f => PM_plus (PP_plus e2 f) e1
  | expr_int i, f => PM_plus f e
  | _, _ => d
  end.

Fixpoint PM_mult (e f:expr) {struct e} : expr :=
  let d := expr_mult e f in
  match e, f with
  | expr_plus e1 e2, f => PM_plus (PM_mult e2 f) (MM_mult e1 f)
  | expr_int i, _ => PM_plus (expr_int 0) (MI_mult f e)
  | _, _ => d
  end.

Fixpoint PP_mult (e f:expr) {struct e} : expr :=
  let d := expr_mult e f in
  match e, f with
  | expr_plus e1 e2, f => PP_plus (PM_mult f e1) (PP_mult e2 f)
  | expr_int i, f => PM_mult f e
  | _, _ => d
  end.

Definition FF_plus (e f:expr) : expr :=
  let d := expr_plus e f in
  match e, f with
  | expr_div e1 e2, expr_div f1 f2 =>
      expr_div (PP_plus (PP_mult e1 f2) (PP_mult e2 f1)) (PP_mult e2 f2)
  | _, _ => d
  end.

Definition FF_mult (e f:expr) : expr :=
  let d := expr_mult e f in
  match e, f with
  | expr_div e1 e2, expr_div f1 f2 =>
      expr_div (PP_mult e1 f1) (PP_mult e2 f2)
  | _, _ => d
  end.

Definition FF_div (e f:expr) : expr :=
  let d := expr_div e f in
  match e, f with
  | expr_div e1 e2, expr_div f1 f2 =>
      expr_div (PP_mult e1 f2) (PP_mult e2 f1)
  | _, _ => d
  end.

Fixpoint NormR (e:expr) : expr :=
  match e with
  | expr_var n => expr_plus (expr_mult e expr_one) expr_zero
  | expr_int i => e
  | expr_plus e1 e2 => PP_plus (NormR e1) (NormR e2)
  | expr_mult e1 e2 => PP_mult (NormR e1) (NormR e2)
  | expr_div e1 e2 => e
  | expr_unop f e =>
      expr_plus (expr_mult (expr_unop f (NormR e)) expr_one) expr_zero
  | expr_binop f e e' =>
      expr_plus (expr_mult (expr_binop f (NormR e) (NormR e')) expr_one)
        expr_zero
  | expr_part f e =>
      expr_plus (expr_mult (expr_part f (NormR e)) expr_one) expr_zero
  end.

Definition NormG := NormR.

Fixpoint NormF (e:expr) : expr :=
  match e with
  | expr_var n =>
      expr_div (expr_plus (expr_mult e expr_one) expr_zero) expr_one
  | expr_int i => expr_div e expr_one
  | expr_plus e1 e2 => FF_plus (NormF e1) (NormF e2)
  | expr_mult e1 e2 => FF_mult (NormF e1) (NormF e2)
  | expr_div e1 e2 => FF_div (NormF e1) (NormF e2)
  | expr_unop f e =>
      expr_div
        (expr_plus (expr_mult (expr_unop f (NormF e)) expr_one) expr_zero)
        expr_one
  | expr_binop f e e' =>
      expr_div
        (expr_plus (expr_mult (expr_binop f (NormF e) (NormF e')) expr_one)
           expr_zero) expr_one
  | expr_part f e =>
      expr_div
        (expr_plus (expr_mult (expr_part f (NormF e)) expr_one) expr_zero)
        expr_one
  end.

Definition expr_is_zero (e:expr) : bool :=
  match e with
  | expr_div (expr_int Z0) _ => true
  | _ => false
  end.

End Normalization_Function.

Section Correctness_Results.

Lemma eq_nat_corr : forall n m:nat, eq_nat n m = true -> n = m.
Proof.
 simple induction n; simple induction m; simpl in |- *; intros.
    trivial.
   inversion H0.
  inversion H0.
 rewrite (H n1 H1). trivial.
Qed.

Lemma eq_int_corr : forall n m:Z, eq_int n m = true -> n = m.
Proof.
 simple induction n; simple induction m; simpl in |- *; intros.
         trivial.
        inversion H.
       inversion H.
      inversion H.
     rewrite <- (convert_is_POS p). rewrite <- (convert_is_POS p0).
     cut (nat_of_P p = nat_of_P p0). auto. apply eq_nat_corr. assumption.
      inversion H.
   inversion H.
  inversion H.
 cut (p = p0); intros.
  rewrite H0; auto.
 rewrite (anti_convert_pred_convert p). rewrite (anti_convert_pred_convert p0).
 cut (nat_of_P p = nat_of_P p0). intro. auto. apply eq_nat_corr. assumption.
Qed.

Lemma eq_expr_corr : forall e e':expr, eq_expr e e' = true -> e = e'.
Proof.
 simple induction e; simple induction e'; simpl in |- *; intros;
   try inversion H3; try inversion H2; try inversion H1; try inversion H0; try inversion H.
        cut (v = v0). intro. rewrite H0; auto. apply eq_nat_corr; assumption.
         cut (z = z0). intro. rewrite H0; auto. apply eq_int_corr; assumption.
        clear H1 H2. elim (andb_prop _ _ H3); intros.
      cut (e0 = e2). cut (e1 = e3). intros. rewrite H4; rewrite H6. auto.
       apply H0. assumption. apply H. assumption.
       clear H1 H2. elim (andb_prop _ _ H3); intros.
     cut (e0 = e2). cut (e1 = e3). intros. rewrite H4; rewrite H6. auto.
      apply H0. assumption. apply H. assumption.
      clear H1 H2. elim (andb_prop _ _ H3); intros.
    cut (e0 = e2). cut (e1 = e3). intros. rewrite H4; rewrite H6. auto.
     apply H0. assumption. apply H. assumption.
     clear H0. elim (andb_prop _ _ H1); intros.
   cut (u = u0). cut (e0 = e1). intros. rewrite H4. rewrite H5. auto.
    apply H. assumption. apply eq_nat_corr. assumption.
    clear H1 H2. elim (andb_prop _ _ H3). intros. elim (andb_prop _ _ H2); intros.
  cut (b = b0). cut (e0 = e2). cut (e1 = e3).
   intros. rewrite H7. rewrite H8. rewrite H9. auto.
     auto. auto. apply eq_nat_corr. assumption.
   clear H0. elim (andb_prop _ _ H1); intros.
 cut (p = p0). cut (e0 = e1). intros. rewrite H4. rewrite H5. auto.
  auto. apply eq_nat_corr. assumption.
Qed.

End Correctness_Results.

Ltac ClosedNat t :=
match t with
| O => constr:(true)
| (S ?n) => ClosedNat n
| _ => constr:(false)
end.

Ltac ClosedPositive t :=
match t with
| xH => constr:(true)
| (xI ?n) => ClosedPositive n
| (xO ?n) => ClosedPositive n
| _ => constr:(false)
end.

Ltac ClosedZ t :=
match t with
| Z0 => constr:(true)
| (Zpos ?n) => ClosedPositive n
| (Zneg ?n) => ClosedPositive n
| _ => constr:(false)
end.

(*To prevent universe inconsitencies, we need lists at a higher
type level than the one provided in algebra/ListType *)

Section MetaList.

Variable A : Type.

Inductive metalist : Type :=
  | Mnil : metalist
  | Mcons : A -> metalist -> metalist.

Fixpoint Mnth (n:nat) (l:metalist) (default:A) {struct l} : A :=
  match n, l with
  | O, Mcons x l' => x
  | O, other => default
  | S m, Mnil => default
  | S m, Mcons x t => Mnth m t default
  end.

End MetaList.
Arguments Mcons [A].
Arguments Mnth [A].

Ltac FindIndex t l :=
match l with
| (Mcons ?x ?xs) =>
  match x with
  | t => constr:(O)
  | _ => let n := FindIndex t xs in constr:(S n)
  end
end.

(*To prevent universe inconsitencies, we define quadruple,
rather than using the ProdT multiple times *)

Section Quadruple.
Variable A B C D: Type.

Inductive quadruple : Type :=
 Quad : A -> B -> C -> D -> quadruple.
End Quadruple.
Arguments Quad [A B C D].

(* end hide *)


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

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.
Require Import Program.

Require Import LensLaws.Isomorphism.
Require Import LensLaws.Crush.
Require Import LensLaws.Lens.
Require Import LensLaws.Prism.

(* Affine Traversal *)
Definition Affine (A B : Set) : Type := { XY : prod Set Set & Iso A (fst XY + (snd XY * B)) }.

Lemma lens_is_affine {A B} (lens : Lens A B) : Affine A B.
Proof.
  destruct lens as [X i].
  exists (pair Empty_set X). simpl.
  apply iso_is_prism_ex. apply i. Defined.

Lemma iso_right {A B X : Set} (i : Iso A B) : Iso (X + A) (X + B).
Proof.
  destruct i as [f g H H0].

  assert (sum X A -> sum X B) as xaxb.
  apply (fun xa =>
    match xa with
    | inl x => inl x
    | inr a => inr (f a)
    end).
  assert (sum X B -> sum X A) as xbxa.
  apply (fun xb =>
    match xb with
    | inl x => inl x
    | inr b => inr (g b)
    end).

  apply (@MkIso (X + A) (X + B)
    (fun xa =>
      match xa with
      | inl x => inl x
      | inr a => inr (f a)
      end)
    (fun xb =>
      match xb with
      | inl x => inl x
      | inr b => inr (g b)
      end)); crush. Defined.

Lemma prism_is_affine {A B} (prism : Prism A B) : Affine A B.
Proof.
  destruct prism as [X i].
  exists (pair X unit). simpl.

  destruct i as [f g H H0].

  assert (A -> X + unit * B).
  refine (fun a =>
    match f a with
    | inl x => inl x
    | inr b => inr (pair tt b)
    end).
  assert (X + unit * B -> A).
  refine (fun xub =>
    g (match xub with
    | inl x => inl x
    | inr ub => inr (snd ub)
    end)).

  apply (MkIso
    (fun a =>
      match f a with
      | inl x => inl x
      | inr b => inr (pair tt b)
      end)
    (fun xub =>
      g (match xub with
      | inl x => inl x
      | inr ub => inr (snd ub)
      end))); crush. Defined.

Lemma prism_lens_compose {A B C} (ab : Prism A B) (bc : Lens B C) : Affine A C.
Proof.
  destruct ab as [X ab]. destruct ab as [axb xba H H0].
  destruct bc as [Y bc]. destruct bc as [byc ycb H1 H2].
  exists (pair X Y); simpl.

  assert (A -> X + Y * C).
  refine
    (fun a =>
      match axb a with
      | inl x => inl x
      | inr b => inr (byc b)
      end).

  assert (X + Y * C -> A).
  refine
    (fun xyc =>
      match xyc with
      | inl x => xba (inl x)
      | inr yc => xba (inr (ycb yc))
      end).

  apply (MkIso
    (fun a =>
      match axb a with
      | inl x => inl x
      | inr b => inr (byc b)
      end)
    (fun xyc =>
      match xyc with
      | inl x => xba (inl x)
      | inr yc => xba (inr (ycb yc))
      end)); crush. Defined.

Lemma lens_prism_compose {A B C} (ab : Lens A B) (bc : Prism B C) : Affine A C.
Proof.
  destruct ab as [X ab]. destruct ab as [axb xba H H0].
  destruct bc as [Y bc]. destruct bc as [byc ycb H1 H2].

  exists (pair (prod X Y) X); simpl.

  assert (A -> X * Y + X * C).
  refine
    (fun a =>
       match axb a with
       | (x, b) =>
         match byc b with
         | inl y => inl (pair x y)
         | inr c => inr (pair x c)
         end
       end).

  assert (X * Y + X * C -> A).
  refine
    (fun xyxc =>
      match xyxc with
      | inl (x, y) => xba (x, ycb (inl y))
      | inr (x, c) => xba (x, ycb (inr c))
      end).

  apply (MkIso
    (fun a =>
       match axb a with
       | (x, b) =>
         match byc b with
         | inl y => inl (pair x y)
         | inr c => inr (pair x c)
         end
       end)
    (fun xyxc =>
      match xyxc with
      | inl (x, y) => xba (x, ycb (inl y))
      | inr (x, c) => xba (x, ycb (inr c))
      end)); crush. Defined.

Lemma affine_compose {A B C} (ab : Affine A B) (bc : Affine B C) : Affine A C.
Proof.
  destruct ab as [XY ab]. destruct XY as [X Y]. destruct ab as [axyb xyba H H0].
  destruct bc as [UV bc]. destruct UV as [U V]. destruct bc as [buvc uvcb H1 H2].
  unfold IsInverse in *.
  simpl in *.
  exists (pair (sum X (prod Y U)) (prod Y V)); simpl.

  assert (A -> X + Y * U + Y * V * C).
  refine
    (fun a =>
      match axyb a with
      | inl x          => inl (inl x)
      | inr (pair y b) =>
        match buvc b with
        | inl u          => inl (inr (pair y u))
        | inr (pair v c) => inr (y, v, c)
        end
      end).

  assert (X + Y * U + Y * V * C -> A).
  refine
    (fun xyuvyc =>
       match xyuvyc with
       | inl (inl x)          => xyba (inl x)
       | inl (inr (pair y u)) => xyba (inr (pair y (uvcb (inl u))))
       | inr (y, v, c)        => xyba (inr (pair y (uvcb (inr (pair v c)))))
       end).

  apply (MkIso
    (fun a =>
      match axyb a with
      | inl x          => inl (inl x)
      | inr (pair y b) =>
        match buvc b with
        | inl u          => inl (inr (pair y u))
        | inr (pair v c) => inr (y, v, c)
        end
      end)
    (fun xyuvyc =>
       match xyuvyc with
       | inl (inl x)          => xyba (inl x)
       | inl (inr (pair y u)) => xyba (inr (pair y (uvcb (inl u))))
       | inr (y, v, c)        => xyba (inr (pair y (uvcb (inr (pair v c)))))
       end)); crush. Qed.

Definition affine_preview {A B} (affine : Affine A B) (a : A) : option B.
Proof.
  destruct affine as [XY ab]. destruct XY as [X Y]. destruct ab as [ayb bya _ _].
  destruct (ayb a) as [x | yb].
  - exact None.
  - exact (Some (snd yb)). Defined.

Definition affine_set {A B} (affine : Affine A B) (a : A) (b : B) : A.
Proof.
  destruct affine as [XY ab]. destruct XY as [X Y]. destruct ab as [ayb bya _ _].
  simpl in *.
  refine (match ayb a with
  | inl x          => bya (inl x)
  | inr (pair y _) => bya (inr (pair y b))
  end). Defined.

Definition option_const_map {A B} (a : A) (b : option B) : option A :=
  match b with
  | None   => None
  | Some _ => Some a
  end.

(* Is this right collection of laws? *)
Theorem affine_law1 {A B} (affine : Affine A B) :
  forall a b, affine_preview affine (affine_set affine a b) = option_const_map b (affine_preview affine a).
Proof.
  intros a b.
  destruct affine as [XY ab]. destruct ab as [ayb bya H H0]. simpl in *. destruct XY as [X Y]. simpl in *.
  remember (ayb a) as x. destruct x.
  - rewrite <- H0. reflexivity.
  - destruct p. rewrite <- H0. reflexivity. Qed.

Theorem affine_law2 {A B} (affine : Affine A B) :
  forall a b, affine_preview affine a = Some b -> affine_set affine a b = a.
Proof.
  intros a b Hsome.
  destruct affine as [XY ab]. destruct ab as [ayb bya H H0].
  crush. Qed.

Theorem affine_law3 {A B} (affine : Affine A B) :
  forall a b, affine_preview affine a = None -> affine_set affine a b = a.
Proof.
  intros a b Hsome.
  destruct affine as [XY ab]. destruct ab as [ayb bya H H0]. simpl in *. destruct XY as [X Y]. simpl in *.
  remember (ayb a) as x. destruct x.
  - crush.
  - inversion Hsome. Qed.

Theorem affine_law4 {A B} (affine : Affine A B) :
  forall a b b', affine_set affine (affine_set affine a b') b = affine_set affine a b.
Proof.
  intros a b b'.
  destruct affine as [XY ab]. destruct ab as [ayb bya H H0]. simpl. destruct XY as [X Y].
  destruct (ayb a); crush. Qed.

Theorem affine_complete {A B : Set} (preview : A -> option B) (set : A -> B -> A) :
  (forall a b, preview (set a b) = option_const_map b (preview a)) ->
  (forall a b, preview a = Some b -> set a b = a) ->
  (forall a b, preview a = None   -> set a b = a) ->
  (forall a b b', set (set a b) b' = set a b') ->
  Affine A B.
Proof.
  intros law1 law2 _ law4.

  set (X := { a : A | None = preview a }).
  set (Y := { ba : B -> A | exists (a : A), ba = set a /\ (exists (b : B), Some b = preview a) }). (* Maybe we need more here? *)

  exists (pair X Y). simpl.

  (*

  assert (FWD_test: A -> X + Y * B).
  refine (fun (a : A) =>
    let pa := preview a in
    let Heqpa := eq_refl : pa = preview a in
    (match pa as pa0 return (pa0 = preview a -> X + Y * B) with
      | None   => fun proof => inl (exist _ a proof)
      | Some b => fun proof => inr (pair (exist _ (set a) (ex_intro (fun x => set a = set x /\ (exists (b : B), Some b = preview x) ) a (conj eq_refl (ex_intro _ b proof)))) b)
      end) Heqpa).

  assert (BWD_test: X + Y * B -> A).
  refine (fun (p : X + Y * B) => match p with
    | inl (exist _ a _)           => a
    | inr (pair (exist _ ba _) b) => ba b
    end).

  *)

  set (FWD := fun (a : A) =>
    let pa := preview a in
    let Heqpa := eq_refl : pa = preview a in
    (match pa as pa0 return (pa0 = preview a -> X + Y * B) with
      | None   => fun proof => inl (exist _ a proof)
      | Some b => fun proof => inr (pair (exist _ (set a) (ex_intro (fun x => set a = set x /\ (exists (b : B), Some b = preview x) ) a (conj eq_refl (ex_intro _ b proof)))) b)
      end) Heqpa).

  set (BWD := (fun (p : X + Y * B) => match p with
    | inl (exist _ a _)           => a
    | inr (pair (exist _ ba _) b) => ba b
    end)).

  apply (MkIso FWD BWD); subst FWD; subst BWD.

  - intro a.
    set (Rw := dependentMatchOfMatch (fun o => o = preview a) A (preview a) eq_refl).
    rewrite Rw.
    clear Rw.
    remember (preview a) as pa. destruct pa.
    + symmetry. apply law2. symmetry. apply Heqpa.
    + reflexivity.
  - intro xyb. simpl. destruct xyb as [x | yb].
    + destruct x as [ a Hnone ].
      set (Lem2 := lem2_None (X + Y * B) (preview a)            Hnone). rewrite Lem2. reflexivity.
    + destruct yb as [ y b ]. destruct y as [ ba HBa]. destruct HBa as [a Hba]. destruct Hba as [Hba HSome]. destruct HSome as [b' HSome].
      rewrite Hba. clear Hba; clear ba.

      (* Helper statement using law1 *)
      assert (H : Some b = preview (set a b)).
      rewrite law1. rewrite <- HSome. simpl. reflexivity.

      set (Lem2 := lem2_Some (X + Y * B) (preview (set a b)) b H).      rewrite Lem2. clear Lem2.
      f_equal. f_equal.
      assert (set a = set (set a b)) as Hsetset.
      extensionality b0. symmetry. apply law4.
      apply sigma_eq with (eqp := Hsetset).
      apply proof_irrelevance. Qed.


(* Simple let-patterns *)
Variable A B : Type.

Definition l1 (t : A * B * B) : A := let '(x, y, z) := t in x.
Print l1.
Definition l2 (t : (A * B) * B) : A := let '((x, y), z) := t in x.
Definition l3 (t : A * (B * B)) : A := let '(x, (y, z)) := t in x.
Print l3.

Record someT (A : Type) := mkT { a : nat; b: A }.

Definition l4 A (t : someT A) : nat := let 'mkT _ x y := t in x.
Print l4.
Print sigT.

Definition l5 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
  let 'existT _ x y := t return B (projT1 t) in y.

Definition l6 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
  let 'existT _ x y as t' := t return B (projT1 t') in y.

Definition l7 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
  let 'existT _ x y as t' in sigT _ := t return B (projT1 t') in y.

Definition l8 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
  match t with
    existT _ x y => y
  end.

(** An example from algebra, using let' and inference of return clauses
   to deconstruct contexts. *)

Record a_category (A : Type) (hom : A -> A -> Type) := {  }.

Definition category := { A : Type & { hom : A -> A -> Type & a_category A hom } }.

Record a_functor (A : Type) (hom : A -> A -> Type) (C : a_category A hom) := {  }.

Notation " x :& y " := (@existT _ _ x y) (right associativity, at level 55) : core_scope.

Definition functor (c d : category) :=
  let ' A :& homA :& CA := c in
  let ' B :& homB :& CB := d in
    A -> B.

Definition identity_functor (c : category) : functor c c :=
  let 'A :& homA :& CA := c in
    fun x => x.

Definition functor_composition (a b c : category) : functor a b -> functor b c -> functor a c :=
  let 'A :& homA :& CA := a in
  let 'B :& homB :& CB := b in
  let 'C :& homB :& CB := c in
    fun f g =>
      fun x => g (f x).


(**************************************************************************
* TLC: A library for Coq                                                  *
* Reflection : Basic Operations on Booleans                               *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibOperation.

(* ********************************************************************** *)
(** * Properties of the boolean type *)

(* ---------------------------------------------------------------------- *)
(** ** Inhabited *)

Instance bool_inhab : Inhab bool.
Proof. constructor. apply (prove_Inhab true). Qed.

(** For [Extensional bool] and [Comparable bool], see file LibReflect:
    These results are not in [LibBool] because they depend on definition
    from [LibReflect], which itself depends on [LibBool]. *)

(* ********************************************************************** *)
(** * Boolean Operations *)

(* TODO: is it possible to reuse the definition from the library?
   It might be possible, but it requires to fix several proofs *)

Section Definitions.
Implicit Types x y z : bool.

(** ** Comparison *)

Definition beq_impl x y :=
  match x, y with
  | true, true => true
  | false, false => true
  | _, _ => false
  end.

(** Conjunction *)

Definition and x y :=
  match x, y with
  | true, true => true
  | _, _ => false
  end.

(** Disjunction *)

Definition or x y :=
  match x, y with
  | false, false => false
  | _, _ => true
  end.

(** Implication *)

Definition impl x y :=
  match x, y with
  | false, true => false
  | _, _ => true
  end.

(** Negation *)

Definition neg x :=
  match x with
  | true => false
  | false => true
  end.

(** Exclusive or*)

Definition xor x y :=
  x <> y.

End Definitions.

(** Notations *)

Notation "! x" := (neg x)
  (at level 35, right associativity) : Bool_scope.
Infix "&&" := and
  (at level 40, left associativity) : Bool_scope.
Infix "||" := or
  (at level 50, left associativity) : Bool_scope.

Notation "! x" := (neg x)
  (at level 35, right associativity) : Bool_scope.
Infix "&&" := and
  (at level 40, left associativity) : Bool_scope.
Infix "||" := or
  (at level 50, left associativity) : Bool_scope.

Infix "&&&" := and
  (at level 40, left associativity, only parsing) : Bool_scope.
Infix "|||" := or
  (at level 50, left associativity, only parsing) : Bool_scope.
  (* todo: understand why there is a bug on the && *)

Bind Scope Bool_scope with bool.
Open Scope Bool_scope.

(* ********************************************************************** *)
(** * Boolean Decision Procedure : tactic working by exponential case
      analysis on all variables of type bool. *)

(* ---------------------------------------------------------------------- *)
(** ** A first simple tactic named [tautob]. *)

Tactic Notation "tautob" :=
  let rec go _ :=
    (try intros_all); match goal with
    | b : bool |- _ => destruct b; clear b; go tt
    | _ => simpls; try split; intros; try discriminate
    end in go tt.

Tactic Notation "tautob" "~" :=
   tautob; auto.
Tactic Notation "tautob" "*" :=
   tautob; auto*.

(* ********************************************************************** *)
(** * Properties of booleans *)

(* ---------------------------------------------------------------------- *)
(** ** Properties of [and], [or] and [neg] *)

(* todo: rename those lemmas according to convention (e.g. and_neutral_l) *)

Lemma or_same : idempotent2 or.
Proof. tautob~. Qed.

Lemma and_same : idempotent2 and.
Proof. tautob~. Qed.

Lemma neutral_l_and : neutral_l and true.
Proof. tautob~. Qed.

Lemma neutral_r_and : neutral_r and true.
Proof. tautob~. Qed.

Lemma absorb_l_and : absorb_l and false.
Proof. tautob~. Qed.

Lemma absorb_r_and : absorb_r and false.
Proof. tautob~. Qed.

Lemma neutral_l_or : neutral_l or false.
Proof. tautob~. Qed.

Lemma neutral_r_or : neutral_r or false.
Proof. tautob~. Qed.

Lemma absorb_l_or : absorb_l or true.
Proof. tautob~. Qed.

Lemma absorb_r_or : absorb_r or true.
Proof. tautob~. Qed.

Lemma comm_or : comm or.
Proof. tautob~. Qed.

Lemma comm_and : comm and.
Proof. tautob~. Qed.

Lemma assoc_and : assoc and.
Proof. tautob*. Qed.

Lemma assoc_or : assoc or.
Proof. tautob*. Qed.

Lemma neg_false : ! false = true.
Proof. auto. Qed.

Lemma neg_true : ! true = false.
Proof. auto. Qed.

Lemma neg_and : @automorphism bool neg and or.
Proof. tautob~. Qed.

Lemma neg_or : @automorphism bool neg or and.
Proof. tautob~. Qed.

Lemma neg_neg : idempotent neg.
Proof. tautob~. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties of [if then else] *)

Section PropertiesIf.

Implicit Types x y z : bool.

Lemma if_t_x_y : forall x y,
  (if true then x else y) = x.
Proof. auto. Qed.

Lemma if_f_x_y : forall x y,
  (if false then x else y) = y.
Proof. auto. Qed.

Lemma if_x_y_y : forall x y,
  (if x then y else y) = y.
Proof. tautob~. Qed.

Lemma if_x_t_f : forall x,
  (if x then true else false) = x.
Proof. tautob~. Qed.

Lemma if_x_f_t : forall x,
  (if x then false else true) = !x.
Proof. tautob~. Qed.

Lemma if_x_t_y : forall x y,
  (if x then true else y) = x || y.
Proof. tautob~. Qed.

Lemma if_x_y_f : forall x y,
  (if x then y else false) = x && y.
Proof. tautob~. Qed.

End PropertiesIf.

(* ********************************************************************** *)
(** * Tactics *)

(** [fix_neg_neg] is a tactic that simplifies all double negations. *)

Hint Rewrite neg_neg : rew_neg_neg.
Tactic Notation "fix_neg_neg" :=
  autorewrite with rew_neg_neg in *.
Tactic Notation "fix_neg_neg" "~" :=
  fix_neg_neg; auto_tilde.
Tactic Notation "fix_neg_neg" "*" :=
  fix_neg_neg; auto_star.

(** [rew_bool] simplifies boolean expressions, using rewriting
    lemmas in the database [rew_bool] defined below. *)

Hint Rewrite
  neg_false neg_true neg_neg neg_and neg_or
  neutral_l_and neutral_r_and absorb_l_and absorb_r_and
  neutral_l_or neutral_r_or absorb_l_or absorb_r_or
  if_t_x_y if_f_x_y if_x_y_y if_x_t_f if_x_f_t if_x_t_y if_x_y_f
  : bool_rew.

Tactic Notation "rew_bool" :=
  autorewrite with bool_rew.
Tactic Notation "rew_bool" "in" hyp(H) :=
  autorewrite with bool_rew in H.
Tactic Notation "rew_bool" "in" "*":=
  autorewrite with bool_rew in *.
Tactic Notation "rew_bool" "~" :=
  rew_bool; auto~.
Tactic Notation "rew_bool" "*" :=
  rew_bool; auto*.
Tactic Notation "rew_bool" "~" "in" "*":=
  rew_bool in *; auto~.
Tactic Notation "rew_bool" "*" "in" "*":=
  rew_bool in *; auto*.

(** Making definitions opaque ensures that the [simpl] tactic does
    not break symmetry in proofs. *)

Opaque and or neg.


Require Import NPeano.
Require Import List.
Require Export ucp.
Require Export logic.
Require Export nat_facts.

Lemma eq_bool_dec : forall a b : bool, {a=b}+{a<>b}. decide equality. Qed.

Lemma remove_corr_neq :
  forall A dec (l : list A) a b,
    a <> b ->
    (In b l <->
     In b (remove dec a l)).
Proof.
  induction l. simpl. intros. split; intro; assumption.
  rename a into h. intros. rename H into aneb. split; [ intro binhl | intro binrahl ].
  - simpl in binhl. destruct binhl.
    + subst. simpl. destruct (dec a b). elim aneb. assumption.
      simpl. left. reflexivity.
    + simpl. destruct (dec a h).
      * subst. apply IHl; assumption.
      * simpl. destruct (dec h b). left. assumption.
        right. apply IHl; assumption.
  - simpl in *. destruct (dec a h).
    + subst. right. rewrite <- IHl in binrahl; assumption.
    + destruct (dec h b). left. assumption.
      right. simpl in *. destruct binrahl. elim n0. assumption.
      rewrite <- IHl in H; assumption.
Qed.

Lemma rmnothing :
  forall A dec l (a : A),
    ~In a l ->
    l = remove dec a l.
Proof.
  induction l. reflexivity.
  intros b nin. simpl in *. rewrite demorgan1 in nin. destruct nin as [ aneb bninl ].
  destruct (dec b a) as [ beqa | bnea ].
  - rewrite beqa in *. elim aneb. reflexivity.
  - rewrite <- IHl. reflexivity. assumption.
Qed.

Ltac innil := match goal with H: In _ nil |- _ => simpl in H; contradiction H end.
Ltac xneqx := match goal with H: ?x <> ?x |- _ => elim H; reflexivity end.

Lemma Inremoveidem :
  forall A dec (l : list A) a b,
    ~In a l ->
    ~In a (remove dec b l).
Proof.
  intros. intro.
  elim H. clear H.
  rename H0 into ainrbl.
  destruct (inb dec b l) eqn:binlres.
  - destruct (dec a b). subst. elim (remove_In dec l b). assumption.
    clear binlres. revert a b ainrbl n. induction l. simpl. intros. assumption.
    rename a into h. intros.
    simpl in *. destruct (dec b h) as [ beqh | bneh ].
    + right. subst. apply (IHl a h); auto.
    + destruct (dec h a). left. assumption.
      right. apply (IHl a b); auto.
      simpl in ainrbl. destruct ainrbl; auto.
      elim n0. assumption.
  - assert (forall b, b = false -> b <> true). clear. intros. destruct b. discriminate. intro. discriminate.
    assert (binlres' := H _ binlres).
    rewrite inbeqIn in binlres'.
    rewrite <- rmnothing in ainrbl; auto.
Qed.

Lemma setrm :
  forall A dec (l : list A),
    is_set dec l = true ->
    (forall a, is_set dec (remove dec a l) = true).
Proof.
  induction l as [ | h l ]. simpl. reflexivity.
  intros set a. destruct (settail _ _ _ _ set) as [ lset hninl ]. clear set. simpl.
  assert (Hx := IHl lset). clear IHl. rename Hx into IHl.
  destruct (dec a h) as [ aeqh | aneh ].
  - subst. apply IHl.
  - simpl. rewrite IHl. clear IHl.
    destruct (inb dec h (remove _ _ _)) eqn:hinralres.
    + elim (Inremoveidem _ dec l h a hninl).
      rewrite inbeqIn in hinralres.
      assumption.
    + reflexivity.
Qed.

Lemma lrm :
  forall A dec (l : list A),
    is_set dec l = true ->
    forall x, In x l ->
    length l = S (length (remove dec x l)).
Proof.
  induction l. intros _ x innil. simpl in innil. contradiction innil.
  intros set x inal.
  destruct (settail _ _ _ _ set) as [ tset ninl ]. clear set.
  simpl in inal. destruct inal as [ aeqx | inl ].
  - rewrite aeqx in *. clear aeqx a.
    simpl.
    destruct (dec x x) as [ _ | xnex ]; [ | elim xnex; reflexivity ].
    assert (rmidem := rmnothing _ dec l x ninl).
    rewrite <- rmidem in *. reflexivity.
  - simpl.
    destruct (dec x a) as [ xeqa | xnea ].
    + rewrite xeqa in *. clear xeqa x. elim ninl. apply inl.
    + simpl in *.
      assert (indhyp := IHl tset x inl).
      rewrite indhyp. reflexivity.
Qed.

Lemma remove_assoc :
  forall A dec (l : list A) a b,
    remove dec a (remove dec b l) = remove dec b (remove dec a l).
Proof.
  induction l. simpl. reflexivity.
  rename a into h.
  intros a b.
  simpl.
  destruct (dec b h); destruct (dec a h); subst; try rewrite IHl; try reflexivity; simpl;
  destruct (dec h h); try reflexivity; try match goal with H: ?x <> ?x |- _ => elim H; reflexivity end.
  destruct (dec b h); destruct (dec a h); subst; try rewrite IHl; try reflexivity; simpl. elim n. reflexivity.
  elim n0. reflexivity.
Qed.

Lemma removetwo :
  forall A eq_dec (l : list A),
    is_set eq_dec l = true ->
    (forall a,
       In a l ->
       (forall b rbral,
          rbral = remove eq_dec b (remove eq_dec a l) ->
          if eq_dec a b
          then length l = S (length rbral)
          else if inb eq_dec b l
               then length l = S (S (length rbral))
               else length l = S (length rbral)
       )
    ).
Proof.
  intros A dec l set a ainl b rbral rbraldef.
  destruct (dec a b) as [ aeqb | aneb ].
  - subst.
    assert (lenrbrbl := lrm _ _ _ set _ ainl).
    assert (bnilrbl := remove_In dec l b).
    assert (leqrbl := rmnothing _ dec _ _ bnilrbl).
    rewrite <- leqrbl.
    assumption.
  - destruct (inb dec b l) eqn:binl.
    + assert (lenral := lrm _ _ _ set _ ainl).
      assert (ralset := setrm A dec l set a).
      rewrite inbeqIn in binl.
      generalize binl; intro binral.
      rewrite (remove_corr_neq _ dec l _ _ aneb) in binral.
      assert (lenrbral := lrm _ _ _ ralset _ binral).
      rewrite lenrbral in lenral.
      rewrite rbraldef.
      apply lenral.
    + rewrite rbraldef in *. clear rbral rbraldef.
      rewrite inbeqInnot in binl.
      assert (bninral := Inremoveidem _ dec l _ a binl).
      assert (raleqrbral := rmnothing _ dec _ _ bninral).
      rewrite <- raleqrbral.
      apply lrm; auto.
Qed.

Lemma removepairs :
  forall A eq_dec (l : list A) (pair : A -> A),
    is_set eq_dec l = true ->
    (forall a, In a l -> In (pair a) l) ->
    (forall a,
       In a l ->
       (forall rbral,
          rbral = remove eq_dec (pair a) (remove eq_dec a l) ->
          if eq_dec a (pair a)
          then length l = S (length rbral)
          else length l = S (S (length rbral))
       )
    ).
Proof.
  intros A eq_dec l pair set pairIn a ainl rbral rbraleq.
  assert (Hx := removetwo _ eq_dec l set a ainl (pair a) rbral rbraleq).
  destruct (eq_dec a (pair a)) as [ aeqpa | anepa ].
  - assumption.
  - destruct (inb eq_dec (pair a) l) eqn:inres.
    + assumption.
    + assert (Hy := pairIn _ ainl).
      rewrite inbeqInnot in inres. elim inres. assumption.
Qed.

Lemma setrmhd :
  forall A eq_dec (a : A) l,
    is_set eq_dec (a::l) = true ->
    remove eq_dec a (a::l) = l.
Proof.
  intros.
  destruct (settail _ _ _ _ H) as [ lset aninl ].
  simpl. destruct (eq_dec a a). rewrite <- (rmnothing). reflexivity. assumption.
  elim n. reflexivity.
Qed.

Lemma list_eo_ind :
  forall A (P : list A -> Prop),
    P nil ->
    (forall a, P (a::nil)) ->
    (forall a b l, P l -> P (a::b::l)) ->
    forall l, P l.
Proof.
  intros. destruct l. assumption.
  assert (P l /\ P (a::l)).
  revert a. induction l.
  - intros. split. assumption. apply H0.
  - intros. destruct (IHl a). split. assumption.
    apply H1; assumption.
  - destruct H2. assumption.
Qed.

Lemma setsigeq :
  forall A eq_dec (P : {l : list A | is_set eq_dec l = true} -> Prop) lx ly,
    lx = ly ->
    (forall py px, P (exist _ lx px) = P (exist _ ly py)).
Proof.
  intros. subst. assert (px = py). apply (@Eqdep_dec.UIP_dec _ eq_bool_dec _ _).
  rewrite H. reflexivity.
Qed.

Lemma set_ind :
  forall A eq_dec (P : {l | is_set eq_dec l = true} -> Prop),
    (forall nilpf, P (exist _ nil nilpf)) ->
    (forall (a : A) lpf ralpf, P (exist _ (remove eq_dec a (proj1_sig lpf)) ralpf) -> P lpf) ->
    forall l, P l.
Proof.
  intros. destruct l as [ l set ].
  induction l. apply H.
  assert (Hset := setrm A eq_dec (a::l) set a).
  apply (H0 a (exist _ (a::l) set) Hset).
  destruct (settail _ _ _ _ set) as [ lset aninl ].
  assert (raaleql := setrmhd _ _ _ _ set).
  rewrite (setsigeq _ _ P (remove eq_dec a (a::l)) l raaleql lset).
  apply IHl.
Qed.

Lemma set_eo_ind :
  forall A eq_dec (P : {l | is_set eq_dec l = true} -> Prop),
    (forall nilpf, P (exist _ nil nilpf)) ->
    (forall a opf, P (exist _ (a::nil) opf)) ->
    (forall (a b : A) lpf rarblpf, P (exist _ (remove eq_dec b (remove eq_dec a (proj1_sig lpf))) rarblpf) -> P lpf) ->
    forall l, P l.
Proof.
  intros. destruct l as [ l lset ].
  destruct l. apply H.
  rename lset into alset.
  assert (lset := setrm A eq_dec (a::l) alset a).
  destruct (settail A eq_dec l a alset) as [ lset' aninl ].
  cut (P (exist _ _ lset') /\ P (exist _ _ alset)). intro. destruct H2. assumption.
  revert a alset lset aninl lset'. induction l. intros. split; auto.
  intros.
  destruct (settail _ _ _ _ alset) as [ alset' a0ninal ].
  assert (Hxxx := setrm _ _ _ lset' a).
  destruct (settail _ _ _ _ lset').
  destruct (IHl a lset' Hxxx H3 H2). split; auto.
  assert (Hxxxx := H1 a0 a (exist _ _ alset)).
  cbv beta in Hxxxx. unfold proj1_sig in Hxxxx.
  assert (is_set eq_dec (remove eq_dec a (remove eq_dec a0 (a0 :: a :: l))) = true) as setrara0aa0l.
    rewrite setrmhd; auto.
  apply (Hxxxx setrara0aa0l).
  assert (Hx := setsigeq A eq_dec P l (remove eq_dec a (remove eq_dec a0 (a0 :: a :: l)))).
  rewrite <- Hx with (px := H2). assumption.
  repeat rewrite setrmhd; auto.
Qed.

Definition eq_dec_t A := forall a b : A, {a=b}+{a<>b}.
Definition eq_pair_dec {A B} (deca : eq_dec_t A) (decb : eq_dec_t B) : forall a b : A * B, {a=b}+{a<>b}. decide equality. Defined.

Definition sig2sig A (P Q : A -> Prop) (impl : forall a : A, P a -> Q a) (x : {x | P x}) : {x | Q x} := exist _ (proj1_sig x) (impl _ (proj2_sig x)).

Lemma sig2sigp1 :
  forall A P Q impl l,
    map (@proj1_sig _ _) l = map (@proj1_sig _ _) (map (sig2sig A P Q impl) l).
Proof.
  intros. induction l.
  simpl. reflexivity.
  simpl. destruct a. simpl. apply f_equal2; [ reflexivity | assumption ].
Qed.

Definition redundant_list A (l : list A) : {lx : list {x | In x l} | map (@proj1_sig _ _) lx = l}.
Proof.
  induction l. exists nil. simpl. reflexivity.
  assert (forall x, In x l -> In x (a::l)). intros. simpl. right. assumption.
  destruct IHl.
  assert (In a (a::l)). simpl. left. reflexivity.
  refine (exist _ ((exist _ a H0)::(map (sig2sig _ _ _ H) x)) _).
  simpl. apply f_equal2; [ reflexivity | ].
  rewrite <- sig2sigp1. assumption.
Defined.

Lemma redundant_list_len :
  forall A (l : list A),
    length l = length (proj1_sig (redundant_list _ l)).
Proof.
  intros. destruct (redundant_list A l). simpl.
  rewrite <- e at 1. rewrite map_length. reflexivity.
Qed.

Lemma nesigne :
  forall A P (a b : {x : A | P x}), proj1_sig a <> proj1_sig b -> a <> b.
Proof.
  intros. intro. destruct a. destruct b. simpl in *. elim H.
  injection H0. intro. assumption.
Qed.

Lemma eqsigeq :
  forall A P (a b : {x : A | P x}) (irrelev : forall a (p1 p2 : P a), p1 = p2), proj1_sig a = proj1_sig b -> a = b.
Proof.
  intros. destruct a, b. simpl in *. subst. assert (Hx := irrelev x0 p p0). rewrite Hx. reflexivity.
Qed.

Lemma inlinsigl :
  forall A (P : A -> Prop) (pi : forall a (p1 p2 : P a), p1 = p2) (a : A) (l : list {x : A | P x}),
    In a (map (@proj1_sig _ _) l) ->
    (forall pf : P a, In (exist _ a pf) l).
Proof.
  intros. rename H into ainl. rename l into sigl.
  induction sigl. simpl in *. assumption.
  simpl. simpl in ainl. destruct ainl.
  - left. destruct a0. simpl in *. subst.
    rewrite (pi a p pf). reflexivity.
  - right. apply IHsigl. assumption.
Qed.

Ltac ainral := match goal with H : In ?a (remove ?dec ?a ?l) |- _ => elim (remove_In dec l a); assumption end.
Ltac ainrbl := match goal with
                   H : In ?a (remove ?f ?b ?l), aneb: ?a <> ?b |- _ =>
                   let Hx := fresh in
                   assert (Hx := remove_corr_neq _ f l _ _ (neqflip _ _ _ aneb));
                     rewrite <- Hx in H; clear Hx
               end.

Tactic Notation "mysimp" :=
  idtac "mysimp no arguments".

Tactic Notation "mysimp" "in" ident(x) :=
  idtac "mysimp called on" x.

Tactic Notation "mysimp" "in" "*" :=
  idtac "mysimp called on *".

Ltac eqneq := match goal with H : ?a = ?b, HH : ?a <> ?b |- _ => elim HH; assumption
                           | H: ?a = ?b, HH : ?b <> ?a |- _ => elim HH; rewrite H; reflexivity
              end.

Ltac neqneq := match goal with H : ?a <> ?b |- ?b <> ?a => let Hx := fresh in
                                                           intro Hx; rewrite Hx in H; elim H; reflexivity
               end.

Definition paired_list {A} (pair : A -> A) l := forall a, In a l -> In (pair a) l.

Lemma paired_not_1 :
  forall
    A
    (pair_not_id : {pair | forall a, a <> pair a})
    (l : {l : list A | paired_list (proj1_sig pair_not_id) l}),
    length (proj1_sig l) <> 1.
Proof.
  intros A [pair nid] [l pf] l1.
  simpl in *.
  destruct l; [ discriminate | ].
  destruct l; [ | discriminate ].
  clear l1. unfold paired_list in pf.
  specialize pf with a.
  assert (In a (a::nil)) as aina. unfold In. left. reflexivity.
  assert (Hx := pf aina). clear pf. rename Hx into pf.
  simpl in pf. destruct pf; [ | assumption ].
  elim (nid a). assumption.
Qed.

Lemma removepairs_still_paired :
  forall
    A
    eq_dec
    (pair_involutive : {pair | forall a b : A, a <> b -> pair a <> b -> a <> pair b})
    (l_paired : {l | paired_list (proj1_sig pair_involutive) l}),
    (forall a,
       let pair := proj1_sig pair_involutive in
       paired_list pair (remove eq_dec (pair a) (remove eq_dec a (proj1_sig l_paired)))
    ).
Proof.
  intros A eq_dec [ pair pair_dis ] [ l pairIn ] a.
  unfold proj1_sig in *. unfold paired_list in *.
  intros x xinrbral.
  remember (remove _ (pair a) _) as rbral. rename Heqrbral into rbraleq.
  destruct (eq_dec a x) as [ aeqx | anex ].
  - rewrite <- aeqx in *. clear aeqx.
    assert (aninral := remove_In eq_dec l a).
    elim (Inremoveidem _ eq_dec _ _ (pair a) aninral).
    rewrite <- rbraleq. assumption.
  - destruct (eq_dec (pair a) x) as [ paeqx | panex ].
    + rewrite <- paeqx in *. exfalso. clear paeqx.
      assert (aninral := remove_In eq_dec l (pair a)).
      elim (Inremoveidem _ eq_dec _ _ a aninral).
      rewrite remove_assoc.
      rewrite <- rbraleq. assumption.
    + destruct (eq_dec a (pair x)) as [ aeqpx | anepx ].
      * elim (pair_dis _ _ anex panex). assumption.
      * destruct (eq_dec (pair a) (pair x)) as [ paeqpx | panepx ].
        assert (a = x) as aeqx. assert (pair_involutive := involutive_if _ eq_dec _ pair_dis). rewrite pair_involutive. rewrite pair_involutive with a.
        rewrite paeqpx. reflexivity.
        rewrite aeqx in anex. elim anex. reflexivity.
      rewrite rbraleq in *. clear rbraleq rbral.
      repeat match goal with
          H : ?e <> ?v,
              HH : In ?v (remove ?dec ?e ?l)
          |- _
          => let Hx := fresh in
             assert (Hx := remove_corr_neq _ dec l _ _ H);
               rewrite <- Hx in HH;
               clear Hx
      end.
      rename xinrbral into xinl.
      assert (pxinl := pairIn _ xinl).
      repeat match goal with
          H : ?e <> ?v
          |- In ?v (remove ?dec ?e ?l)
          => let Hx := fresh in
             assert (Hx := remove_corr_neq _ dec l _ _ H);
               rewrite <- Hx;
               clear Hx
      end.
      assumption.
Qed.

Require Import PeanoNat.
Lemma paired_even :
  forall
    A
    eq_dec
    (pair : {pair | (forall a, a <> pair a) /\ (forall a b : A, a <> b -> pair a <> b -> a <> pair b)})
    (l_paired : {l | is_set eq_dec l = true /\ paired_list (proj1_sig pair) l}),
  Nat.Even (length (proj1_sig l_paired)).
Proof.
  intros.
  destruct pair as [ pair [ notid involutive ] ].
  destruct l_paired as [ l [ set paired ] ]. simpl in *.
  unfold paired_list in paired.
  remember (length l) as n.
  revert l set paired Heqn. induction n using fib_ind.
  - intros. exists 0. reflexivity.
  - intros. elim (paired_not_1 _ (exist _ _ notid) (exist _ l paired)).
    simpl. rewrite Heqn. reflexivity.
  - intros. clear IHn0.
    assert (rarblpaired := removepairs_still_paired A eq_dec (exist _ _ involutive) (exist _ _ paired)). simpl in rarblpaired.
    assert (Hx := removepairs A eq_dec l pair set paired).
    destruct l. discriminate Heqn.
    assert (Hy := Hx a). clear Hx. assert (In a (a::l)). simpl. left. reflexivity.
    assert (Hx := Hy H). clear Hy H.
    assert (Hy := Hx _ eq_refl). clear Hx.
    destruct (eq_dec a (pair a)). elim (notid a). assumption.
    rewrite (setrmhd _ _ _ _ set) in Hy.
    assert (Hx := IHn (remove eq_dec (pair a) l)). clear IHn.
    assert (lset := setrm _ _ _ set a). rewrite setrmhd in lset; [ | assumption ].
    assert (palset := setrm _ _ _ lset (pair a)).
    assert (Hz := Hx palset). clear Hx.
    unfold paired_list in rarblpaired.
    assert (rblpaired := rarblpaired a). clear rarblpaired. rewrite setrmhd in rblpaired; [ | assumption ].
    assert (Hx := Hz rblpaired). clear Hz rblpaired.
    assert (painl := paired a). assert (In a (a::l)). simpl. left. reflexivity.
    assert (Hz := painl H). clear painl H.
    assert (In (pair a) l) as painl. simpl in Hz. destruct Hz. elim n0. assumption. assumption. clear Hz.
    assert (Hz := lrm _ _ _ lset _ painl). simpl in Heqn. rewrite Hz in Heqn. injection Heqn. intro. clear Hz.
    assert (Hz := Hx H). revert Hz. clear. intro neven.
    unfold Nat.Even in *. destruct neven. rewrite H.
    exists (S x). simpl. auto.
Qed.

Lemma paired_even' :
  forall
    A
    eq_dec
    pair
    (pairpf1 : forall a, a <> pair a)
    (pairpf2 : forall a b : A, a <> b -> pair a <> b -> a <> pair b)
    l
    (l_paired : is_set eq_dec l = true /\ paired_list pair l),
  Nat.Even (length l).
Proof.
  intros. assert (Hx := paired_even _ _ (exist _ pair (conj pairpf1 pairpf2)) (exist _ _ l_paired)).
  simpl in Hx. assumption.
Qed.

Lemma setleneq :
  forall A dec (l ll : list A),
    is_set dec l = true ->
    is_set dec ll = true ->
    (forall a, In a l <-> In a ll) ->
    length l = length ll.
Proof.
  induction l. intros. simpl. destruct ll. reflexivity. simpl in H1.
  assert (a = a \/ In a ll). left. reflexivity.
  rewrite <- H1 in H2. contradiction.
  intros. simpl in *. destruct (inb dec a l) eqn:xx; [ discriminate | ].
  assert (In a ll).
    rewrite <- H1. left. reflexivity.
  assert (Hx := setrm _ _ _ H0 a).
  assert (Hy := lrm _ _ _ H0 _ H2).
  rewrite Hy. rewrite (IHl _ H Hx). reflexivity.
  intros. destruct (dec a a0).
  - rewrite <- e. split; intro.
    + rewrite inbeqInnot in xx. elim xx. assumption.
    + exfalso. revert H3. clear. intro.
      elim (remove_In dec ll a). assumption.
  - rewrite <- (remove_corr_neq _ dec ll _ _ n).
    rewrite <- H1. split; intro.
    + right. assumption.
    + destruct H3.
      * elim n. assumption.
      * assumption.
Qed.

Fixpoint zipmin {A B} (l : list A) (ll : list B) :=
  match l, ll with
    | nil, _ => nil
    | _, nil => nil
    | a::l', b::ll' => (a,b)::(zipmin l' ll')
  end.

Lemma zipminlnil : forall A B (l : list A), zipmin l (@nil B) = nil.
Proof.
  induction l. reflexivity.
  simpl. reflexivity.
Qed.

Lemma rev_unit : forall A (a : A) l, rev l = a::nil -> l = a::nil.
Proof.
  intros.
  assert (length (rev l) = 1). rewrite H. simpl. reflexivity.
  destruct l; [ discriminate H0 | ].
  destruct l; [ solve [ auto ] | ].
  simpl in H0. rewrite <- app_assoc in H0. rewrite app_length in H0.
  simpl in H0. remember (length _). exfalso. revert H0. clear.
  intros.
  rewrite Nat.add_comm in H0. simpl in H0. discriminate H0.
Qed.