(** * LProps: Properties of LDef *)

(** This file develops the type safety theorem for the small-step semantics of LDef.v.
    It is currently just Pierce's StlcProp.v. *)

Load Init.
Require Export SfLib.
Require Import LibTactics.
Require Export OLDef.

Module LDefProps.
Import LDEF.

(* ###################################################################### *)
(** ** Canonical Forms *)

Lemma canonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma canonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
    (* manual version:
    inversion HVal; subst; clear HVal.
      inversion HT; subst; clear HT. exists x0. exists t0.  auto.
      inversion HT.
      inversion HT.
  my version:*)
  inversion HVal; subst; inversion HT; subst; clear HVal HT.
  (* inversion HVal; intros; subst; try inversion HT; subst; auto. -- original *)
  exists x t0.  auto.
Qed.

(* ###################################################################### *)
(** ** Progress *)

(** The _progress_ theorem tells us that closed, well-typed
    terms are not stuck: either a well-typed term is a value, or it
    can take an evaluation step.
  The proof is by induction on the derivation of [|- t \in T]. *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.

(** _Proof_:

    - The last rule of the derivation cannot be [T_Var], since a
      variable is never well typed in an empty context.

    - The [T_True], [T_False], and [T_Abs] cases are trivial, since in
      each of these cases we know immediately that [t] is a value.

    - If the last rule of the derivation was [T_App], then [t = t1
      t2], and we know that [t1] and [t2] are also well typed in the
      empty context; in particular, there exists a type [T2] such that
      [|- t1 \in T2 -> T] and [|- t2 \in T2].  By the induction
      hypothesis, either [t1] is a value or it can take an evaluation
      step.

        - If [t1] is a value, we now consider [t2], which by the other
          induction hypothesis must also either be a value or take an
          evaluation step.

            - Suppose [t2] is a value.  Since [t1] is a value with an
              arrow type, it must be a lambda abstraction; hence [t1
              t2] can take a step by [ST_AppAbs].

            - Otherwise, [t2] can take a step, and hence so can [t1
              t2] by [ST_App2].

        - If [t1] can take a step, then so can [t1 t2] by [ST_App1].

    - If the last rule of the derivation was [T_If], then [t = if t1
      then t2 else t3], where [t1] has type [Bool].  By the IH, [t1]
      either is a value or takes a step.

        - If [t1] is a value, then since it has type [Bool] it must be
          either [true] or [false].  If it is [true], then [t] steps
          to [t2]; otherwise it steps to [t3].

        - Otherwise, [t1] takes a step, and therefore so does [t] (by
          [ST_If]).
*)

Proof with eauto.
  intros t T Ht.
  remember (empty) as Gamma.
  has_type_cases (induction Ht) Case; subst Gamma...
  Case "T_Var".
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  Case "T_App".
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    SCase "t1 is a value".
      destruct IHHt2...
      SSCase "t2 is also a value".
        apply canonical_forms_fun in Ht1.
          destruct Ht1 as [x0 [t0 Heq]]. subst. eexists.
            apply ST_AppAbs. assumption.
          assumption.
        (* original:
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply canonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...
      *)

      SSCase "t2 steps".
(* Why doesn't this work?
        eexists. apply ST_App2.
          assumption.  inversion H0 as [t2' Hstp]. subst.  eapply Hstp.
*)
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    SCase "t1 steps".
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  Case "T_If".
    right. destruct IHHt1...

    SCase "t1 is a value".
      destruct (canonical_forms_bool t1); subst; eauto.

    SCase "t1 also steps".
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
Qed.

(** (Exercise: 3 ) A proof that progress can also be proved by induction on terms
    instead of induction on typing derivations. *)

Theorem progress' : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof.
  intros t.
  t_cases (induction t) Case; intros T Ht; auto.
  (* FILLED IN  *)
    Case "tvar". inversion Ht. inversion H1.
    Case "tapp". right. inversion Ht; subst; clear Ht.
        destruct IHt1 with (T:=TArrow T11 T).  (* t1 : T11-->T *) apply H2.
      SCase "value t1". apply IHt2 in H4. clear IHt2. destruct H4.
        SSCase "value t2". apply canonical_forms_fun in H2.
          destruct H2 as [x0 [t0 Heq]]. subst.
          eexists. apply ST_AppAbs. assumption. assumption.
        SSCase " t2 ==> t' ". destruct H0 as [t2' Ht2]. eexists.
          apply ST_App2. assumption. eassumption.
      SCase "t1==>t1'". destruct H as [t1' Ht1]. eexists.
        apply ST_App1. eassumption.
    Case "tif". right. inversion Ht; subst; clear Ht.
          destruct IHt1 with (T:=TBool). apply H3.
      SCase "value t1". apply canonical_forms_bool in H3. destruct H3; subst.
        SSCase "t1 = ttrue". eexists. apply ST_IfTrue.
        SSCase "t1 = tfalse". eexists. apply ST_IfFalse.
        apply H.
      SCase "t1==>t1'". destruct H as [t1' Ht1]. eexists.
        apply ST_If. eassumption.
Qed.
(** [] *)

(* ###################################################################### *)
(** ** Preservation *)

(* ###################################################################### *)
(** *** Free Occurrences *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tif t1 t2 t3).

Tactic Notation "afi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "afi_var"
  | Case_aux c "afi_app1" | Case_aux c "afi_app2"
  | Case_aux c "afi_abs"
  | Case_aux c "afi_if1" | Case_aux c "afi_if2"
  | Case_aux c "afi_if3" ].

Hint Constructors appears_free_in.

(** A term in which no variables appear free is said to be _closed_. *)

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

(* ###################################################################### *)
(** *** Substitution *)

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', lookup_vdecl x Gamma = Some T'.
Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  afi_cases (induction H) Case;
         intros; try solve [inversion H0; eauto].
  Case "afi_abs".
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite lookup_add_vdecl_neq in H7; assumption.
Qed.

(** Next, we'll need the fact that any term [t] which is well typed in
    the empty context is closed -- that is, it has no free variables. *)

(** ** (Exercise: 2 stars, optional (typable_empty__closed))  *)
Corollary typable_empty__closed : forall t T,
    empty |- t \in T  ->
    closed t.
Proof.
  (* FILLED IN *)
  intros t T Hin x Hfree.
  apply free_in_context with (T:=T) (Gamma:=empty) in Hfree.
  destruct Hfree. inversion H. assumption.
Qed.

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T  ->
     (forall x, appears_free_in x t ->
                lookup_vdecl x Gamma = lookup_vdecl x Gamma') ->
     Gamma' |- t \in T.

Proof with eauto.
  intros.
  generalize dependent Gamma'.
  has_type_cases (induction H) Case; intros; auto.
  Case "T_Var".
    apply T_Var. rewrite <- H0...
  Case "T_Abs".
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [extend Gamma x T11] *)
    unfold add_vdecl, lookup_vdecl. destruct (eq_id_dec x x1)...
  Case "T_App".
    apply T_App with T11...
Qed.

(** _Lemma_: If [Gamma,x:U |- t \in T] and [|- v \in U], then [Gamma |-
    [x:=v]t \in T]. *)

Lemma substitution_preserves_typing : forall Gamma x U t v T,
     add_vdecl x U Gamma |- t \in T ->
     empty |- v \in U   ->
     Gamma |- [x:=v]t \in T.

(** One technical subtlety in the statement of the lemma is that we
    assign [v] the type [U] in the _empty_ context -- in other words,
    we assume [v] is closed.  This assumption considerably simplifies
    the [T_Abs] case of the proof (compared to assuming [Gamma |- v \in
    U], which would be the other reasonable assumption at this point)
    because the context invariance lemma then tells us that [v] has
    type [U] in any context at all -- we don't have to worry about
    free variables in [v] clashing with the variable being introduced
    into the context by [T_Abs]. *)

Proof with eauto.
  intros Gamma x U t v T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  t_cases (induction t) Case; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; clear H (* added *); simpl...
  Case "tvar".
    rename i into y. destruct (eq_id_dec x y).
    SCase "x=y".
      subst.
      rewrite lookup_add_vdecl_eq in H2.
      inversion H2; subst. clear H2.
      eapply context_invariance... intros x Hcontra.
      (* added Ht' & removed .. *)
      destruct (free_in_context _ _ T empty Hcontra Ht') as [T' HT'].
      inversion HT'.
    SCase "x<>y".
      apply T_Var. rewrite lookup_add_vdecl_neq in H2...
  Case "tabs".
    rename i into y. apply T_Abs.
    destruct (eq_id_dec x y).
    SCase "x=y".
      eapply context_invariance...
      subst.
      intros x Hafi. unfold add_vdecl, lookup_vdecl.
      destruct (eq_id_dec y x)...
    SCase "x<>y".
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold add_vdecl, lookup_vdecl.
      destruct (eq_id_dec y z)...
      subst. rewrite neq_id...
Qed.

(** The substitution lemma can be viewed as a kind of "commutation"
    property.  Intuitively, it says that substitution and typing can
    be done in either order: we can either assign types to the terms
    [t] and [v] separately (under suitable contexts) and then combine
    them using substitution, or we can substitute first and then
    assign a type to [ [x:=v] t ] -- the result is the same either
    way. *)

(* ###################################################################### *)
(** *** Main Theorem *)

(** Preservation: if a closed
    term [t] has type [T], and takes an evaluation step to [t'], then [t']
    is also a closed term with type [T].  In other words, the small-step
    evaluation relation preserves types.
    Proof by induction on the derivation of [|- t \in T].
*)

Theorem preservation : forall t t' T,
     empty |- t \in T  ->
     t ==> t'  ->
     empty |- t' \in T.

Proof with eauto.
  remember (empty) as Gamma.
  intros t t' T HT. generalize dependent t'.
      (* playing around:
        has_type_cases (induction HT) Case. admit. admit. admit.  admit. admit.
        intros t' HE. subst Gamma. subst. inversion HE. subst. assumption. subst. assumption. subst. apply T_If; try assumption.
        apply IHHT1. reflexivity . apply H3. *)
       has_type_cases (induction HT) Case;
       intros t' HE; subst Gamma; subst;
       try solve [inversion HE; subst; auto].
  Case "T_App".
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and [eauto] takes care of them *)
    SCase "ST_AppAbs".
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

(* ###################################################################### *)
(** ** Type Soundness *)

(** Progress and preservation together imply that a well-typed
    term can _never_ reach a stuck state.  *)

Definition normal_form {X:Type} (R:relation X) (t:X) : Prop :=
  ~ exists t', R t t'.

Definition stuck (t:tm) : Prop :=
  (normal_form step) t /\ ~ value t.

Corollary soundness : forall t t' T,
  empty |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti   (* FILLED IN  *)  as [ x | x y z ].
    Case "multi_refl: x==>x".
      apply progress in Hhas_type. destruct Hhas_type; auto.
    Case "multi_step: x==>y, y==>*z".
      apply IHHmulti; try assumption.
      eapply preservation.
        apply Hhas_type.
        assumption.
Qed.

(* ###################################################################### *)
(** ** Uniqueness of Types *)

(** Another pleasant property of the STLC is that types are
    unique: a given term (in a given context) has at most one
    type.

    (Exercise) TBD: Formalize this statement and prove it. *)
(* FILL IN HERE *)

End LDefProps.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*             Yannick Forster            [+]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*                             [+] Affiliation Saarland Univ. *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* ** Compiler from MM to FRACTRAN *)

Require Import List Arith Lia Permutation.

Import ListNotations.

From Undecidability.Shared.Libs.DLW
  Require Import utils utils_tac utils_list utils_nat gcd rel_iter prime
                 pos vec subcode sss.

From Undecidability.MinskyMachines.MM Require Import mm_defs mm_no_self.
From Undecidability.FRACTRAN Require Import FRACTRAN fractran_utils prime_seq.

Set Implicit Arguments.

Tactic Notation "rew" "length" := autorewrite with length_db.

Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).

Local Notation "I // s -1> t" := (mm_sss I s t).
Local Notation "P /MM/ s → t" := (sss_step (@mm_sss _) P s t) (at level 70, no associativity).
Local Notation "P /MM/ s -[ k ]-> t" := (sss_steps (@mm_sss _) P k s t) (at level 70, no associativity).
Local Notation "P /MM/ s ↓" := (sss_terminates (@mm_sss _) P s) (at level 70, no associativity).

Local Notation "l /F/ x → y" := (fractran_step l x y) (at level 70, no associativity).
Local Notation "l /F/ x -[ k ]-> y" := (fractran_steps l k x y) (at level 70, no associativity).

Set Implicit Arguments.

(* Fractran simulates MM *)

(*       let a MM program 1: INC ... k: DEC ... n: _ *)
(*       with variables x1...xm *)

(*    we use p1...pn,q1...qm distinct primes and  *)
(*    encode the state (i,v1,...,vm) *)
(*    as p1^0*...*pi^1*...*pn^0*q1^v1*...*qm^vm *)

(*    i: INC xu   ---> (qu*p(i+1) / pi) *)
(*    i: DEC xu j ---> (p(i+1) / pi*qu) and (pj / pi) (the second constraint should appear AFTER in the list) *)

Definition encode_state {n} (c : nat * vec nat n) := ps (fst c) * @exp n 0 (snd c).

Definition encode_inc n  i (u : pos n) := (ps (i + 1) * qs u, ps i).
Definition encode_dec n  i (u : pos n) (_ : nat) := (ps (i + 1), ps i * qs u).
Definition encode_dec2 n i (u : pos n) j := (ps j, ps i).

Definition encode_one_instr m i (rho : mm_instr (pos m)) :=
  match rho with
    | INC u   => encode_inc i u :: nil
    | DEC u j => encode_dec i u j :: encode_dec2 i u j :: nil
  end.

Fixpoint encode_mm_instr m i (l : list (mm_instr (pos m))) : list (nat * nat) :=
  match l with
    | nil          => nil
    | rho :: l => encode_one_instr i rho ++ encode_mm_instr (S i) l
  end.

Fact encode_mm_instr_app m i l r : @encode_mm_instr m i (l++r) = encode_mm_instr i l++encode_mm_instr (length l+i) r.
Proof.
  revert i; induction l as [ | rho l IHl ]; intros i; simpl; auto; rewrite IHl, app_ass.
  do 3 f_equal; lia.
Qed.

Fact encode_mm_instr_regular n i l : Forall (fun c => fst c <> 0 /\ snd c <> 0) (@encode_mm_instr n i l).
Proof.
  revert i; induction l as [ | [ u | u j ] l IHl ]; intros i; simpl.
  + constructor.
  + constructor; auto; unfold encode_inc; simpl; split;
      [ apply Nat.neq_mul_0; split | ]; apply prime_neq_0; apply nthprime_prime.
  + constructor; [ | constructor ]; auto; split; unfold encode_dec, encode_dec2; simpl.
    2: apply Nat.neq_mul_0; split.
    all: apply prime_neq_0; apply nthprime_prime.
Qed.

Fact encode_mm_instr_regular' n i l : fractran_regular (@encode_mm_instr n i l).
Proof.
  generalize (@encode_mm_instr_regular n i l); apply Forall_impl; tauto.
Qed.

Fact encode_mm_instr_in_inv n i P el c er :
          @encode_mm_instr n i P = el++c::er
       -> exists l rho r, P = l++rho::r /\ In c (encode_one_instr (length l+i) rho).
Proof.
  revert i el c er; induction P as [ | rho P IHP ]; simpl; intros i el c er H.
  + destruct el; discriminate.
  + destruct list_app_cons_eq_inv with (1 := H)
      as [ (m & H1 & H2) | (m & H1 & H2) ].
    * destruct IHP with (1 := H2) as (l & rho' & r & G1 & G2).
      exists (rho::l), rho', r; subst; split; auto.
      eq goal G2; do 2 f_equal; simpl; lia.
    * exists nil, rho, P; split; simpl; auto.
      rewrite <- H1; apply in_or_app; simpl; auto.
Qed.

Local Notation divides_mult_inv := prime_div_mult.

Local Ltac inv H := inversion H; subst; clear H.

Opaque ps qs.

Lemma divides_encode_state i k n v : divides (ps i) (@encode_state n (k,v)) -> i = k.
Proof.
  unfold encode_state. intros. induction v.
  - cbn in H. replace (ps k * 1) with (ps k) in H by lia.
    now eapply primestream_divides in H.
  - cbn in H. eapply divides_mult_inv in H as [ | [ | ] % divides_mult_inv ]; eauto.
    + now eapply primestream_divides in H.
    + eapply divides_pow in H; eauto.
      now eapply ps_qs_div in H.
    + now eapply ps_exp in H.
Qed.

Lemma skip_steps m k l r k' (v v' : vec _ m) :
      @mm_no_self_loops m (k, l ++ r)
   -> encode_mm_instr (k + length l) r /F/ encode_state (k + length l,v) → encode_state (k',v')
   -> encode_mm_instr k (l ++ r)       /F/ encode_state (k + length l,v) → encode_state (k',v').
Proof with eauto; try lia.
  revert k. induction l; cbn - [subcode] in *; intros.
  - revert H0. ring_simplify (k + 0). eauto.
  - revert H0. ring_simplify (k + S (length l)). intros H1. destruct a.
    + econstructor 2. intros [[|] % divides_mult_inv | ] % divides_mult_inv; eauto.
      * eapply primestream_divides in H0; lia.
      * now eapply ps_qs_div in H0.
      * eapply divides_encode_state in H0; lia.
      * specialize IHl with (k := S k). revert IHl.
        cbn - [subcode]. ring_simplify (S (k + length l)).
        intros IHl. eapply IHl. 2:exact H1.
        intros ? ? ?. eapply H. eapply subcode_cons. eassumption.
    + repeat econstructor 2. 2:unfold encode_dec2.
      2,3: cbn- [subcode]. 1: intros [] % divides_mult_inv_l.
      2: intros [ | ] % divides_mult_inv...
      * eapply divides_mult_inv in H0 as [? | ?]...
        eapply primestream_divides in H0...
        eapply divides_encode_state in H0...
      * eapply primestream_divides in H0... subst.
        eapply (H n t). eauto.
      * eapply divides_encode_state in H0...
      * specialize (IHl (S k)). revert IHl.
        cbn - [subcode]. ring_simplify (S (k + length l)).
        intros IHl. eapply IHl. 2:exact H1.
        intros ? ? ?. eapply H. eapply subcode_cons. eassumption.
Qed.

Lemma qs_exp i n u (v : vec nat n) :
  divides (qs u) (encode_state (i,v)) <-> divides (qs u) (exp 0 v).
Proof.
  split.
  - intros [ | ] % divides_mult_inv; eauto.
    now eapply qs_ps_div in H.
  - intros. unfold encode_state. now eapply divides_mult.
Qed.

Lemma qs_encode_state i n (u : pos n) (v : vec nat n) :
  divides (qs u) (encode_state (i,v)) <-> v #> u > 0.
Proof.
  rewrite qs_exp.
  enough (forall i, divides (qs (i + u)) (exp i v) <-> v #> u > 0). eapply H. intros j.
  induction v.
  - inversion u.
  - revert u. eapply pos.pos_S_invert.
    + cbn; rewrite pos2nat_fst, Nat.add_0_r.
      split.
      * intros [ | ] % divides_mult_inv; eauto.
        -- destruct h; try lia. cbn in H.
           apply divides_1_inv in H.
           generalize (str_prime qs j); rewrite H.
           intros [ [] _ ]; auto.
        -- eapply qs_exp_div in H; now eauto.
      * intros. destruct h. inv H.
        exists (qs j ^ h * exp (S j) v). cbn. ring.
    + cbn. intros. rewrite <- IHv, pos2nat_nxt.
      rewrite qs_shift with (m := 1).
      simpl.
      replace (j+S (pos2nat p)) with (S (j+p)); try tauto.
      2: rewrite (plus_comm _ (S _)); simpl; rewrite plus_comm; auto.
      split; intros H.
      * eapply divides_mult_inv in H as [ | ]; eauto.
        eapply divides_pow in H; auto.
        eapply primestream_divides in H.
        lia.
      * eapply divides_mult.
        revert H; cbn; rewrite plus_n_Sm; eauto.
Qed.

Lemma one_step_forward m i P i1 v1 i2 v2 :
     @mm_no_self_loops m (i,P)
  -> (i, P)              /MM/ (i1, v1)           → (i2,v2)
  -> encode_mm_instr i P /F/  encode_state (i1,v1) → encode_state (i2,v2).
Proof with eauto; try lia.
  intros HP (k & l & [ u | u j ] & r & v & ? & ? & ?); inversion H; subst; clear H.
  - inversion H0; inversion H1; subst; clear H0 H1.
    eapply skip_steps...
    econstructor. cbn. ring_simplify.
    replace (1 + (k + length l)) with (k + length l + 1) by lia. unfold encode_state, fst, snd.
    rewrite vec_prod_mult.
    rewrite Nat.add_0_r; ring.
  - inversion H0; inversion H1; subst; clear H0 H1.
    all:eapply skip_steps...
    + cbn. econstructor 2.
      intros [] % divides_mult_inv_l...
      eapply divides_mult_inv in H0 as [ | ]...
      * now eapply qs_ps_div in H0.
      * eapply qs_encode_state in H0. lia.
      * unfold encode_dec2. econstructor. unfold encode_state, fst, snd. ring.
    + econstructor. cbn. unfold encode_state, fst, snd. ring_simplify.
      replace (1 + (k + length l)) with (k + length l + 1) by lia.
      erewrite <- (vec_prod_div _ _ _ H4).
      rewrite Nat.add_0_r; ring.
Qed.

Lemma steps_forward m i P i1 v1 i2 v2 k :
    @mm_no_self_loops m (i, P)
 -> (i, P) /MM/ (i1, v1) -[k]-> (i2,v2)
 -> encode_mm_instr i P /F/ encode_state (i1,v1) -[k]-> encode_state (i2,v2).
Proof.
  intros HP H. revert v1 i1 i2 H. induction k; intros v1 i1 i2 H; inversion H; subst; clear H; cbn.
  - reflexivity.
  - destruct st2. eapply one_step_forward in H1; eauto.
Qed.

(* The divisibility results are no so complicated when
    we do not need to show that encode_state is injective ... *)

Local Fact divides_from_eq x y t : x*y = t -> divides x t.
Proof. exists y; subst; ring. Qed.

Local Fact prime_div_mult3 p x y z : prime p -> divides p (x*y*z) -> divides p x \/ divides p y \/ divides p z.
Proof.
  intros H1 H2.
  apply prime_div_mult in H2; auto.
  destruct H2 as [ H2 | ]; auto.
  apply prime_div_mult in H2; tauto.
Qed.

Local Fact prime_div_mult4 p w x y z : prime p -> divides p (w*x*y*z) -> divides p w \/ divides p x \/ divides p y \/ divides p z.
Proof.
  intros H1 H2.
  apply prime_div_mult3 in H2; auto.
  destruct H2 as [ H2 | H2 ]; try tauto.
  apply prime_div_mult in H2; tauto.
Qed.

Local Hint Resolve encode_mm_instr_regular' : core.

Lemma one_step_backward m i P i1 v1 st :
     @mm_no_self_loops m (i, P)
  -> encode_mm_instr i P /F/ @encode_state m (i1,v1) → st
  -> exists i2 v2, st = @encode_state m (i2,v2)
                /\ (i, P) /MM/ (i1, v1) → (i2,v2).
Proof.
  intros H1 H2.
  destruct fractran_step_inv with (1 := H2)
    as (el & p & q & er & H3 & H4 & H5).
  unfold encode_state in H5; simpl in H5.
  destruct encode_mm_instr_in_inv with (1 := H3)
    as (l & rho & r & -> & G2).
  assert (i1 = length l+i) as E.
  { unfold encode_one_instr in G2.
    destruct rho as [ u | u j ]; unfold encode_inc, encode_dec, encode_dec2 in G2;
      [ destruct G2 as [ G2 | [] ] | destruct G2 as [ G2 | [ G2 | [] ] ] ];
      inversion G2; subst p q; clear G2;
      repeat rewrite mult_assoc in H5.
    * apply divides_from_eq, prime_div_mult4 in H5; auto.
      destruct H5 as [ H5 | [ H5 | [ H5 | H5 ] ] ].
      + apply primestream_divides in H5; lia.
      + apply ps_qs_div in H5; tauto.
      + apply primestream_divides in H5; lia.
      + apply ps_exp in H5; tauto.
    * rewrite <- mult_assoc in H5.
      apply divides_from_eq, prime_div_mult3 in H5; auto.
      destruct H5 as [ H5 | [ H5 | H5 ] ].
      + apply primestream_divides in H5; lia.
      + apply primestream_divides in H5; lia.
      + apply ps_exp in H5; tauto.
    * apply divides_from_eq, prime_div_mult3 in H5; auto.
      destruct H5 as [ H5 | [ H5 | H5 ] ].
      + apply primestream_divides in H5.
        exfalso; apply (H1 j u); auto.
      + apply primestream_divides in H5; lia.
      + apply ps_exp in H5; tauto. }
  destruct mm_sss_total with (ii := rho) (s := (i1,v1))
    as ((i2 & v2) & H7).
  exists i2, v2.
  assert ((i, l++rho::r) /MM/ (i1,v1) → (i2,v2)) as H8.
  { apply in_sss_step; auto; simpl; lia. }
  split; auto.
  apply one_step_forward in H8; auto.
  revert H2 H8; apply fractran_step_fun; auto.
Qed.

Lemma steps_backward m i P i1 v1 k st :
     @mm_no_self_loops m (i, P)
  ->               encode_mm_instr i P /F/ encode_state (i1,v1) -[k]-> st
  -> exists i2 v2, (i, P) /MM/ (i1, v1) -[k]-> (i2,v2)
                /\ st = encode_state (i2,v2).
Proof.
  intros H1.
  revert i1 v1 st; induction k as [ | k IHk ]; intros i1 v1 st H; simpl in H.
  - subst; exists i1, v1; split; auto; constructor.
  - destruct H as (st1 & H2 & H3).
    destruct one_step_backward with (2 := H2)
      as (i2 & v2 & -> & H5); auto.
    destruct IHk with (1 := H3) as (i3 & v3 & ? & ->).
    exists i3, v3; split; auto.
    constructor 2 with (i2,v2); auto.
Qed.

Theorem mm_fractran_simulation n P v :
     @mm_no_self_loops n (1, P)
  -> (1,P) /MM/ (1,v) ↓ <-> encode_mm_instr 1 P /F/ ps 1 * exp 0 v ↓.
Proof.
  intros HP.
  change (ps 1* exp 0 v) with (encode_state (1,v)).
  split.
  + intros ((j,w) & (k & H1) & H2); simpl fst in *.
    exists (encode_state (j,w)); split.
    * exists k; apply steps_forward in H1; auto.
    * intros x Hx.
      destruct one_step_backward with (2 := Hx)
        as (i2 & v2 & -> & ?); auto.
      revert H; apply sss_out_step_stall; auto.
  + intros (st & (k & H1) & H2).
    destruct steps_backward with (2 := H1)
      as (i2 & v2 & H3 & ->); auto.
    exists (i2,v2); split.
    * exists k; auto.
    * simpl fst.
      destruct (in_out_code_dec i2 (1,P)) as [ H4 | H4 ]; auto; exfalso.
      destruct in_code_subcode with (1 := H4) as (rho & l & r & G1 & G2).
      destruct (mm_sss_total rho (i2,v2)) as ((i3,v3) & G3).
      apply H2 with (encode_state (i3,v3)).
      apply one_step_forward; auto.
      subst P; apply in_sss_step; auto.
Qed.

Theorem mm_fractran_not_zero n (P : list (mm_instr (pos n))) :
        { l |  Forall (fun c => fst c <> 0 /\ snd c <> 0) l
            /\ forall v, (1,P) /MM/ (1,v) ↓ <-> l /F/ ps 1 * exp 1 v ↓ }.
Proof.
   destruct mm_remove_self_loops with (P := P) as (Q & H1 & _ & H2).
   exists (encode_mm_instr 1 Q); split.
   + apply encode_mm_instr_regular.
   + intros x.
     rewrite H2, mm_fractran_simulation; auto.
     simpl exp; rewrite Nat.add_0_r; tauto.
Qed.

Theorem mm_fractran_n n (P : list (mm_instr (pos n))) :
        { l |  Forall (fun c => snd c <> 0) l
            /\ forall v, (1,P) /MM/ (1,v) ↓ <-> l /F/ ps 1 * exp 1 v ↓ }.
Proof.
   destruct (mm_fractran_not_zero P) as (l & H1 & H2).
   exists l; split; auto.
   revert H1; apply Forall_impl; intros; tauto.
Qed.

Theorem mm_fractran n (P : list (mm_instr (pos (S n)))) :
     { l | forall x, (1,P) /MM/ (1,x##vec_zero) ↓ <-> l /F/ ps 1 * qs 1^x ↓ }.
Proof.
   destruct mm_fractran_n with (P := P) as (l & _ & Hl).
   exists l; intros x; rewrite Hl; simpl.
   rewrite exp_zero, Nat.mul_1_r; tauto.
Qed.


From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import reals classical_sets boolp.
From mathcomp Require Import zify.
Require Import tactics.

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

Section TupleExtras.
Variables (T : eqType) (n : nat).
Implicit Types (x y : T) (t : n.-tuple T).

Lemma cons_tupleE x t : cons_tuple x t = [tuple of x :: t].
Proof. by []. Qed.

Lemma tuple_cons_in x y t (l : list (n.-tuple T)) :
  [tuple of x :: t] \in map (cons_tuple y) l <-> x = y /\ t \in l.
Proof.
  split => [| [->]] ; last by apply map_f.
  elim: l => [|t0 l IH] ; first by rewrite /= in_nil.
  rewrite map_cons in_cons => /orP[|].
  - rewrite -val_eqE /= => /eqP[-> /val_inj ->].
    by rewrite in_cons eqxx.
  - by rewrite in_cons ; move => /IH[-> ->] ; intuition.
Qed.

Lemma tuple_behead_cons x t :
  [tuple of behead [tuple of x :: t]] = t.
Proof. by apply val_inj => /=. Qed.

Lemma cons_tuple_inj : injective2 (@cons_tuple n T).
Proof. by move=> x x' t t' [-> /val_inj ->]. Qed.

Lemma tuple_count_size x t :
  count (xpred1 x) t <= n.
Proof.
  rewrite (leqRW (@count_size _ _ t)).
  by case: t => t /eqP st /= ; rewrite st leqnn.
Qed.

End TupleExtras.

Section BoolExtras.

Lemma is_true_inj : injective is_true.
Proof.
  move=> a b ; case: a ; case: b => //= ;
  move: (@iffP (is_true true) (is_true false) true (@idP true)) => H0 H1.
  - by feed_n 2 H0 ; [by rewrite H1 .. |] ; case: H0.
  - by feed_n 2 H0 ; [by rewrite H1 .. |] ; case: H0.
Qed.

Lemma nat_of_bool_inj : injective nat_of_bool.
Proof. by move=> a b ; case: a ; case: b. Qed.

End BoolExtras.

Section OrdExtras.
Variables n : nat.

Inductive lift_ord_spec : 'I_n.+1 -> Type :=
  | Lift_ord_0 : lift_ord_spec (@ord0 n)
  | Lift_ord_lift : forall (i : 'I_n), lift_ord_spec (lift ord0 i).

(* Use this with 'case: (lift_ordP i)'. *)
Lemma lift_ordP i : lift_ord_spec i.
Proof.
  case: (i =P ord0) => [->|/eqP] ; first by constructor.
  case: i => [i lt_in1] /= ; rewrite -val_eqE /= => ne_i0.
  have lt_i1n : i.-1 < n by lia.
  have : Ordinal lt_in1 = lift ord0 (Ordinal lt_i1n) => [|->].
    by apply /eqP ; rewrite -val_eqE /= /bump /= ; lia.
  by constructor.
Qed.

Inductive widen_ord_spec : 'I_n.+1 -> Type :=
  | Widen_ord_max : widen_ord_spec (@ord_max n)
  | Widen_ord_widen : forall (i : 'I_n), widen_ord_spec (widen_ord (leqnSn n) i).

(* Use this with 'case: (widen_ordP i)'. *)
Lemma widen_ordP i : widen_ord_spec i.
Proof.
  case: (i =P ord_max) => [->|/eqP] ; first by constructor.
  case: i => [i lt_in1] ; rewrite -val_eqE /= => ne_im.
  have lt_in : i < n by lia.
  have : Ordinal lt_in1 = widen_ord (leqnSn n) (Ordinal lt_in) => [|->].
    by apply /eqP ; rewrite -val_eqE /=.
  by constructor.
Qed.

End OrdExtras.

Section MatrixExtras.
Open Scope real_scope.
Open Scope classical_set_scope.
Open Scope ring_scope.
Variables R : realType.
Implicit Types (s t : R).

Lemma trmx_scale n m (A : 'M_(n, m)) s  : (s *: A)^T = s *: A^T.
Proof. by rewrite -mul_mx_scalar trmx_mul tr_scalar_mx mul_scalar_mx. Qed.

Lemma scale_mulmx m1 m2 m3 (A : 'M_(m1, m2)) (B : 'M_(m2, m3)) s t :
  s *: A *m (t *: B) = (s * t) *: (A *m B).
Proof.
  rewrite -!mul_scalar_mx scalar_mxM.
  rewrite mulmxA [in RHS]mulmxA ; congr (_ *m _).
  by rewrite -mulmxA scalar_mxC mulmxA.
Qed.

Lemma mxbigcap1U n a i0 (P : set 'I_n) (F : 'I_n -> 'M[R]_a) : i0 \notin P ->
  (\bigcap_(i in (i0 |` P)) F i == F i0 :&: \bigcap_(i in P) F i)%MS.
Proof.
  rewrite (bigID [pred i | i == i0]) /= => N_Pi0.
  apply /eqmxP ; apply cap_eqmx.
  - under eq_bigl do (rewrite andb_idl => [|/eqP->] ; [|by rewrite in_setE ; left]).
    rewrite big_pred1_eq ; apply eqmx_refl.
  - have cond i : ((i \in i0 |` P) && (i != i0)) = (i \in P).
      apply /eqP ; rewrite -eqbE /eqb /addb ; case: ifP => [|/negbT].
      + rewrite negb_and negbK => /orP[|/eqP-> //].
        move /negP ; rewrite in_setE /= -[P i]in_setE.
        by case E: (i \in P) ; intuition.
      + by rewrite negbK => /andP[+ /eqP] ; rewrite !in_setE /= ; intuition.
    under eq_bigl do rewrite cond ; apply eqmx_refl.
Qed.

Lemma sumr_ge0if (I : finType) (P : pred I) (E : I -> R) :
  (forall i, P i -> 0 <= E i)%R ->
  (0 <= \sum_(i | P i) E i ?= iff [forall i, P i ==> (E i == 0)])%R.
Proof.
  move=> Hle0 ; split ; first by apply big_ind => // x y ; apply Num.Theory.addr_ge0.
  apply /eqP ; case: ifP => [/forallP Heq0|].
  - apply big_ind => //.
    by move=> x y <- <- ; rewrite GRing.Theory.addr0.
    by move=> i Pi ; symmetry ; apply /eqP ; apply (implyP (Heq0 i)).
  - move /negbT ; rewrite negb_forall => /existsP[i0].
    rewrite negb_imply => /andP[Pi0 Ei0_neq0].
    suff: \sum_(i | P i) E i > 0 by move /Num.Theory.lt0r_neq0 /eqP ; intuition.
    have Ei0_gt0 : E i0 > 0 by rewrite Order.POrderTheory.lt_def Ei0_neq0 Hle0. clear Ei0_neq0.
    rewrite (bigID (xpred1 i0)) /= ; apply Num.Theory.ltr_paddr.
    + by apply big_ind => // [x y | i /andP[Pi _]] ; [apply Num.Theory.addr_ge0 | auto].
    + by under eq_bigl do rewrite andb_idl => [|/eqP-> //] ; rewrite big_pred1_eq.
Qed.

Lemma mxbigcap_sub n d (P P' : pred 'I_n) (F : 'I_n -> 'M[R]_d) :
  (forall i, P i -> P' i) -> (\bigcap_(i | P' i) F i <= \bigcap_(i | P i) F i)%MS.
Proof. Admitted.

End MatrixExtras.

Section NatSetBounds.
Open Scope classical_set_scope.
Variables (A : set nat) (x0 t : nat).

Lemma inf_le :
  (exists2 x, A x & x <= t) -> infimum x0 A <= t.
Proof. Admitted.

Lemma inf_ge :
  (forall x, A x -> x >= t) -> A !=set0 -> infimum x0 A >= t.
Proof. Admitted.

End NatSetBounds.

Section ClassicalSetsExtras.
Open Scope classical_set_scope.

Lemma image_nonempty aT rT (f : aT -> rT) (A : set aT) :
  A !=set0 -> [set f x | x in A] !=set0.
Proof. by case => [x Ax] ; exists (f x) ; exists x. Qed.

Lemma set_ord0 (P : set 'I_0) : P = set0.
Proof.
  case E: `[< P = set0 >].
  - by move: E => /asboolP.
  - move: E => /negbT /asboolPn /eqP /set0P [x] ; case: x ; lia.
Qed.

Lemma Csubset1 T (A : set T) x : ([set x] `<=` A) = (x \in A).
Proof. by apply propext ; rewrite /subset /= in_setE ; split => [/(_ x (Logic.eq_refl _)) | Ax t ->]. Qed.

Definition disjointS n T (F : 'I_n -> set T) := forall i j, i != j -> F i `&` F j =set0.

Lemma disjointS_capl n T S (F : 'I_n -> set T) :
  disjointS F -> disjointS (fun i => S `&` F i).
Proof. Admitted.

Lemma disjointS_capr n T S (F : 'I_n -> set T) :
  disjointS F -> disjointS (fun i => F i `&` S).
Proof. Admitted.

Lemma bigcup_decomp n T (F : 'I_n -> set T) S :
  S `<=` \bigcup_i F i -> S = \bigcup_i (S `&` F i).
Proof. by rewrite -setI_bigcupr => Hsub ; symmetry ; apply setIidl. Qed.

Section CardSet.
Variables (T : finType).
Implicit Types (S : set T).

Lemma card_set_sum S :
  #|S| = \sum_i (i \in S).
Proof. Admitted.

Lemma card0_set0 S : (#|S| == 0) = (S == set0).
Proof.
  apply /eqP ; case: ifP => [/eqP ->|/negbT /set0P[x Sx]].
  - rewrite card_set_sum. apply big_ind => // [x y -> -> //| i _].
    by rewrite in_set0 /=.
  - suff: #|S| > 0 by move=> /lt0n_neq0 /eqP.
    rewrite card_set_sum (bigID [pred i | i == x]) /=.
    rewrite addn_gt0 ; apply /orP ; left ; rewrite big_pred1_eq.
    by rewrite lt0b in_setE.
Qed.

Lemma card_set0 : #|@set0 T| = 0.
Proof. by apply /eqP ; rewrite (card0_set0 set0) eqxx. Qed.

Lemma card_setT : #|@setT T| = #|T|.
Proof. by rewrite card_set_sum ; under eq_big do [|rewrite in_setT /=] ; rewrite sum1_card. Qed.

Lemma card_leTif S : #|S| <= #|T| ?= iff (S == setT).
Proof.
  rewrite -card_setT !card_set_sum ; split.
  - by apply leq_sum => i _ ; rewrite in_setT /= leq_b1.
  - rewrite (@leqif_sum _ _ [pred i | i \in S]) /= ; last first => [i _|].
    + by rewrite in_setT /= ; split ; [rewrite leq_b1 | case: (i \in S)].
    + symmetry ; apply /eqP ; case: ifP => [/forallP H | /negbT].
      * apply funext => x /= ; move: (implyP (H x) (eq_refl true)).
        rewrite in_setE => Sx ; apply propext ; intuition.
      * rewrite negb_forall => /existsP[x] ; rewrite negb_imply /= => N_Sx ST.
        have Sx : x \in S by rewrite in_setE ST /=.
        by move: Sx N_Sx => ->.
Qed.

Lemma Nin_card_ltT x S : x \notin S -> #|S| < #|T|.
Proof.
  move=> N_Px.
  apply contraT ; rewrite -ltnNge ltnS => le_TP.
  have /eqP eq_TP : #|S| == #|T| by rewrite eqn_leq (card_leTif S) /=.
  by move: eq_TP N_Px => /eqP ; rewrite card_leTif => /eqP -> ; rewrite in_setT.
Qed.

Lemma set1U_disj_card x S :
  x \notin S -> #|x |` S| = #|S|.+1.
Proof. Admitted.

Lemma card_set_count m (t : m.-tuple T) x :
  #|[set i | tnth t i == x]| = count (xpred1 x) t.
Proof.
rewrite cardE /in_set /enum_mem size_filter /= /mem /=.
rewrite -(@count_map _ _ _ (fun s : T => boolp.asbool (s == x))).
f_equal.
- by apply funext => s ; rewrite asboolb.
- apply (@eq_from_nth _ x) ; rewrite size_map -enumT size_enum_ord.
  + by case: t => /= ; lia.
  + move=> i lt_in. rewrite (nth_map (Ordinal lt_in)) ?size_enum_ord //.
    by rewrite (tnth_nth x) ; f_equal ; rewrite nth_enum_ord //.
Qed.

Lemma card_bigcup_leif n (F : 'I_n -> set T) :
  #|\bigcup_i F i| <= \sum_i #|F i| ?= iff `[< disjointS F >].
Proof. Admitted.

End CardSet.

Lemma finset_ind (T : finType) (P : (set T) -> Prop) :
  P set0 ->
  (forall x S, x \notin S -> P S -> P (x |` S)) ->
  (forall S, P S).
Proof.
  move=> base step S ; remember #|S| as n.
  elim: n S Heqn => [S | n IH S cardS].
    by move=> /eqP ; rewrite eq_sym card0_set0 => /eqP -> ; apply base.
  have: #|S| != 0 by lia.
  rewrite card0_set0 => /set0P [x Sx].
  apply setD1K in Sx ; rewrite -Sx ; apply step.
    by rewrite notin_set /= ; intuition.
  apply IH ; move: cardS ; rewrite -{1}Sx set1U_disj_card ; first by lia.
  by rewrite notin_set /= ; intuition.
Qed.

Lemma interval_ind_rev n (P : nat -> Prop) :
  (forall k, k >= n -> P k) ->
  (forall k, k.+1 <= n -> P k.+1 -> P k) ->
  (forall k, P k).
Proof.
  elim: n => [|n IH] base step k ; first by apply base ; lia.
  apply IH => {} k.
  - case: (ltngtP n k) => [+ _| // |<- _] ; first by apply base.
    by apply step ; [|apply base] ; lia.
  - by move=> /leqW ; apply step.
Qed.

Lemma finset_ind_rev (T : finType) (P : (set T) -> Prop) :
  P setT ->
  (forall x S, x \notin S -> P (x |` S) -> P S) ->
  (forall S, P S).
Proof.
  move=> /= base step S ; remember #|S| as n.
  elim /(@interval_ind_rev #|T|) : n S Heqn => [k ge_kn | k lt_kn IH] S cardS.
    have /eqP -> : S == [set: T].
      by rewrite -card_leTif eqn_leq card_leTif /= -cardS.
    by apply base.
  have /setTPn [x N_Sx] : S != [set: T].
    by rewrite -(ltn_leqif (card_leTif _)) -cardS.
  apply (step x) ; first by rewrite notin_set.
  by apply IH ; rewrite cardS set1U_disj_card // notin_set.
Qed.

End ClassicalSetsExtras.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <aciclo@gmail.com>                                        *)
(*                                        Computer Science Department, USTC   *)
(*                                                                            *)
(*           Hui Zhang <sa512073@mail.ustc.edu.cn>                            *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import LibEx.
Require Import Lists.List.
Require Import Arith.
Require Import bnat.
Require Import Omega.

Set Implicit Arguments.
Unset Strict Implicit.

Fixpoint list_append {A: Set} (l: list A) (a: A) : list A :=
  match l with
    | nil => cons a nil
    | cons x l' => cons x (list_append l' a)
  end.

Fixpoint list_none_list {A: Set} (n: nat) : list (option A) :=
  match n with
    | O => nil
    | S n => cons None (list_none_list n)
  end.

Fixpoint list_repeat_list {A: Set} (n : nat) (elem : A) : list A :=
  match n with
    | O => nil
    | S n' => cons elem (list_repeat_list n' elem)
  end.

Fixpoint list_get {A: Set} (l: list A) (i: nat) : option A :=
  match i, l with
    | O, cons a l' => Some a
    | S i', cons a l' => list_get l' i'
    | _, _ => None
  end.

Fixpoint list_set {A: Set} (l: list A) (i: nat) (a: A): option (list A) :=
  match i, l with
    | O, cons a' l' => Some (cons a l')
    | S i', cons a' l' =>
      match list_set l' i' a with
        | None => None
        | Some l'' => Some (cons a' l'')
      end
    | _, _ => None
  end.

Lemma list_get_list_set_eq :
  forall {A: Set} (l: list A) (i: nat) (a: A) (l' : list A),
    list_set l i a = Some l'
    -> list_get l' i = Some a.
Proof.
  induction l.
    simpl; intros.
    destruct i.
      discriminate.
    discriminate.
  intros.
  destruct i.
  simpl in * .
  injection H.
  intro; subst l'.
  simpl.
  trivial.
  simpl in H.
  destruct (list_set l i a0) eqn:Hset; [| discriminate] .
  injection H.
  intro; subst l'.
  simpl.
  eapply IHl; eauto.
Qed.

Lemma list_get_list_set_neq :
  forall {A: Set} (l: list A) (i i': nat) (a: A) (l' : list A),
    list_set l i a = Some l'
    -> i <> i'
    -> list_get l' i' = list_get l i'.
Proof.
  induction l.
    simpl; intros.
    destruct i.
      discriminate.
    discriminate.
  intros.
  simpl in * .
  destruct i;
    destruct i'.
    destruct (H0 (refl_equal _)).
    injection H.
    intro; subst l'.
    simpl.
    trivial.
    destruct (list_set l i a0) eqn:Hset.
    injection H.
     intro; subst l'.
    simpl.
    trivial.
    discriminate.
  destruct (list_set l i a0) eqn:Hset; [| discriminate].
  assert (Hi: i <> i').
    auto with arith.
  injection H.
  intro; subst l'.
  simpl.
  eapply IHl; eauto.
Qed.

Lemma list_get_list_set :
  forall {A: Set} (l: list A) i (a a': A)  ,
    list_get l i = Some a
    -> exists l', list_set l i a' = Some l'.
Proof.
  induction l;  simpl; intros; auto.
    destruct i; discriminate.
  destruct i.
    exists (cons a' l).
    trivial.
  destruct (IHl i a0 a' H) as [l' Hl'].
  rewrite Hl'.
  exists (cons a l'); trivial.
Qed.

Lemma list_set_same :
  forall {A: Set} (l: list A) i (a : A)  ,
    list_get l i = Some a
    -> list_set l i a = Some l.
Proof.
  induction l;  simpl; intros; auto.
    destruct i; discriminate.
  destruct i.
    injection H; intro; subst a0.
    trivial.
  rewrite (IHl _ _ H).
  trivial.
Qed.

Lemma list_set_list_get_rev :
  forall {A: Set} (l: list A) (i: nat) (a: A) (l' : list A),
    list_set l i a = Some l'
    -> exists a', list_get l i = Some a'.
Proof.
  induction l.
    simpl; intros.
    destruct i.
      discriminate.
    discriminate.
  intros.
  destruct i.
  simpl in * .
  exists a; trivial.

  simpl in H.
  destruct (list_set l i a0) eqn:Hset; [| discriminate] .
  injection H.
  intro; subst l'.
  simpl.
  eapply IHl; eauto.
Qed.

Lemma list_get_list_repeat_list :
  forall {A: Set} i (a: A) n,
    i < n
    -> list_get (list_repeat_list n a) i = Some a.
Proof.
  induction i; simpl; intros; trivial.
    destruct n.
      apply False_ind.
      apply (gt_irrefl _ H); trivial.
    simpl.
    trivial.
  destruct n.
    apply gt_asym in H.
    apply False_ind.
    apply H.
    apply gt_Sn_O; trivial.
  simpl.
  apply IHi; trivial.
  apply gt_S_n; trivial.
Qed.

Lemma list_get_list_repeat_list_none :
  forall {A: Set} i (a: A) n,
    n <= i
    -> list_get (list_repeat_list n a) i = None.
Proof.
  induction i; simpl; intros; trivial.
    destruct n.
      simpl.
      trivial.
    apply False_ind.
    apply (le_Sn_0 _ H).
  destruct n.
    simpl; trivial.
  apply IHi; trivial.
  apply le_S_n; trivial.
Qed.

Lemma list_get_list_repeat_list_some_elim :
  forall {A: Set} i (a a' : A) n,
    list_get (list_repeat_list n a) i = Some a'
    -> blt_nat i n = true /\ a = a'.
Proof.
  induction i; simpl; intros; trivial.
    destruct n.
      simpl in H.
      discriminate.
    simpl in H.
    injection H; intro; subst a'.
    split; trivial.
  destruct n.
    simpl in H.
    discriminate.
  apply (IHi a a' n).
  simpl in H.
  trivial.
Qed.

(* ************************************************************************** *)

Lemma list_set_length_preserv:
  forall {A: Set} (l:list A) i l' (a: A),
    list_set l i a = Some l'
    -> length l' = length l.
Proof.
  induction l; destruct i; simpl; intros.
    discriminate.
    discriminate.
  destruct l' as [ | a' l'].
  discriminate.
  inversion H.
  subst a0 l'.
  simpl; trivial.
  destruct l' as [ | a' l'].
  destruct (list_set l i a0).
    inversion H.
    discriminate.
  simpl.
  destruct (list_set l i a0) eqn:Hset.
  inversion H; subst.
  assert (length l' = length l).
    eapply IHl; eauto.
  rewrite H0; trivial.
  discriminate.
Qed.

Lemma length_elim:
  forall {A: Set} (l: list A) len,
    length l = len
    -> forall i,
         (blt_nat i len = true -> exists a, list_get l i = Some a)
         /\ (blt_nat i len = false -> list_get l i = None).
Proof.
  induction l; simpl; intros; trivial.
    split.
      subst len.
      intros.
      simplbnat.
    subst len.
    intros.
    destruct i; trivial.
  destruct len.
    discriminate.
  injection H; intros.
  split.
    intros.
    destruct i.
      exists a; trivial.
    assert (blt_nat i len = true).
      simplbnat.
      trivial.
    destruct (IHl len H0 i) as [IH1 IH2].
    apply IH1; trivial.
  intros.
  destruct i.
    simplbnat.
  assert (blt_nat i len = false).
    simplbnat.
    trivial.
  destruct (IHl len H0 i) as [IH1 IH2].
  apply IH2; trivial.
Qed.

Lemma length_intro:
  forall {A: Set} (l: list A) len,
    (forall i,
         (blt_nat i len = true -> exists a, list_get l i = Some a)
         /\ (blt_nat i len = false -> list_get l i = None))
    -> length l = len.
Proof.
  induction l; simpl; intros; trivial.
    destruct (H 0) as [H1 H2].
    destruct len; trivial.
    assert (blt_nat 0 (S len) = true).
      simplbnat.
      trivial.
    destruct (H1 H0).
    discriminate.
  destruct len; trivial.
    destruct (H 0) as [H1 H2].
    assert (blt_nat 0 0 = false).
      simplbnat.
      trivial.
    discriminate (H2 H0).
  assert ((forall i : nat,
         (blt_nat i len = true -> exists a : A, list_get l i = Some a) /\
         (blt_nat i len = false -> list_get l i = None))).
    intros.
    split.
      intros.
      assert (blt_nat (S i) (S len) = true).
        simplbnat.
        trivial.
      destruct (H (S i)) as [Hx Hy].
      apply Hx; trivial.
    intros.
    assert (blt_nat (S i) (S len) = false).
      simplbnat.
      trivial.
    destruct (H (S i)) as [Hx Hy].
    apply Hy; trivial.
  rewrite (IHl len); trivial.
Qed.

(* ************************************************************************** *)

Fixpoint list_make_nat_list (i : nat) : list nat :=
  match i with
    | 0 => nil
    | S i' => list_append (list_make_nat_list i') i'
  end.

(* Eval compute in (list_make_nat_list 5). *)

Lemma list_get_list_append_some_elim :
  forall {A: Set} (l : list A) a a' i,
    list_get (list_append l a) i = Some a'
    -> (blt_nat i (length l) = true -> list_get l i = Some a')
       /\ (blt_nat i (length l) = false -> list_get l i = None /\ i = length l /\ a = a').
Proof.
  induction l.
    simpl.
    intros.
    destruct i.
      injection H; intro; subst a'.
      split.
        intro HF.
        simplbnat.
      intro Hx.
      split; trivial.
      split; trivial.
    destruct i; discriminate.
  simpl.
  intros ax a' i H.
  destruct i.
    injection H; intro; subst a'.
    split.
      intros; trivial.
    intros.
    simplbnat.
  simpl.
  split.
    intro Hx.
    destruct (IHl ax a' i H) as [H1 H2].
    apply H1; trivial.
  intro Hx.
  destruct (IHl ax a' i H) as [H1 H2].
  destruct (H2 Hx) as [H3 [H4 H5]].
  split; trivial.
  rewrite H4, H5.
  split; trivial.
Qed.

Lemma list_append_list_length :
  forall {A: Set} (l : list A) a,
    length (list_append l a) = S (length l).
Proof.
  induction l.
    simpl; trivial.
  intros.
  simpl.
  rewrite IHl.
  trivial.
Qed.

Lemma list_make_nat_list_length :
  forall n, length (list_make_nat_list n) = n.
Proof.
  induction n.
    simpl; trivial.
  simpl.
  rewrite list_append_list_length.
  rewrite IHn.
  trivial.
Qed.

Lemma list_make_nat_list_get_some_elim :
  forall n i a,
    list_get (list_make_nat_list n) i = Some a
    -> blt_nat a n = true /\ i = a.
Proof.
  induction n; trivial.
    intros.
    destruct i.
      simpl in H.
      discriminate.
    simpl in H.
    discriminate.
  intros i a H.
  destruct i.
    simpl in H.
    destruct (@list_get_list_append_some_elim _ _ _ _ _ H) as [H1 H2].
    rewrite list_make_nat_list_length in H1.
    rewrite list_make_nat_list_length in H2.
    destruct (blt_nat 0 n) eqn:Hn.
      destruct (IHn 0 a (H1 (refl_equal _))).
      split; trivial.
      solvebnat.
    destruct (H2 (refl_equal _)) as [H3 [H4 H5]].
    subst.
    subst a.
    simpl; split; trivial.
  simpl in H.
  destruct (@list_get_list_append_some_elim _ _ _ _ _ H) as [H1 H2].
  rewrite list_make_nat_list_length in H1.
  rewrite list_make_nat_list_length in H2.
  destruct (blt_nat (S i) n) eqn:Hn.
    destruct (IHn (S i) a (H1 (refl_equal _))) as [Hx Hy].
    split; trivial.
    solvebnat.
  destruct (H2 (refl_equal _)) as [H3 [H4 H5]].
  subst n a.
  split.
    simpl.
    simplbnat.
    trivial.
  trivial.
Qed.

Lemma list_get_list_append_some_intro :
  forall {A: Set} (l : list A) a a' i,
     (blt_nat i (length l) = true /\ list_get l i = Some a')
    \/ (beq_nat i (length l) = true /\ a = a')
    -> list_get (list_append l a) i = Some a'.
Proof.
  induction l.
    simpl.
    intros.
    destruct i.
      destruct H.
        destruct H; discriminate.
      destruct H; subst; trivial.
    destruct H.
      destruct H; discriminate.
    destruct H; discriminate.
  simpl.
  intros ax a' i H.
  destruct i.
    destruct H.
      destruct H; trivial.
    destruct H.
    desbnat.
    discriminate.
  simplbnat.
  destruct H.
    apply IHl.
    left; trivial.
  apply IHl.
  right.
  destruct H.
  split; trivial.
Qed.

Lemma list_make_nat_list_get_some_intro :
  forall n i,
    blt_nat i n = true
    -> list_get (list_make_nat_list n) i = Some i.
Proof.
  induction n.
    intros.
    simplbnat.
  intros.
  simpl.
  apply list_get_list_append_some_intro.
  rewrite list_make_nat_list_length.
  destruct (blt_S_dec _ _ H) as [H1 | H2].
    left.
    split.
      solvebnat.
    apply IHn; trivial.
  right.
  split; trivial.
  rewrite (beq_true_eq _ _ H2).
  trivial.
Qed.

(* ************************************************************************** *)

Fixpoint list_find_rec {A: Set} (beq : A -> A -> bool) (l: list A) (a: A) (i: nat) : option nat :=
  match l with
    | nil => None
    | cons a' l' =>
      match beq a a' with
        | true => Some i
        | false => list_find_rec beq l' a (S i)
      end
  end.

Definition list_find {A: Set} (beq : A -> A -> bool) (l: list A) (a: A) : option nat :=
  list_find_rec beq l a O.

Fixpoint list_find_rev {A: Set} (beq : A -> A -> bool) (l: list A) (a: A) : option nat :=
  match l with
    | nil => None
    | cons a' l' => match list_find_rev beq l' a with
                      | Some i' => Some (S i')
                      | None => match beq a a' with
                                  | true => Some 0
                                  | false => None
                                end
                    end
  end.

(* Section TEST. *)
(*   Let l := 1::2::3::4::4::5::2::nil. *)
(*   Eval compute in list_find_rev beq_nat l 9. *)
(* End TEST. *)

Lemma list_find_rev_list_get :
  forall {A: Set} (l: list A) (a : A) i beq,
    list_find_rev beq l a = Some i
    -> (forall a1 a2, beq a1 a2 = true -> a1 = a2)
    -> list_get l i = Some a.
Proof.
  induction l as [ | a' l']; simpl; intros; trivial.
    discriminate.
  destruct (list_find_rev beq l' a) eqn:Hfind; try discriminate.
    injection H; intro; subst i; clear H.
    apply (IHl' a n beq); auto.
  destruct (beq a a') eqn:Ha; try discriminate.
  injection H; intro; subst i; clear H.
  rewrite (H0 _ _ Ha); trivial.
Qed.

Lemma list_find_rev_mono_rev :
  forall {A: Set} (l: list A) (a a' : A) i beq,
    list_find_rev beq (a'::l) a = Some (S i)
    -> list_find_rev beq l a = Some i.
Proof.
  induction l as [ | a' l']; simpl; intros; trivial.
    destruct (beq a a'); discriminate.
  destruct (list_find_rev beq l' a) eqn:Hfind; try discriminate.
    injection H; intro; subst i; clear H.
    trivial.
  destruct (beq a a') eqn:Ha; try discriminate.
    injection H; intro; subst i; clear H.
    trivial.
  destruct (beq a a'0).
    discriminate.
  discriminate.
Qed.

Lemma list_find_rev_mono :
  forall {A: Set} (l: list A) (a a' : A) i beq,
    list_find_rev beq l a = Some i
    -> list_find_rev beq (a'::l) a = Some (S i).
Proof.
  intros; simpl; trivial.
  rewrite H.
  trivial.
Qed.

Lemma list_get_list_find_rev :
  forall {A: Set} i (l: list A) (a : A) beq,
    list_get l i = Some a
  -> (forall i' a', i' > i
                 -> list_get l i' = Some a'
                 -> a <> a')
  -> (forall a1 a2, a1 = a2 -> beq a1 a2 = true)
  -> (forall a1 a2, beq a1 a2 = true -> a1 = a2)
  -> list_find_rev beq l a = Some i.
Proof.
  induction i; simpl; intros; trivial.
    destruct l as [ | a' l'].
      simpl in H.
      discriminate.
    simpl in H.
    injection H; intro; subst a'; clear H.
    simpl.
    rewrite (H1 a a (refl_equal _)).
    destruct (list_find_rev beq l' a) eqn:Hfind; trivial.
    assert (HF:= H0 (S n) a).
    assert (Hget:= list_find_rev_list_get Hfind H2).
    simpl in  HF.
    apply False_ind.
    apply HF; trivial.
    auto with arith.
  destruct l as [ | a' l' ].
    simpl in H.
    discriminate.
  simpl in H.
  apply list_find_rev_mono; trivial.
  apply IHi; eauto.
  intros.
  apply H0 with (S i'); auto.
  apply lt_n_S; trivial.
Qed.

Lemma list_set_list_find_rev_neq :
  forall {A:Set} (l l':list A) i a a' a'' beq,
    list_get l i = Some a
    -> list_set l i a' = Some l'
    -> a'' <> a'
    -> a'' <> a
    -> (forall a1 a2, a1 <> a2 -> beq a1 a2 = false)
    -> (forall a1 a2, beq a1 a2 = false -> a1 <> a2)
    -> list_find_rev beq l' a'' = list_find_rev beq l a''.
Proof.
  induction l; simpl; intros; trivial.
    destruct i; discriminate.
  destruct i.
    injection H; intro; subst a0; clear H.
    injection H0; intro; subst l'; clear H0.
    simpl.
    destruct (list_find_rev beq l a'') eqn:Hfind; trivial.
    rewrite (H3 a'' a' H1).
    rewrite (H3 a'' a H2).
    trivial.
  destruct (list_set l i a') eqn:Hset; try discriminate.
  injection H0; intro; subst l'; clear H0.
  simpl.
  rewrite (IHl l0 i a0 a' a'' beq H Hset H1 H2 H3 H4).
  destruct (list_find_rev beq l a'') eqn:Hfind; trivial.
Qed.

(* ************************************************************************** *)

Fixpoint list_inb {A: Set} (beq : A -> A -> bool) (l: list A) (a : A) : bool :=
  match l with
    | nil => false
    | cons a' l' => match beq a a' with
                      | true => true
                      | false => list_inb beq l' a
                    end
  end.

Lemma list_inb_false_elim :
  forall {A: Set} (l: list A) a beq,
    list_inb beq l a = false
    -> (forall a1 a2, beq a1 a2 = false -> a1 <> a2)
    -> (forall i' a',
          list_get l i' = Some a'
          -> a <> a'
       ).
Proof.
  induction l as [ | a' l'].
    simpl; intros.
    destruct i'; discriminate.
  simpl.
  intros a beq H Hbeq2 i' a2 Hgi'.
  destruct (beq a a') eqn: Hb; try discriminate.
  destruct i'.
    injection Hgi'; intro; subst a2.
    apply Hbeq2; trivial.
  apply IHl' with beq i'; trivial.
Qed.

Lemma list_inb_true_elim :
  forall {A: Set} (l: list A) a beq,
    list_inb beq l a = true
    -> (forall a1 a2, beq a1 a2 = true -> a1 = a2)
    -> exists i',
         list_get l i' = Some a.
Proof.
  induction l as [ | a' l'].
    simpl; intros.
    discriminate.
  simpl.
  intros a beq H Hbeq .
  destruct (beq a a') eqn: Hb.
    exists 0.
    rewrite (Hbeq a a' Hb).
    trivial.
  destruct (IHl' a beq H Hbeq) as [i' Hi'].
  exists (S i').
  trivial.
Qed.

Lemma list_inb_true_intro :
  forall {A: Set} (l: list A) a beq i,
    list_get l i = Some a
    -> (forall a1 a2, beq a1 a2 = false -> a1 <> a2)
    -> list_inb beq l a = true.
Proof.
  induction l as [ | a' l'].
    simpl; intros.
    destruct i; discriminate.
  simpl.
  intros a beq i H Hbeq2 .
  destruct (beq a a') eqn: Hb; trivial.
  destruct i.
    injection H; intro; subst a'.
    destruct (Hbeq2 _ _ Hb (refl_equal _)).
  apply IHl' with i; trivial.
Qed.

(* ************************************************************************** *)

Fixpoint list_unique {A: Set} (beq : A -> A -> bool) (l : list A) : bool :=
  match l with
    | nil => true
    | cons a' l' => match list_inb beq l' a' with
                 | true => false
                 | false => list_unique beq l'
               end
  end.

Lemma list_unique_elim :
  forall {A: Set} (l: list A) beq,
    list_unique beq l = true
    -> (forall a1 a2, beq a1 a2 = false -> a1 <> a2)
    -> (forall i i' a a',
          i <> i'
          -> list_get l i = Some a
          -> list_get l i' = Some a'
          -> a <> a'
       ).
Proof.
  induction l as [ | a' l'].
    simpl; intros.
    destruct i; discriminate.
  simpl.
  intros beq H Hbeq i1 i2 a1 a2 Hneq Hgi1 Hgi2.
  destruct i1.
    injection Hgi1; intro; subst a'.
    destruct (list_inb beq l' a1) eqn:Hinb; try discriminate.
    destruct i2.
      destruct (Hneq (refl_equal _)).
    apply (list_inb_false_elim Hinb Hbeq Hgi2).
  destruct i2.
    injection Hgi2; intro; subst a'.
    destruct (list_inb beq l' a2) eqn:Hinb; try discriminate.
    apply neq_sym.
    apply (list_inb_false_elim Hinb Hbeq Hgi1).
  destruct (list_inb beq l' a') eqn:Hinb; try discriminate.
  apply IHl' with beq i1 i2; trivial.
  intro HF; subst i1.
  destruct (Hneq (refl_equal _)).
Qed.

Lemma list_unique_intro :
  forall {A: Set} (l: list A) beq,
    (forall a1 a2, beq a1 a2 = false -> a1 <> a2)
    -> (forall a1 a2, beq a1 a2 = true -> a1 = a2)
    -> (forall i i' a a',
          i <> i'
          -> list_get l i = Some a
          -> list_get l i' = Some a'
          -> a <> a'
       )
    -> list_unique beq l = true.
Proof.
  induction l as [ | a' l'].
    simpl; intros.
    trivial.
  simpl.
  intros beq Hbeq1 Hbeq2 H.
  destruct (list_inb beq l' a') eqn:Hinb.
    destruct (list_inb_true_elim Hinb Hbeq2) as [ix Hix].
    assert (Hx := H 0 (S ix) a' a').
    simpl in Hx.
    apply False_ind.
    apply Hx; trivial.
  apply IHl'; trivial.
  intros i1 i2 a1 a2 Hneq Ha1 Ha2.
  apply (H (S i1) (S i2) _ _); trivial.
  auto with arith.
Qed.

(* ************************************************************************** *)

Fixpoint list_remove {A:Set} (beq: A -> A -> bool) (x : A) (l : list A) : list A :=
  match l with
    | nil => nil
    | y::tl => if (beq x y) then list_remove beq x tl else y::(list_remove beq x tl)
  end.

Lemma list_inb_list_remove_neq :
  forall {A: Set} (l: list A) (a a' : A) beq,
    a' <> a
    -> (forall a1 a2, beq a1 a2 = true -> a1 = a2)
    -> list_inb beq (list_remove beq a' l) a = list_inb beq l a.
Proof.
  induction l; simpl; intros; trivial.
  destruct (beq a' a) eqn:Ha1.
    destruct (beq a0 a) eqn:Ha2.
      rewrite (H0 _ _ Ha1) in H.
      rewrite (H0 _ _ Ha2) in H.
      destruct (H (refl_equal _)).
    assert (a' = a).
      apply H0; trivial.
    subst a'.
    rewrite IHl; trivial.
  simpl.
  destruct (beq a0 a) eqn:Ha2.
    trivial.
  rewrite IHl; trivial.
Qed.

Lemma list_remove_preserv_list_unique :
  forall {A:Set} (l l' : list A) a beq,
    list_unique beq l = true
    -> (forall a1 a2, beq a1 a2 = false -> a1 <> a2)
    -> (forall a1 a2, beq a1 a2 = true -> a1 = a2)
    -> l' =  list_remove beq a l
    -> list_unique beq l' = true.
Proof.
  induction l; simpl; intros.
    subst; simpl; trivial.
  destruct (list_inb beq l a) eqn:Hinb; try discriminate.
  destruct (beq a0 a) eqn:Hbeq.
    assert (a0 = a).
    apply H1; trivial.
    subst a0.
    apply IHl with a; trivial.
  rewrite H2.
  simpl.
  destruct (list_inb beq (list_remove beq a0 l) a) eqn:Hx.
    assert (a0 <> a).
      apply H0; trivial.
    rewrite list_inb_list_remove_neq in Hx; trivial.
    rewrite Hx in Hinb.
    discriminate.
  apply IHl with a0; trivial.
Qed.

Lemma list_inb_false_list_remove :
  forall {A:Set} (l : list A) a beq,
    list_inb beq l a = false
    -> l = list_remove beq a l.
Proof.
  induction l as [ | a' l'].
    simpl; intros.
    trivial.
  intros a beq Hinb.
  simpl in * .
  destruct (beq a a') eqn:Hneq; try discriminate.
  rewrite (IHl' a beq Hinb) at 1; trivial.
Qed.

Lemma list_length_subone_after_list_remove :
  forall {A:Set} (l l': list A) a beq,
    list_unique beq l = true
    -> list_inb beq l a = true
    -> l' = list_remove beq a l
    -> (forall a1 a2, beq a1 a2 = false -> a1 <> a2)
    -> (forall a1 a2, beq a1 a2 = true -> a1 = a2)
    -> S (length l') = length l.
Proof.
  induction l as [ | a l].
    simpl; intros.
    discriminate.
  intros l' a' beq Hlu Hinb Hl' Hbeqfe Hbeqte.
  simpl in * .
  destruct (beq a' a) eqn:Hbeq.
    destruct (list_inb beq l a) eqn:Hinb2; try discriminate.
    assert (a' = a).
      apply Hbeqte; trivial.
    subst a'.
    rewrite Hl'.
    rewrite <- list_inb_false_list_remove; trivial.
  rewrite Hl'.
  simpl.
  destruct (list_inb beq l a) eqn:Hinb2; try discriminate.
  assert (Hx := IHl (list_remove beq a' l) a' beq Hlu Hinb (refl_equal _) Hbeqfe Hbeqte).
  rewrite Hx.
  trivial.
Qed.

Lemma list_remove_list_inb_false :
  forall {A:Set} (l l': list A) a beq,
    l' = list_remove beq a l
    -> list_inb beq l' a = false.
Proof.
  induction l as [ | a l ].
    simpl; intros.
    subst l'.
    simpl.
    trivial.
  intros l' a' beq Hl'.
  simpl in Hl'.
  destruct (beq a' a) eqn:Hbeq.
    rewrite IHl; trivial.
  rewrite Hl'.
  simpl.
  rewrite Hbeq.
  rewrite IHl; auto.
Qed.

(* ************************************************************************** *)

Fixpoint list_filter {A: Set} (l : list A) (f: A -> bool) : list A :=
  match l with
    | nil => nil
    | cons a' l' => match f a' with
                 | true => a' :: list_filter l' f
                 | false => list_filter l' f
               end
  end.

Fixpoint list_filter_domain {A: Set} (l : list A) (f: A -> bool) (i: nat): list nat :=
  match l with
    | nil => nil
    | cons a' l' => match f a' with
                 | true => i :: list_filter_domain l' f (S i)
                 | false => list_filter_domain l' f (S i)
               end
  end.

Lemma list_filter_domain_is_greater_equal_than_base :
  forall {A: Set} (l:list A) i base f beq,
    i < base
    -> (forall a1 a2, a1 <> a2 -> beq a1 a2 = false)
    -> list_inb beq (list_filter_domain l f base) i = false .
Proof.
  induction l.
    simpl; trivial.
  intros i base f beq Hi Hbeqnf.
  simpl.
  destruct (f a) eqn: Hf.
    simpl.
    assert (beq i base = false).
      apply Hbeqnf.
      clear - Hi.
      omega.
    rewrite H.
    apply IHl; trivial.
    auto with arith.
  apply IHl.
  omega.
  trivial.
Qed.

Lemma list_filter_domain_elim :
  forall {A: Set} (l:list A) i base f beq,
    list_inb beq (list_filter_domain l f base) (base + i) = true
    -> (forall a1 a2, a1 <> a2 -> beq a1 a2 = false)
    -> (forall a1 a2, beq a1 a2 = true -> a1 = a2)
    -> exists a, list_get l i = Some a
                 /\ f a = true.
Proof.
  induction l.
    simpl; intros.
    discriminate.
  simpl.
  intros i base f beq Hinb Hbeqnf Hbeqte.
  assert (forall i j, i + S j = S i + j).
    clear.
    intros; omega.
  destruct (f a) eqn: Hf.
    destruct i.
      simpl in * .
      exists a; split; trivial.
    simpl in Hinb.
    destruct (beq (base + S i) base) eqn:Hbase.
      assert (forall i j, i + S j <> i).
        clear.
        intros.
        omega.
      rewrite (Hbeqnf _ _ (H0 base i)) in Hbase.
      discriminate.
    apply IHl with (S base) beq; trivial.
    rewrite H in Hinb.
    trivial.
  destruct i.
    rewrite (list_filter_domain_is_greater_equal_than_base) in Hinb; trivial.
    discriminate.
    clear.
    omega.
  apply IHl with (S base) beq; trivial.
  rewrite H in Hinb.
  trivial.
Qed.

Lemma list_unique_list_filter_domain :
  forall {A: Set} (l : list A) f base,
    (* (forall a1 a2, beq a1 a2 = true -> a1 = a2) *)
    list_unique beq_nat (list_filter_domain l f base) = true.
Proof.
  induction l.
    simpl.
    trivial.
  simpl.
  intros f base.
  destruct (f a) eqn: Hf.
    simpl.
    rewrite list_filter_domain_is_greater_equal_than_base; trivial.
    omega.
    apply neq_beq_false.
  rewrite IHl with f (S base).
  trivial.
Qed.

Lemma list_filter_domain_intro :
  forall {A: Set} (l:list A) i base f beq ,
    forall a,
      list_get l i = Some a
      -> f a = true
      -> (forall a1 a2, a1 <> a2 -> beq a1 a2 = false)
      -> (forall a1 a2, a1 = a2 -> beq a1 a2 = true)
      -> list_inb beq (list_filter_domain l f base) (base + i) = true.
Proof.
  induction l.
    simpl; intros.
    destruct i; discriminate.
  simpl.
  intros i base f beq ax Hg Hf Hbeqnf Hbeqet.
  (* assert (forall i j, i + S j = S i + j). *)
  (*   clear. *)
  (*   intros; omega. *)
  destruct (f a) eqn: Hfa.
    destruct i.
      simpl.
      assert (beq (base + 0) base = true).
      apply Hbeqet.
      omega.
      rewrite H.
      trivial.
    simpl.
    assert (beq (base + S i) base = false).
      apply Hbeqnf.
      omega.
    rewrite H.
    assert (base + S i = S base + i).
      omega.
      rewrite H0.
    apply (IHl i (S base) f beq ax); trivial.
  destruct i.
    injection Hg; intro; subst ax; clear Hg.
    rewrite Hfa in Hf.
    discriminate.
  assert (base + S i = S base + i).
    omega.
    rewrite H.
  apply (IHl i (S base) f beq ax); trivial.
Qed.

(* ************************************************************************** *)

Fixpoint list_opt_dual_filter {A: Set} (l : list (prod (option A) (option A))) (f: A -> bool) : list A :=
  match l with
    | nil => nil
    | cons (Some a1, Some a2) l' =>
               match (f a1, f a2) with
                 | (true, true) => a1 :: a2 :: list_opt_dual_filter l' f
                 | (true, false) => a1 :: list_opt_dual_filter l' f
                 | (false, true) => a2 :: list_opt_dual_filter l' f
                 | (false, false) => list_opt_dual_filter l' f
               end

    | cons (Some a1, None) l' =>
               match (f a1) with
                 | true => a1 :: list_opt_dual_filter l' f
                 | false => list_opt_dual_filter l' f
               end

    | cons (None, Some a2) l' =>
               match (f a2) with
                 | true => a2 :: list_opt_dual_filter l' f
                 | false => list_opt_dual_filter l' f
               end

    | cons (None, None) l' =>  list_opt_dual_filter l' f
  end.

(* ************************************************************************** *)

Lemma list_length_after_permutation:
  forall {A:Set} (l l': list A) beq,
    list_unique beq l = true
    -> list_unique beq l' = true
    -> (forall i a, list_get l i = Some a
       -> list_inb beq l' a = true)
    -> (forall i a, list_get l' i = Some a
       -> list_inb beq l a = true)
    -> (forall a1 a2, beq a1 a2 = false -> a1 <> a2)
    -> (forall a1 a2, beq a1 a2 = true -> a1 = a2)
    -> length l = length l'.
Proof.
  induction l as [ | a l].
    simpl; intros.
    destruct l' as [ | a' l'].
      simpl; trivial.
    assert (Hx : list_get (a' :: l') 0 = Some a').
      simpl; trivial.
    discriminate (H2 _ _ Hx).
  intros l' beq Hlu Hlu' Hsub Hsub' Hbeqfe Hbeqte.
  set (lx := list_remove beq a l').
  assert (list_unique beq l = true).
    simpl in Hlu.
    destruct (list_inb beq l a) eqn:Hinb; try discriminate.
    trivial.
  assert (list_unique beq lx = true).
    apply list_remove_preserv_list_unique with l' a; trivial.
  assert (length l = length lx).
    apply IHl with beq; trivial.

    intros i ax Hax.
    assert (Hneq : a <> ax).
      intro HF.
      subst ax.
      simpl in Hlu.
      destruct (list_inb beq l a) eqn:Hinb; try discriminate.
      assert (Hx := list_inb_false_elim Hinb Hbeqfe).
      apply (Hx i a); trivial.
    assert (Hx := Hsub (S i) ax).
    simpl in Hx.
    apply Hx in Hax.
    subst lx.
    rewrite (list_inb_list_remove_neq _ Hneq Hbeqte); trivial.

    intros i ax Hax.
    assert (Hneq : a <> ax).
      intro HF.
      subst ax.
      assert (Hx := @list_remove_list_inb_false _ l' lx a beq (refl_equal _)).
      assert (Hy := @list_inb_false_elim _ _ _ _ Hx Hbeqfe i a Hax).
      apply Hy; trivial.
    assert (Hx : list_inb beq l' ax = true).
      rewrite <- (@list_inb_list_remove_neq _ _ _ _ _ Hneq Hbeqte); trivial.
      subst lx.
      apply list_inb_true_intro with i; trivial.
    destruct (@list_inb_true_elim _ _ _ _ Hx Hbeqte) as [ix Hgx].
    assert (Hy := Hsub' ix ax Hgx).
    simpl in Hy.
    destruct (beq ax a) eqn:Hax2.
      destruct ((neq_sym Hneq) (Hbeqte _ _ Hax2)).
    trivial.
  simpl.
  rewrite H1.
  assert (list_inb beq l' a = true).
    apply Hsub with 0.
    simpl; trivial.
  rewrite (@list_length_subone_after_list_remove _ _ _ _ _ Hlu' H2 ); trivial.
Qed.

Unset Implicit Arguments.


Require Import List.

Require Import ssreflect.

Set Default Goal Selector "!".

Lemma Forall_repeatI {X : Type} {P : X -> Prop} {x n} :
  P x -> Forall P (repeat x n).
Proof.
  elim: n; first by constructor.
  move=> ? IH ?. constructor; [done | by apply: IH].
Qed.

Lemma In_appl {X : Type} {x: X} {l1 l2: list X} : In x l1 -> In x (l1 ++ l2).
Proof. move=> ?. apply: in_or_app. by left. Qed.

Lemma In_appr {X : Type} {x: X} {l1 l2: list X} : In x l2 -> In x (l1 ++ l2).
Proof. move=> ?. apply: in_or_app. by right. Qed.


(** in_before, in_between & succ_in **)
Require Import Lists.List.
Require Import Coq.Program.Equality.
Require Import Coq.Classes.EquivDec.
Require Export Util ListExtra PreSuffix DecTac.

Local Definition prefix_nincl' {A : Type} `{EqDec A eq} (a : A) l
  := rev (postfix_nincl a (rev l)).

Section aux.

  Context {A : Type} `{EqDec A eq}.

  Lemma postfix_nincl_rcons_a (a : A) (l : list A)
    : postfix_nincl a (l :r: a) = postfix_nincl a l.
  Proof.
    induction l; cbn; eauto.
    - decide' (a == a);[eauto|congruence].
    - decide' (a == a0);eauto.
      rewrite <-IHl. reflexivity.
  Qed.

  Hint Resolve postfix_nincl_rcons_a : core.

  Lemma postfix_nincl_app_in (a : A) (l l' : list A)
        (Hin : a ∈ l)
    : postfix_nincl a (l ++ l') = postfix_nincl a l.
  Proof.
    induction l; cbn; eauto.
    - contradiction.
    - destruct Hin; subst.
      + decide' (a == a); eauto. congruence.
      + decide' (a == a0);eauto.
        rewrite IHl;eauto.
  Qed.

  Hint Resolve postfix_nincl_app_in : core.

  Lemma post_pre_nincl_NoDup (l : list A) (a : A)
        (Hnd : NoDup l)
        (Hin : a ∈ l)
    : l = postfix_nincl a l ++ a :: prefix_nincl' a l.
  Proof.
    induction l; cbn in *;[contradiction|].
    destruct Hin;subst.
    - decide' (a == a); [|congruence]. cbn.
      f_equal.
      rewrite postfix_nincl_rcons_a.
      rewrite postfix_nincl_invariant; eauto using rev_involutive.
      rewrite <-in_rev. inversion Hnd; eauto.
    - decide' (a == a0);[inversion Hnd;subst;contradiction|cbn].
      f_equal. rewrite postfix_nincl_app_in. eapply IHl; inversion Hnd; eauto.
      rewrite <-in_rev; eauto.
  Qed.

  Lemma postfix_nincl_rev_prefix_nincl' (a : A) l
    : rev (postfix_nincl a l) = prefix_nincl' a (rev l).
  Proof.
    unfold prefix_nincl'. rewrite rev_involutive. reflexivity.
  Qed.

  Lemma NoDup_rcons (l : list A) a
        (Hnd : NoDup l)
        (Hnin : a ∉ l)
    : NoDup (l :r: a).
  Proof.
    induction l; cbn; eauto.
    - econstructor;eauto.
    - econstructor.
      + contradict Hnin.
        eapply In_rcons in Hnin. destruct Hnin;[left;eauto|inversion Hnd;contradiction].
      + eapply IHl; inversion Hnd;subst; eauto.
  Qed.

  Lemma NoDup_rev (l : list A)
    : NoDup l -> NoDup (rev l).
  Proof.
    intros Hnd; induction Hnd; cbn;eauto.
    econstructor.
    eapply NoDup_rcons;eauto. rewrite <-in_rev;eauto.
  Qed.

End aux.

Inductive splinter {A : Type} : list A -> list A -> Prop :=
| sl_nil : splinter nil nil
| sl_copy l l' a : splinter l (a :: l') -> splinter (a :: l) (a :: l')
| sl_skip l l' a : splinter l l' -> splinter l (a :: l').

Inductive splinter_strict {A : Type} : list A -> list A -> Prop :=
| sls_nil : splinter_strict nil nil
| sls_sim l l' a : splinter_strict l l' -> splinter_strict (a :: l) (a :: l')
| sls_skip l l' a : splinter_strict l l' -> splinter_strict l (a :: l').

(*Notation "l1 ⊴ l2" := (splinter l1 l2) (at level 70).*)

(* Read: a succeeds b in l modulo reflexivity and transitivity *)
Notation "a ≻* b | l" := (splinter (a :: b :: nil) l) (at level 70, b at next level).
Notation "a ≻* b ≻* c | l" := (splinter (a :: b :: c :: nil) l) (at level 70,
                                                                 b at next level,
                                                                c at next level).
Notation "a ≻* b ≻* c ≻* d | l" := (splinter (a :: b :: c :: d :: nil) l) (at level 70,
                                                                           b at next level,
                                                                           c at next level,
                                                                           d at next level).
Notation "a ≻* b ≻* c ≻* d ≻* e | l" := (splinter (a :: b :: c :: d :: e :: nil) l) (at level 70,
                                                                                b at next level,
                                                                                c at next level,
                                                                                d at next level).

Definition succ_in {A : Type} l (a b : A)
  := exists l1 l2, l = l2 ++ a :: b :: l1.

Notation "a ≻ b | l" := (succ_in l a b) (at level 70).

Module SplinterAux.

  Section splinter_aux.

    Context {A : Type} `{EqDec A eq}.

    Lemma splinter_double (l1 l2 l' : list A) a
          (Hsp : splinter (l1 ++ a :: l2) l')
      : splinter (l1 ++ a :: a :: l2) l'.
    Proof.
      dependent induction Hsp;cbn in *.
      - congruence'.
      - destruct l1; inversion x; subst; cbn in *.
        + do 2 econstructor;eauto.
        + econstructor. eapply IHHsp; eauto.
      - econstructor. eapply IHHsp; eauto.
    Qed.

    Hint Resolve splinter_double : core.

    Lemma splinter_remove (l1 l2 l' : list A) a
          (Hsp : splinter (l1 ++ a :: l2) l')
      : splinter (l1 ++ l2) l'.
    Proof.
      dependent induction Hsp; cbn in *; subst.
      - congruence'.
      - destruct l1; inversion x; subst; cbn in *; eauto.
        econstructor. eapply IHHsp; eauto.
      - econstructor. eapply IHHsp;eauto.
    Qed.

    Hint Resolve splinter_remove : core.

    Lemma splinter_remove_dup (l1 l2 l' : list A) a
          (Hsp : splinter l' (l1 ++ a :: a :: l2))
      : splinter l' (l1 ++ a :: l2).
    Proof.
      dependent induction Hsp; cbn in *; subst.
      - congruence'.
      - destruct l1; cbn in *.
        + inversion x; subst. econstructor. specialize (IHHsp H nil). cbn in IHHsp.
          eapply IHHsp. reflexivity.
        + inversion x; subst. econstructor. rewrite app_comm_cons. eapply IHHsp;eauto.
      - destruct l1; cbn in *.
        + inversion x; subst; eauto.
        + econstructor. eapply IHHsp; eauto. inversion x; subst; eauto.
    Qed.

    Hint Resolve splinter_remove_dup : core.

    Lemma splinter_rcons_right (a : A) l l'
          (Hsp : splinter l l')
      : splinter l (l' :r: a).
    Proof.
      induction Hsp; cbn in *; econstructor;eauto.
      econstructor.
    Qed.

    Hint Resolve splinter_rcons_right : core.

    Hint Constructors splinter : core.

    Lemma splinter_rcons_left (a : A) l l'
          (Hsp : splinter l (l' :r: a))
      : splinter (l :r: a) (l' :r: a).
    Proof.
      dependent induction Hsp; cbn in *.
      - congruence'.
      - rewrite <-x. econstructor. rewrite x. eauto.
      - rewrite <-x. destruct l'; cbn in *.
        + inversion x; subst. inversion Hsp; subst; cbn; eauto.
        + econstructor. inversion x; subst. eapply IHHsp; eauto.
    Qed.

  End splinter_aux.

End SplinterAux.

Import SplinterAux.

Hint Resolve
     splinter_double
     splinter_remove
     splinter_remove_dup
     splinter_rcons_left
     splinter_rcons_right : splinter.
Section splinterStrict.
  Variable (A : Type).

    Lemma splinter_strict_rcons_right (a : A) l l'
          (Hsp : splinter_strict l l')
      : splinter_strict l (l' :r: a).
    Proof.
      induction Hsp; cbn in *; econstructor;eauto.
      econstructor.
    Qed.

    Lemma splinter_strict_rcons (a : A) l l'
          (Hsp : splinter_strict l l')
      : splinter_strict (l :r: a) (l' :r: a).
    Proof.
      dependent induction Hsp; cbn in *.
      - econstructor. econstructor.
      - econstructor. fold (l :r: a). fold (l' :r: a). auto.
      - econstructor. fold (l' :r: a). auto.
    Qed.

    Hint Resolve splinter_strict_rcons splinter_strict_rcons_right : core.

  Lemma splinter_strict_rev (l l' : list A)
    : splinter_strict l l' <-> splinter_strict (rev l) (rev l').
  Proof.
    revert l l'.
    enough (forall (l l' : list A), splinter_strict l l' -> splinter_strict (rev l) (rev l')).
    {
      split;eauto. intros Hrev. rewrite <-rev_involutive. rewrite <- rev_involutive at 1.
      eapply H; eauto.
    }
    intros ? ? Hsp.
    induction Hsp; cbn in *; eauto;econstructor.
  Qed.

  Lemma splinter_strict_incl (l l' : list A)
    : splinter_strict l l' -> l ⊆ l'.
  Proof.
    intros.
    induction H;eauto.
  Qed.

  Lemma splinter_strict_refl (l : list A)
    : splinter_strict l l.
  Proof.
    induction l;econstructor;auto.
  Qed.

  Lemma splinter_strict_prefix (l1 l2 : list A)
        (Hpre : Prefix l1 l2)
    : splinter_strict l1 l2.
  Proof.
    induction Hpre;[eauto using splinter_strict_refl|econstructor;auto].
  Qed.

  Lemma splinter_strict_nil (l : list A)
    : splinter_strict [] l.
  Proof.
    induction l;econstructor;eauto.
  Qed.

  Hint Resolve splinter_strict_nil splinter_strict_prefix splinter_strict_refl : core.

  Global Instance splinter_strict_trans
    : Transitive (@splinter_strict A).
  Proof.
    unfold Transitive. intros.
    revert dependent z.
    induction H;intros;eauto with splinter.
    - dependent induction H0;subst.
      + econstructor. eapply IHsplinter_strict;eauto.
      + econstructor. eapply IHsplinter_strict0;eauto.
    - dependent induction H0.
      + econstructor;eauto.
      + econstructor;eauto.
  Qed.

End splinterStrict.

Hint Resolve splinter_strict_nil splinter_strict_prefix splinter_strict_refl : splinter.

Section splinter.
  Context {A : Type} `{EqDec A eq}.

  Lemma splinter_prefix (l l1 l2 : list A)
        (Hin : splinter l l1)
        (Hpre : Prefix l1 l2)
    : splinter l l2.
  Proof.
    induction Hpre; eauto.
    econstructor; eauto.
  Qed.

  Lemma splinter_nil (l : list A)
    : splinter nil l.
  Proof.
    induction l; econstructor;eauto.
  Qed.

  Hint Constructors splinter : core.

  Lemma splinter_refl (l : list A)
    : splinter l l.
  Proof.
    induction l; eauto with splinter.
  Qed.

  Lemma splinter_app (l1 l2 l1' l2' : list A)
        (Hleft : splinter l1' l1)
        (Hright : splinter l2' l2)
    : splinter (l1' ++ l2') (l1 ++ l2).
  Proof.
    induction Hleft; cbn in *;eauto.
  Qed.

  Lemma splinter_in (a : A) l l'
        (Hsp : splinter (a :: l) l')
    : a ∈ l'.
  Proof.
    clear H equiv0.
    dependent induction Hsp;[firstorder|].
    (*do 2 exploit' IHHsp. *)
    specialize (IHHsp a l x).
    firstorder.
  Qed.

  Lemma splinter_cons (a : A) l l'
        (Hsp : splinter (a :: l) l')
    : splinter l l'.
  Proof.
    clear H equiv0.
    dependent induction Hsp.
    - subst. eauto.
    - specialize (IHHsp a l x). econstructor;eauto.
  Qed.

  Lemma splinter_incl (l l' : list A)
        (Hsp : splinter l l')
    : l ⊆ l'.
  Proof.
    induction l; cbn; [firstorder|].
    unfold incl. intros a0 Ha0. destruct Ha0;subst.
    - eapply splinter_in; eauto.
    - eapply IHl;eauto. eapply splinter_cons. eauto.
  Qed.

  Hint Resolve splinter_nil splinter_in splinter_incl : splinter.

  Lemma splinter_single (a : A) l
    : splinter (a :: nil) l <-> a ∈ l.
  Proof.
    split; intro Hsp; [eapply splinter_in;eauto|].
    induction l;[contradiction|].
    destruct Hsp;subst; repeat (econstructor;eauto with splinter).
  Qed.

  Lemma splinter_lr l l' (a : A)
        (Hsp : splinter l l')
    : splinter (a :: l) (a :: l').
  Proof.
    econstructor;econstructor;eauto.
  Qed.

  Lemma splinter_trans (l1 l2 l3 : list A)
        (H12 : splinter l1 l2)
        (H23 : splinter l2 l3)
    : splinter l1 l3.
  Proof.
    revert dependent l1;induction H23;intros;eauto.
    - dependent induction H12; do 2 exploit' IHsplinter0; intros.
      + econstructor. eapply IHsplinter0;eauto.
      + eapply IHsplinter; eauto.
  Qed.

  Hint Constructors splinter: core.

  Lemma splinter_rev (l l' : list A)
    : splinter l l' <-> splinter (rev l) (rev l').
  Proof.
    revert l l'.
    enough (forall (l l' : list A), splinter l l' -> splinter (rev l) (rev l')).
    {
      split;eauto. intros Hrev. rewrite <-rev_involutive. rewrite <- rev_involutive at 1.
      eapply H0; eauto.
    }
    intros ? ? Hsp.
    induction Hsp; cbn in *; eauto with splinter.
  Qed.

  Lemma splinter_app_l (a : A) l0 l l'
        (Hnd : NoDup l0)
        (Hleft : splinter (l :r: a) l0)
        (Hright : splinter (a :: l') l0)
    : splinter (l ++ a :: l') l0.
  Proof.
    rewrite (@post_pre_nincl_NoDup _ _ _ l0 a);eauto; [|eapply splinter_incl;eauto;firstorder].
    eapply splinter_remove_dup. setoid_rewrite app_cons_assoc at 2.
    assert (forall (l' l0 : list A),
               NoDup l0
               -> splinter (a :: l') l0
               -> splinter l' (a :: prefix_nincl' a l0)).
    {
      clear. intros ? ? Hnd Hsp.
      assert (a ∈ l0) as Hin by (eauto with splinter).
      rewrite (post_pre_nincl_NoDup (l:=l0) (a:=a)) in Hsp;eauto.
      set (l1 := postfix_nincl a l0) in *.
      assert (a ∉ l1) by eapply postfix_nincl_nincl.
      induction l1;cbn in *.
      + eapply splinter_cons;eauto.
      + assert (a0 <> a /\ a ∉ l1) as [Hneq Hnin] by firstorder. clear H0.
        eapply IHl1;eauto.
        inversion Hsp;subst;eauto.
        contradiction.
    }
    eapply splinter_app;[clear Hright|clear Hleft; econstructor; eauto].
    - eapply splinter_rev in Hleft.  rewrite rev_rcons in Hleft.
      eapply splinter_rev. rewrite rev_rcons.
      erewrite postfix_nincl_rev_prefix_nincl'. eapply H0; eauto.
      eauto using NoDup_rev.
  Qed.

  Ltac anthithesis H :=
    lazymatch type of H with
    | Postfix (_ :: _) nil => exfalso; eapply postfix_nil_nil in H; congruence
    end.

  Lemma splinter_postfix (l l' l'' : list A)
        (Hpost : Postfix l l')
        (Hsp : splinter l'' l)
    : splinter l'' l'.
  Proof with (eauto with splinter).
    induction Hpost...
  Qed.

  Lemma splinter_app_drop (l l1 l2 : list A) a
        (Hsp : splinter (a :: l) (l1 ++ l2))
        (Hnin : a ∉ l1)
    : splinter (a :: l) l2.
  Proof.
    induction l1.
    - cbn in Hsp. eassumption.
    - inv Hsp.
      + cbn in Hnin. firstorder.
      + eapply IHl1;eauto.
  Qed.

End splinter.

Hint Constructors splinter : splinter.
Hint Resolve splinter_nil splinter_in splinter_incl : splinter.

Lemma splinter_strict_single (A : Type) (l : list A) (a : A)
  : splinter_strict [a] l <-> a ∈ l.
Proof.
  clear.
  split;intros.
  - dependent induction H;cbn;auto.
  - dependent induction l;cbn in *;[contradiction|].
    destruct H;[subst;econstructor;eauto with splinter|econstructor;eauto].
Qed.
Lemma splinter_neq_strict (A : Type) (l : list A) (a b : A)
      (Hsp : splinter [a;b] l)
      (Hneqq : a <> b)
  : splinter_strict [a;b] l.
Proof.
  clear - Hsp Hneqq.
  dependent induction Hsp;subst;eauto with splinter.
  - econstructor. inversion Hsp; subst;[contradiction|]. eapply splinter_in in H1.
    eapply splinter_strict_single;auto.
  - econstructor. eapply IHHsp;eauto.
Qed.

Ltac splice_splinter :=
  match goal with
  | [H : splinter ?l1 ?l,
     Q : splinter ?l2 ?l |- _ ]
    => lazymatch l2 with
      | ?a :: _
        => lazymatch l1 with
          | context C [a :: nil]
            => fold_rcons H; eapply (splinter_app_l (a:=a) (l0:=l)) in H;[|eauto|eapply Q];
              clear Q; cbn in H
          end
      end
  end.

Section succ_rt.
  Context {A : Type} `{EqDec A eq}.

  Lemma succ_rt_prefix (a b : A) l
        (Hsp : a ≻* b | l)
    : exists l', Prefix (a :: l') l /\ b ∈ (a :: l').
  Proof.
    dependent induction Hsp; do 2 exploit' IHHsp.
    - exists l'. split; [econstructor| eauto with splinter].
    - specialize (IHHsp _ _ eq_refl). destructH. eexists. split; [ econstructor|]; eauto.
  Qed.

  Lemma succ_rt_refl (a : A) l
        (Hin : a ∈ l)
    : a ≻* a | l.
  Proof.
    induction l; cbn in *;[contradiction|].
    destruct Hin. subst. econstructor. econstructor. eapply splinter_nil.
    econstructor. eauto.
  Qed.

  Hint Resolve succ_rt_refl : succ_rt.

  Lemma succ_rt_trans (a b c : A) l
        (Hnd : NoDup l)
        (Hsucc1 : b ≻* a | l)
        (Hsucc2 : c ≻* b | l)
    : c ≻* a | l.
  Proof.
    induction l; inversion Hsucc1; inversion Hsucc2; inversion Hnd; subst.
    - (* copy-copy *) eauto.
    - (* copy-skip -> contradiction *)
      exfalso. eapply H11. eapply splinter_incl;eauto.
    - (* skip-copy *)
      econstructor. eapply splinter_incl in H2.
      eapply splinter_single;eauto.
    - (* skip-skip *)
      econstructor;eauto.
  Qed.

  Lemma succ_rt_combine (a b c : A) l
        (Hnd : NoDup l)
        (Hsucc1 : b ≻* a | l)
        (Hsucc2 : c ≻* b | l)
    : c ≻* b ≻* a | l.
  Proof.
    splice_splinter;eauto.
  Qed.

  Lemma succ_NoDup_app (x y : A) (l l' : list A)
        (Hsucc : x ≻* y | l ++ l')
        (Hnd : NoDup (l ++ l'))
        (Hel : y ∈ l)
    : x ∈ l.
  Proof.
    clear - Hsucc Hnd Hel.
    revert dependent l'.
    induction l;intros;cbn in *.
    - contradiction.
    - destruct Hel.
      + inversion Hsucc;subst;[left;reflexivity|exfalso].
        eapply splinter_incl in H2. inversion Hnd;subst. apply H1. eapply H2. right;left. reflexivity.
      + inversion Hsucc;subst;[left;reflexivity|right].
        inversion Hnd;subst.
        eapply IHl;eauto.
  Qed.

  Ltac find_in_succ_rt := eapply splinter_incl; eauto; firstorder.

  Lemma postfix_succ_in (a b : A) l l'
        (Hpost : Postfix l l')
        (Hsucc : a ≻ b | l)
    : a ≻ b | l'.
  Proof.
    induction Hpost;eauto.
    eapply IHHpost in Hsucc.
    unfold succ_in in Hsucc. destructH. exists (l1 :r: a0), l2. rewrite Hsucc.
    rewrite <- cons_rcons_assoc. rewrite <-app_assoc.
    rewrite app_comm_cons. reflexivity.
  Qed.

  Lemma succ_in_cons_cons (a b : A) l
    : a ≻ b | a :: b :: l.
  Proof.
    exists l, nil. cbn. reflexivity.
  Qed.

  Lemma succ_cons (a b c : A) l
        (Hsucc : b ≻ c | l)
    : b ≻ c | a :: l.
  Proof.
    revert a;destruct l;intros a0.
    - unfold succ_in in *;cbn in *;eauto. destructH. destruct l2;cbn in *;congruence.
    - unfold succ_in in Hsucc. destructH. unfold succ_in. exists l1, (a0 :: l2).  cbn.
      rewrite Hsucc. reflexivity.
  Qed.

  Lemma in_succ_in2 (a b c : A) l
        (Hsucc : a ≻ b | c :: l)
    : b ∈ l.
  Proof.
    unfold succ_in in Hsucc. destructH.
    destruct l2;cbn in *; inversion Hsucc;subst; [|eapply in_or_app]; firstorder.
  Qed.

  Lemma in_succ_in1 (a b : A) l
        (Hsucc : a ≻ b | l)
    : a ∈ l.
  Proof.
    unfold succ_in in Hsucc. destructH.
    destruct l.
    - congruence'.
    - symmetry in Hsucc. eapply eq_incl in Hsucc. eapply Hsucc.
      clear Hsucc. induction l2;cbn;firstorder.
  Qed.

  Lemma succ_in_succ_rt (x y : A) l
        (Hsucc : x ≻ y | l)
    : x ≻* y | l.
  Proof.
    destruct Hsucc as [l1 [l2 Hsucc]]. subst l.
    induction l2;cbn.
    - eapply splinter_lr. econstructor. eapply splinter_nil.
    - econstructor. eapply IHl2.
  Qed.

  Lemma prefix_succ_in (a b : A) l l'
        (Hpre : Prefix l l')
        (Hsucc : a ≻ b | l)
    : a ≻ b | l'.
  Proof.
    induction Hpre;eauto.
    eapply IHHpre in Hsucc.
    unfold succ_in in Hsucc. destructH. exists l1, (a0 :: l2). rewrite Hsucc. cbn; reflexivity.
  Qed.

End succ_rt.


(* This file contains some lemmas on boolean expressions, which are exported as global reslove hints, and the proof irrelenvance theorem for booleans *)

Require Import ZArith Arith Bool Lia.

Lemma ltb_correct (a b:nat) : a < b -> a <? b = true.
  apply Nat.ltb_lt; assumption.
Qed.

Lemma ltb_complete (a b:nat) : a <? b = true -> a < b.
  apply Nat.ltb_lt; assumption.
Qed.

Lemma ltb_imp_leb (i j :nat) : (i <? j) = true -> (i <=? j) = true.
Proof.
  intro.
  rewrite Nat.leb_le.
  rewrite Nat.ltb_lt in H.
  apply Nat.lt_le_incl.
  assumption.
Qed.

Lemma ltb_trans (i j n :nat) : (i <? j) = true /\ (j <? n) = true -> (i <? n) = true.
Proof.
  intros.
  destruct H.
  rewrite Nat.ltb_lt in H.
  rewrite Nat.ltb_lt in H0.
  rewrite Nat.ltb_lt.
  eapply Nat.lt_trans with (m:= j); assumption.
Qed.

Lemma leb_trans (i j n :nat) : (i <=? j) = true /\ (j <=? n) = true -> (i <=? n) = true.
Proof.
  intros.
  destruct H.
  rewrite Nat.leb_le in H.
  rewrite Nat.leb_le in H0.
  rewrite Nat.leb_le.
  eapply Nat.le_trans with (m:= j); assumption.
Qed.

Lemma ltb_leb_trans (i j n :nat) : (i <? j) = true /\ (j <=? n) = true -> (i <? n) = true.
Proof.
  intros.
  destruct H.
  rewrite Nat.ltb_lt in H.
  rewrite Nat.leb_le in H0.
  rewrite Nat.ltb_lt.
  apply Nat.lt_le_trans with (m:= j); assumption.
Qed.

Lemma ltb_leb_incl (i j :nat) : (i <? j) = true -> (i <=? j) = true.
Proof.
  rewrite Nat.ltb_lt.
  rewrite Nat.leb_le.
  apply Nat.lt_le_incl.
Qed.

#[export] Hint Resolve leb_complete : core.
#[export] Hint Resolve leb_correct : core.
#[export] Hint Resolve ltb_correct : core.
#[export] Hint Resolve ltb_complete : core.
#[export] Hint Resolve Nat.ltb_lt : core.
#[export] Hint Resolve Nat.sub_0_r Nat.lt_le_incl ltb_imp_leb ltb_trans leb_trans ltb_leb_trans: core.

Ltac andb_destr H :=
  repeat (let H' := fresh H in apply andb_true_iff in H as [H H']; try andb_destr H').

Ltac andb_split :=
  repeat (apply andb_true_iff; split).

  (* Proof irrelevance on booleans *)

Lemma b_dec : forall (b1 b2 : bool), b1 = b2 \/ b1 <> b2.
Proof.
  intros.
  destruct b1,b2; intuition.
Qed.

Local Definition comp [A] [x y y':A] (eq1:x = y) (eq2:x = y') : y = y' :=
eq_ind _ (fun a => a = y') eq2 _ eq1.

Local Definition trans_sym_eq [A] (x y:A) (u:x = y) : comp u u = eq_refl y.
Proof.
case u; trivial.
Qed.

Local Definition nu [x y:bool] (u:x = y) : x = y :=
match b_dec x y with
| or_introl eqxy => eqxy
| or_intror neqxy => False_ind _ (neqxy u)
end.

Local Definition nu_constant [x y:bool] (u v:x = y) : nu u = nu v.
unfold nu.
destruct (b_dec x y) as [Heq|Hneq].
- reflexivity.
- case Hneq; trivial.
Qed.

Local Definition nu_inv [x y:bool] (v:x = y) : x = y := comp (nu (eq_refl x)) v.

Local Definition nu_left_inv [x y:bool] (u:x = y) : nu_inv (nu u) = u.
Proof.
case u; unfold nu_inv.
case eq_refl.
apply trans_sym_eq.
Qed.

Lemma bool_irrel (x y:bool) (p1 p2:x = y) : p1 = p2.
Proof.
elim (nu_left_inv p1).
elim (nu_left_inv p2).
elim nu_constant with x y p1 p2.
reflexivity.
Qed.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require Export pythagoras_difference_lemmas.

Definition a_ratio A O U V ro ru rv :=
 ~ Col O U V /\
 S A U V / S O U V = ro /\
 S O A V / S O U V = ru /\
 S O U A / S O U V = rv.

Definition is_centroid G A B C :=  a_ratio G A B C (1/(2+1)) (1/(2+1)) (1/(2+1)).

Definition is_orthocenter' H A B C :=
  a_ratio H A B C (Py A B C * Py A C B / ((2*2*2*2) * (S A B C * S A B C)))
                            (Py B A C * Py B C A / ((2*2*2*2) * (S A B C * S A B C)))
                            (Py C A B * Py C B A / ((2*2*2*2) * (S A B C * S A B C))).

Definition is_orthocenter H A B C :=
 a_ratio H A B C
        (Py A B C * Py A C B / (Py A B A * Py A C A - Py B A C * Py B A C))
        (Py B A C * Py B C A / (Py A B A * Py A C A - Py B A C * Py B A C))
        (Py C A B * Py C B A / (Py A B A * Py A C A - Py B A C * Py B A C)).

Lemma is_orthocenter_non_zero' : forall H A B C,
 is_orthocenter H A B C ->
 (2*2*2*2) * (S A B C * S A B C) <> 0.
Proof.
intros.
unfold is_orthocenter in H0.
unfold a_ratio in H0.
use H0.
repeat (apply nonzeromult);auto with Geom.
Qed.

Lemma is_orthocenter_non_zero : forall H A B C,
 is_orthocenter H A B C ->
 (Py A B A * Py A C A - Py B A C * Py B A C) <> 0.
Proof.
intros.
apply is_orthocenter_non_zero' in H0.
rewrite (herron_qin A B C) in *.
replace (2 * 2 * 2 * 2 *
     (1 / (2 * 2 * 2 * 2) * (Py A B A * Py A C A - Py B A C * Py B A C)))
with ((Py A B A * Py A C A - Py B A C * Py B A C)) in *
  by (field;solve_conds).
auto.
Qed.

Lemma is_orthocenter_equiv : forall H A B C,
 is_orthocenter' H A B C <-> is_orthocenter H A B C.
Proof.
intros.
unfold is_orthocenter in *.
unfold is_orthocenter' in *.
rewrite (herron_qin A B C).
replace (2 * 2 * 2 * 2 *
    (1 / (2 * 2 * 2 * 2) * (Py A B A * Py A C A - Py B A C * Py B A C)))
with
 (Py A B A * Py A C A - Py B A C * Py B A C)
 by (field;solve_conds).
tauto.
Qed.

Definition is_circumcenter' O A B C :=
  a_ratio O A B C (Py B C B * Py B A C / ((2*2*2*2*2) * (S A B C * S A B C)))
                            (Py A C A * Py A B C / ((2*2*2*2*2) * (S A B C * S A B C)))
                           (Py A B A * Py A C B / ((2*2*2*2*2) * (S A B C * S A B C))).

Definition is_circumcenter O A B C :=
  a_ratio O A B C (Py B C B * Py B A C / (2*(Py A B A * Py A C A - Py B A C * Py B A C)))
                            (Py A C A * Py A B C /(2*(Py A B A * Py A C A - Py B A C * Py B A C)))
                           (Py A B A * Py A C B / (2*(Py A B A * Py A C A - Py B A C * Py B A C))).

Lemma is_circumcenter_non_zero' : forall H A B C,
 is_circumcenter H A B C ->
 (2*2*2*2*2) * (S A B C * S A B C) <> 0.
Proof.
intros.
unfold is_circumcenter in H0.
unfold a_ratio in H0.
use H0.
repeat (apply nonzeromult);auto with Geom.
Qed.

Lemma is_circumcenter_non_zero : forall H A B C,
 is_circumcenter H A B C ->
 2*(Py A B A * Py A C A - Py B A C * Py B A C) <> 0.
Proof.
intros.
apply is_circumcenter_non_zero' in H0.
rewrite (herron_qin A B C) in *.
replace (2 * 2 * 2 * 2 * 2 *
     (1 / (2 * 2 * 2 * 2) * (Py A B A * Py A C A - Py B A C * Py B A C)))
with (2 * (Py A B A * Py A C A - Py B A C * Py B A C)) in *
  by (field;solve_conds).
auto.
Qed.

Lemma is_circumcenter_equiv : forall H A B C,
 is_circumcenter' H A B C <-> is_circumcenter H A B C.
Proof.
intros.
unfold is_circumcenter in *.
unfold is_circumcenter' in *.
rewrite (herron_qin A B C).
replace (2 * 2 * 2 * 2 * 2 *
    (1 / (2 * 2 * 2 * 2) * (Py A B A * Py A C A - Py B A C * Py B A C)))
with
 (2*(Py A B A * Py A C A - Py B A C * Py B A C))
 by (field;solve_conds).
tauto.
Qed.

Definition is_Lemoine L A B C :=
 a_ratio L A B C (Py B C B / (Py A B A + Py B C B + Py A C A))
                 (Py A C A / (Py A B A + Py B C B + Py A C A))
                 (Py A B A / (Py A B A + Py B C B + Py A C A)).


Require Import Arith.
Require Import Omega.
Require Import List.
Require Import String.
Import ListNotations.

Require Import Oeuf.

(* Our core coq function *)
Fixpoint double_nat (x : nat) :=
    match x with
    | 0 => 0
    | S n => S (S (double_nat n))
    end.

(* Proof of correctness of our function *)
Theorem double_nat_plus :
  forall x,
    double_nat x = x + x.
Proof.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. omega.
Qed.

(* Core function in terms of eliminators *)
Definition double_nat_elim (x : nat) :=
  nat_rect
    O
    (fun n' rec_res => S (S rec_res))
    x.

(* Proof that elim version is same as original *)
Theorem double_nat_elim_double_nat :
  double_nat_elim = double_nat.
Proof.
  reflexivity.
Qed.

(* Reflect double_nat_elim *)
(* Call this step "Mirror" *)
Oeuf Reflect double_nat_elim As double_nat_cu.

(* Look at what's reflected *)
Check double_nat_cu : compilation_unit.

Print double_nat_cu.

Eval cbv in (types double_nat_cu).
Eval cbv in (exprs double_nat_cu).

(* Prove that denotation of reflection is same as original *)
(* This is where we use the computational denotation to prove that we
have the correct AST *)
Lemma double_nat_cu_validate :
  cu_denote (exprs double_nat_cu) = double_nat_elim.
Proof.
  reflexivity.
Qed.

(* Serialize the Coq AST to a file *)
Oeuf Eval lazy Then Write To File "double_nat.oeuf"
     (Pretty.compilation_unit.print double_nat_cu).

(* Compilation will continue from here in the Oeuf standalone tool *)

(* The next step is linking in the Shim code *)