Require Import OrderedType FMapAVL.
Require Import List.
Require Import Setoid RelationClasses.
Require Import Reflection.
Require Import NPeano.

Set Implict Arguments.
Set Strict Implicit.

Module Ordered_nat <: OrderedType with Definition t := nat.
  Definition t := nat.
  Definition eq := @eq nat.
  Definition lt := @lt.

  Theorem eq_refl : forall x, eq x x.
    reflexivity.
  Qed.

  Theorem eq_sym : forall a b, eq a b -> eq b a.
    intros; symmetry; auto.
  Qed.

  Theorem eq_trans : forall a b c, eq a b -> eq b c -> eq a c.
    intros; etransitivity; eauto.
  Qed.

  Require Import Omega.
  Theorem lt_trans : forall a b c, lt a b -> lt b c -> lt a c.
    intros. unfold lt in *. omega.
  Qed.

  Theorem lt_not_eq : forall a b, lt a b -> ~(eq a b).
    unfold eq, lt. intros; omega.
  Qed.

  Definition compare (x y : t) : OrderedType.Compare lt eq x y :=
    match Compare_dec.nat_compare x y as r return
      Compare_dec.nat_compare x y = r -> OrderedType.Compare lt eq x y
      with
      | Lt => fun pf => OrderedType.LT (lt:=lt) (nat_compare_Lt_lt _ _ pf)
      | Eq => fun pf => OrderedType.EQ (lt:=lt) (Compare_dec.nat_compare_eq _ _ pf)
      | Gt => fun pf => OrderedType.GT (lt:=lt) (nat_compare_Gt_gt _ _ pf)
    end (refl_equal _).

  Definition eq_dec (x y : nat) : {x = y} + {x <> y} :=
    match beq_nat x y as r return
      beq_nat x y = r -> {x = y} + {x <> y} with
      | true => fun pf => left (beq_nat_true _ _ pf)
      | false => fun pf => right (beq_nat_false _ _ pf)
    end (refl_equal _).

End Ordered_nat.

Module IntMap := FMapAVL.Make Ordered_nat.

Remove Hints IntMap.E.eq_sym IntMap.E.eq_refl IntMap.E.eq_trans IntMap.E.lt_not_eq IntMap.E.lt_trans
  IntMap.Raw.Proofs.L.PX.eqk_refl IntMap.Raw.Proofs.L.PX.eqk_sym
  IntMap.Raw.Proofs.L.PX.eqk_trans
  IntMap.Raw.Proofs.PX.eqk_refl IntMap.Raw.Proofs.PX.eqk_sym IntMap.Raw.Proofs.PX.eqk_trans
  IntMap.Raw.Proofs.L.PX.eqke_refl IntMap.Raw.Proofs.L.PX.eqke_sym IntMap.Raw.Proofs.L.PX.eqke_trans
  IntMap.Raw.Proofs.PX.eqke_refl IntMap.Raw.Proofs.PX.eqke_sym IntMap.Raw.Proofs.PX.eqke_trans
  IntMap.Raw.Proofs.L.PX.MO.lt_eq IntMap.Raw.Proofs.L.PX.MO.eq_lt IntMap.Raw.Proofs.L.MX.lt_eq
  IntMap.Raw.Proofs.L.MX.eq_lt IntMap.Raw.Proofs.PX.MO.lt_eq IntMap.Raw.Proofs.PX.MO.eq_lt
  IntMap.Raw.Proofs.MX.lt_eq IntMap.Raw.Proofs.MX.eq_lt
  IntMap.Raw.Proofs.L.PX.eqk_ltk IntMap.Raw.Proofs.L.PX.ltk_eqk IntMap.Raw.Proofs.L.PX.ltk_trans
  IntMap.Raw.Proofs.PX.eqk_ltk IntMap.Raw.Proofs.PX.ltk_eqk IntMap.Raw.Proofs.PX.ltk_trans
  IntMap.Raw.Proofs.L.PX.MO.lt_antirefl
  IntMap.Raw.Proofs.L.MX.lt_antirefl IntMap.Raw.Proofs.PX.MO.lt_antirefl IntMap.Raw.Proofs.MX.lt_antirefl
  IntMap.Raw.Proofs.L.PX.eqk_not_ltk IntMap.Raw.Proofs.L.PX.ltk_not_eqke
  IntMap.Raw.Proofs.L.PX.ltk_not_eqk IntMap.Raw.Proofs.L.PX.MO.lt_not_gt
  IntMap.Raw.Proofs.L.PX.MO.eq_not_gt IntMap.Raw.Proofs.L.PX.MO.eq_neq
  IntMap.Raw.Proofs.L.PX.MO.neq_eq IntMap.Raw.Proofs.L.PX.MO.eq_le
  IntMap.Raw.Proofs.L.PX.MO.le_eq IntMap.Raw.Proofs.L.PX.MO.eq_not_lt
  IntMap.Raw.Proofs.L.PX.MO.gt_not_eq IntMap.Raw.Proofs.L.MX.lt_not_gt
  IntMap.Raw.Proofs.L.MX.eq_not_gt IntMap.Raw.Proofs.L.MX.eq_neq
  IntMap.Raw.Proofs.L.MX.neq_eq IntMap.Raw.Proofs.L.MX.eq_le
  IntMap.Raw.Proofs.L.MX.le_eq IntMap.Raw.Proofs.L.MX.eq_not_lt
  IntMap.Raw.Proofs.L.MX.gt_not_eq IntMap.Raw.Proofs.PX.eqk_not_ltk
  IntMap.Raw.Proofs.PX.ltk_not_eqke IntMap.Raw.Proofs.PX.ltk_not_eqk
  IntMap.Raw.Proofs.PX.MO.lt_not_gt IntMap.Raw.Proofs.PX.MO.eq_not_gt
  IntMap.Raw.Proofs.PX.MO.eq_neq IntMap.Raw.Proofs.PX.MO.neq_eq
  IntMap.Raw.Proofs.PX.MO.eq_le IntMap.Raw.Proofs.PX.MO.le_eq
  IntMap.Raw.Proofs.PX.MO.eq_not_lt IntMap.Raw.Proofs.PX.MO.gt_not_eq
  IntMap.Raw.Proofs.MX.lt_not_gt IntMap.Raw.Proofs.MX.eq_not_gt
  IntMap.Raw.Proofs.MX.eq_neq IntMap.Raw.Proofs.MX.neq_eq
  IntMap.Raw.Proofs.MX.eq_le IntMap.Raw.Proofs.MX.le_eq
  IntMap.Raw.Proofs.MX.eq_not_lt IntMap.Raw.Proofs.MX.gt_not_eq
  IntMap.Raw.Proofs.L.PX.Sort_Inf_NotIn IntMap.Raw.Proofs.PX.Sort_Inf_NotIn
  IntMap.Raw.Proofs.L.PX.Inf_eq IntMap.Raw.Proofs.L.PX.MO.Inf_lt
  IntMap.Raw.Proofs.L.MX.Inf_lt IntMap.Raw.Proofs.PX.Inf_eq
  IntMap.Raw.Proofs.PX.MO.Inf_lt IntMap.Raw.Proofs.MX.Inf_lt
  IntMap.Raw.Proofs.L.PX.Inf_lt IntMap.Raw.Proofs.L.PX.MO.Inf_lt
  IntMap.Raw.Proofs.L.MX.Inf_lt IntMap.Raw.Proofs.PX.Inf_lt
  IntMap.Raw.Proofs.PX.MO.Inf_lt IntMap.Raw.Proofs.MX.Inf_lt
  IntMap.Raw.InRight IntMap.Raw.InLeft IntMap.Raw.InRoot
  IntMap.Raw.Proofs.L.PX.InA_eqke_eqk IntMap.Raw.Proofs.L.PX.MO.In_eq
  IntMap.Raw.Proofs.L.PX.MO.ListIn_In IntMap.Raw.Proofs.L.MX.In_eq
  IntMap.Raw.Proofs.L.MX.ListIn_In IntMap.Raw.Proofs.PX.InA_eqke_eqk
  IntMap.Raw.Proofs.PX.MO.In_eq IntMap.Raw.Proofs.PX.MO.ListIn_In
  IntMap.Raw.Proofs.MX.In_eq IntMap.Raw.Proofs.MX.ListIn_In
  IntMap.Raw.Proofs.L.PX.In_inv_3 IntMap.Raw.Proofs.PX.In_inv_3
  IntMap.Raw.Proofs.L.PX.In_inv_2 IntMap.Raw.Proofs.PX.In_inv_2
  IntMap.Raw.MapsRight IntMap.Raw.MapsLeft
  IntMap.Raw.MapsRoot IntMap.Raw.Proofs.L.PX.MO.Sort_NoDup
  IntMap.Raw.Proofs.L.MX.Sort_NoDup IntMap.Raw.Proofs.PX.MO.Sort_NoDup
  IntMap.Raw.Proofs.MX.Sort_NoDup
  IntMap.Raw.BSLeaf IntMap.Raw.BSNode IntMap.Raw.Leaf IntMap.Raw.Node.

Require FMapFacts.
Module IntMapFacts := FMapFacts.WFacts_fun(Ordered_nat)(IntMap).

Module IntMapProperties := FMapFacts.WProperties_fun(Ordered_nat)(IntMap).

Definition singleton {T} (k : nat) (v : T) : IntMap.t T :=
  IntMap.add k v (IntMap.empty _).

(** Neither Properties nor Facts contains anything useful about 'map' **)
Module MoreFMapFacts (FM : FMapInterface.WS)
.
  Module PROPS := FMapFacts.WProperties_fun(FM.E) FM.
  Module FACTS := FMapFacts.WFacts_fun FM.E FM.

  Definition union T :=
    FM.fold (fun k (v : T) a => FM.add k v a).

  Lemma add_remove_Equal : forall (elt : Type) k (v : elt) m,
    FM.Equal (FM.add k v m) (FM.add k v (FM.remove k m)).
  Proof.
    clear. unfold FM.Equal. intros.
    repeat (rewrite FACTS.add_o || rewrite FACTS.remove_o).
    destruct (FM.E.eq_dec k y); auto.
  Qed.

  Lemma MapsTo_add_remove_Equal : forall (elt : Type) k (v : elt) m,
    FM.MapsTo k v m ->
    FM.Equal m (FM.add k v (FM.remove k m)).
  Proof.
    clear. unfold FM.Equal. intros.
    repeat (rewrite FACTS.add_o || rewrite FACTS.remove_o).
    destruct (FM.E.eq_dec k y); auto.
    rewrite <- e. apply FACTS.find_mapsto_iff; auto.
  Qed.

  Lemma map_Empty : forall T U (F : T -> U) m,
    FM.Empty m ->
    FM.Empty (FM.map F m).
  Proof.
    intros.
    unfold FM.Empty in *.
    intros. intro.
    eapply FACTS.map_mapsto_iff in H0. destruct H0; intuition. eauto.
  Qed.

  Lemma map_Add : forall T U (F : T -> U) x e m m',
    PROPS.Add x e m m' ->
    PROPS.Add x (F e) (FM.map F m) (FM.map F m').
  Proof.
    unfold PROPS.Add; intros.
    specialize (H y).
    repeat (rewrite FACTS.add_o in * || rewrite FACTS.map_o in *).
    rewrite H. destruct (FM.E.eq_dec x y); reflexivity.
  Qed.

  Lemma map_not_In : forall T U (F : T -> U) x m,
    ~ FM.In x m ->
    ~ FM.In x (FM.map F m).
  Proof.
    intros. intro. apply H; clear H. destruct H0.
    apply FACTS.map_mapsto_iff in H. destruct H.
    exists x1. intuition.
  Qed.

  Lemma union_empty : forall T m,
    FM.Equal (union T m (FM.empty _)) m.
  Proof.
    intros. unfold union.
    remember (FM.empty T).
    apply PROPS.map_induction with (m := m); intros.
      rewrite PROPS.fold_Empty; eauto with typeclass_instances. subst; auto.
      unfold FM.Equal, FM.Empty in *. intros.
      rewrite FACTS.empty_o. case_eq (FM.find y m0); intros; auto.
      exfalso. eapply H. eapply FM.find_2; eauto.

    erewrite PROPS.fold_Add; eauto with typeclass_instances.
    rewrite H. unfold PROPS.Add, FM.Equal in *. eauto.

    repeat (red; intros; subst).
    repeat (rewrite FACTS.add_o).
      destruct (FM.E.eq_dec k y); auto.
      destruct (FM.E.eq_dec k' y); auto. rewrite <- e1 in e2. exfalso; auto.
  Qed.

  Lemma map_fold' : forall T U (F : T -> U) (m : FM.t T) (m' : FM.t U),
    FM.Equal (union _ (FM.map F m) m')
             (FM.fold (fun k v a => FM.add k (F v) a) m m').
  Proof.
    do 4 intro. unfold union.
    eapply PROPS.map_induction with (m := m); intros.
    symmetry.
    rewrite PROPS.fold_Empty; eauto with typeclass_instances.
    rewrite PROPS.fold_Empty; eauto with typeclass_instances. reflexivity.
    eapply map_Empty; auto.

    symmetry; rewrite PROPS.fold_Add; eauto with typeclass_instances.
      specialize (H m'0).
      cut (PROPS.Add x (F e) (FM.map F m0) (FM.map F m')); intros.
      symmetry. rewrite PROPS.fold_Add. 6: eapply H2. 2: eauto with typeclass_instances.
      rewrite H. reflexivity.

      repeat (red; intros; subst). rewrite H3. rewrite H4. reflexivity.
      repeat (red; intros; subst). repeat rewrite FACTS.add_o.
      destruct (FM.E.eq_dec k y); destruct (FM.E.eq_dec k' y); eauto.
      rewrite <- e1 in e2; exfalso; auto.
      intro. apply FACTS.map_in_iff in H3. auto.

      unfold PROPS.Add in *; intros.
      specialize (H1 y). repeat (rewrite FACTS.add_o || rewrite FACTS.map_o || rewrite H1).
      unfold FACTS.option_map.
      destruct (FM.E.eq_dec x y); auto.

      repeat (red; intros; subst). rewrite H3. rewrite H2. reflexivity.
      repeat (red; intros; subst). repeat rewrite FACTS.add_o.
      repeat match goal with
               | [ |- context [ FM.E.eq_dec ?X ?Y ] ] => destruct (FM.E.eq_dec X Y); auto
             end.
      rewrite <- e1 in e2; exfalso; auto.
  Qed.

  Lemma map_fold : forall T U (F : T -> U) m,
    FM.Equal (FM.map F m)
             (FM.fold (fun k v a => FM.add k (F v) a) m (FM.empty _)).
  Proof.
    intros. etransitivity. symmetry; apply union_empty. apply map_fold'.
  Qed.

  Lemma find_empty_iff : forall T (m : FM.t T),
    FM.Empty m <-> forall k, FM.find k m = None.
  Proof.
    unfold FM.Empty. intros. split.
    { intros; case_eq (FM.find k m); auto; intros.
      exfalso. eapply FACTS.find_mapsto_iff in H0. eapply H; eauto. }
    { intros. intro. apply FACTS.find_mapsto_iff in H0.
      specialize (H a). congruence. }
  Qed.

  Lemma find_Empty : forall T k (m : FM.t T),
    FM.Empty m -> FM.find k m = None.
  Proof.
    intros. apply find_empty_iff; auto.
  Qed.

  Section fusion.
    Variable T U V : Type.
    Variable F : T -> U.
    Variable G : FM.key -> U -> V -> V.
    Hypothesis equ : V -> V -> Prop.
    Hypothesis equ_Equiv : RelationClasses.Equivalence equ.
    Hypothesis G_trans: PROPS.transpose_neqkey equ G.
    Hypothesis G_respect: Morphisms.Proper
      (Morphisms.respectful FM.E.eq
        (Morphisms.respectful eq (Morphisms.respectful equ equ))) G.

    Local Hint Resolve G_trans G_respect equ_Equiv.
    Local Hint Extern 1 (Morphisms.Proper _ _) =>
      clear; repeat (red; intros; subst); repeat rewrite FACTS.add_o;
        repeat match goal with
                 | [ |- context [ FM.E.eq_dec ?X ?Y ] ] =>
                   destruct (FM.E.eq_dec X Y)
                 | [ H : FM.E.eq ?X ?Y |- _ ] => rewrite H in *
               end; auto; exfalso; auto.
    Local Hint Extern 1 (PROPS.transpose_neqkey _ _) =>
      clear; repeat (red; intros; subst); repeat rewrite FACTS.add_o;
        repeat match goal with
                 | [ |- context [ FM.E.eq_dec ?X ?Y ] ] =>
                   destruct (FM.E.eq_dec X Y)
                 | [ H : FM.E.eq ?X ?Y |- _ ] => rewrite H in *
               end; auto; exfalso; auto.
    Local Hint Resolve FACTS.EqualSetoid.

    Lemma fold_map_fusion : forall m a,
      equ (FM.fold G (FM.map F m) a)
      (FM.fold (fun k x acc => G k (F x) acc) m a).
    Proof.
      intro. eapply PROPS.map_induction with (m := m); intros.
        rewrite PROPS.fold_Empty; eauto with typeclass_instances.
        rewrite PROPS.fold_Empty; eauto with typeclass_instances. eapply equ_Equiv.
        apply map_Empty. auto.

        symmetry. rewrite PROPS.fold_Add; eauto with typeclass_instances.
        2: repeat (red; intros; subst); eapply G_respect; auto.
        2: repeat (red; intros; subst); eapply G_trans; auto.

        symmetry. rewrite PROPS.fold_Equal. 5: eapply map_fold. 2: eapply equ_Equiv. 3: eapply G_trans.
        2: eapply G_respect.
        rewrite PROPS.fold_Equal. 5: rewrite PROPS.fold_Add; eauto.
        5: reflexivity. rewrite PROPS.fold_add; eauto.
        eapply G_respect; eauto. erewrite <- H.
        symmetry. rewrite PROPS.fold_Equal. 5: apply map_fold. reflexivity. eauto. eauto. eauto.

        { revert H0. clear. revert x. eapply PROPS.map_induction with (m := m0); intros.
          rewrite PROPS.fold_Empty; eauto. intro. eapply FACTS.empty_in_iff; eauto with typeclass_instances.

          rewrite PROPS.fold_Add. 6: eauto. 5: eauto. 2: eauto. 2: eauto. 2: eauto.
          intro. apply FACTS.add_in_iff in H3. destruct H3.
            rewrite <- H3 in *. apply H2. specialize (H1 x). rewrite FACTS.add_o in *.
            destruct (FM.E.eq_dec x x); try solve [ exfalso; auto ]. apply FACTS.in_find_iff. congruence.

            eapply H. 2: eauto. intro. clear H3. specialize (H1 x0).
            rewrite FACTS.add_o in H1.
            repeat match goal with
                     | [ H : ~ FM.In _ _ |- _ ] => apply FACTS.not_find_in_iff in H
                     | [ H : FM.In _ _ |- _ ] => apply FACTS.in_find_iff in H
                   end.
            destruct (FM.E.eq_dec x x0); congruence.
        }

        eauto.
        eauto.
        eauto.
    Qed.

    Lemma remove_empty : forall T k,
      FM.Equal (FM.remove k (FM.empty T)) (FM.empty _).
    Proof.
      clear. unfold FM.Equal; intros.
      rewrite FACTS.remove_o. rewrite FACTS.empty_o. destruct (FM.E.eq_dec k y); auto.
    Qed.

    Lemma remove_Empty : forall T k (m : FM.t T),
      FM.Empty m ->
      FM.Equal (FM.remove k m) m.
    Proof.
      clear. unfold FM.Equal; intros.
      rewrite FACTS.remove_o. consider (FM.E.eq_dec k y); auto.
      eapply find_empty_iff in H; eauto.
    Qed.

    Lemma map_remove : forall k m,
      FM.Equal (FM.map F (FM.remove k m))
               (FM.remove k (FM.map F m)).
    Proof.
      clear; unfold FM.Equal; intros.
      repeat (rewrite FACTS.map_o || rewrite FACTS.remove_o).
      destruct (FM.E.eq_dec k y); reflexivity.
    Qed.

    Lemma map_add : forall k v m,
      FM.Equal (FM.map F (FM.add k v m))
               (FM.add k (F v) (FM.map F m)).
    Proof.
      clear; unfold FM.Equal; intros.
      repeat (rewrite FACTS.map_o || rewrite FACTS.add_o).
      destruct (FM.E.eq_dec k y); reflexivity.
    Qed.

  End fusion.

  Lemma MapsTo_def : forall T k m,
    FM.In k m <-> exists (v : T), FM.MapsTo k v m.
  Proof.
    unfold FM.In; split; auto.
  Qed.

  Global Add Parametric Morphism (elt : Type) F : (@FM.Equiv elt F) with
    signature (FM.Equal ==> FM.Equal ==> iff)
    as equiv_eq_mor.
  Proof.
    intros. unfold FM.Equiv. split; intros.
      intuition; rewrite <- H in *; rewrite <- H0 in *; firstorder.
      intuition; rewrite H in *; rewrite H0 in *; firstorder.
  Qed.

  Section Equiv.
    Variable T : Type.
    Variable R : T -> T -> Prop.
    Hypothesis refl : Reflexive R.

    Global Instance Refl_Equiv : Reflexive (FM.Equiv R).
    Proof.
      revert refl; clear.
      red. unfold FM.Equiv. firstorder.
      apply FACTS.find_mapsto_iff in H.
      apply FACTS.find_mapsto_iff in H0.
      rewrite H in H0. inversion H0; apply refl.
    Qed.

    Lemma Equiv_Add : forall k v m m' n',
      FM.Equiv R m' n' ->
      ~FM.In k m ->
      PROPS.Add k v m m' ->
      exists n v',
        PROPS.Add k v' n n' /\
        ~FM.In k n /\
        FM.Equiv R m n /\
        R v v'.
    Proof.
      intros. unfold PROPS.Add in *.
      destruct H. generalize (H1 k). intros.
      rewrite FACTS.add_o in *. destruct (FM.E.eq_dec k k); try solve [ exfalso; auto ].
      case_eq (FM.find k n'); intros. exists (FM.remove k n'). exists t.
      { intuition.
        rewrite FACTS.add_o. rewrite FACTS.remove_o. destruct (FM.E.eq_dec k y); auto.
        rewrite <- e0; eauto.

        destruct H5. apply FACTS.find_mapsto_iff in H5. rewrite FACTS.remove_o in H5.
        destruct (FM.E.eq_dec k k); congruence.

        split. intros. destruct (FM.E.eq_dec k k0); try rewrite <- e0 in *.
        split; intro; try solve [ exfalso ; auto ]. destruct H5. apply FACTS.find_mapsto_iff in H5.
        rewrite FACTS.remove_o in H5; destruct (FM.E.eq_dec k k); congruence.
        split; intro. apply FACTS.remove_in_iff; split; auto.

        { eapply H. destruct H5. apply FACTS.find_mapsto_iff in H5. exists x. apply FACTS.find_mapsto_iff.
          rewrite H1. rewrite FACTS.add_o. destruct (FM.E.eq_dec k k0); try congruence. }
        { apply FACTS.remove_in_iff in H5. intuition. apply H in H7.
          destruct H7. apply FACTS.find_mapsto_iff in H5. exists x. apply FACTS.find_mapsto_iff.
          rewrite H1 in H5. rewrite FACTS.add_o in H5. destruct (FM.E.eq_dec k k0); try congruence. }
        { intros. apply FACTS.remove_mapsto_iff in H6. intuition.
          specialize (H1 k0). rewrite FACTS.add_o in *.
          destruct (FM.E.eq_dec k k0). congruence.
          apply FACTS.find_mapsto_iff in H5. rewrite <- H1 in *. apply FACTS.find_mapsto_iff in H5.
          eapply H2; eauto. }

        { eapply H2; eapply FACTS.find_mapsto_iff; eauto. } }
      { exfalso. apply FACTS.not_find_in_iff in H4. apply H4. apply H. apply FACTS.find_mapsto_iff in H3; eexists; eauto. }
    Qed.

    Hypothesis sym : Symmetric R.
    Global Instance Sym_Equiv : Symmetric (FM.Equiv R).
    Proof.
      clear refl. red. unfold FM.Equiv. intros.
      intuition; eauto; firstorder.
    Qed.

    Hypothesis trans : Transitive R.
    Global Instance Trans_Equiv : Transitive (FM.Equiv R).
    Proof.
      clear refl sym. red. unfold FM.Equiv. intros.
      intuition.
      eapply H. eapply H1. auto.
      eapply H1; eapply H; auto.
      cut (FM.In k y); intros.
      destruct H5. etransitivity. eapply H2; eauto. eapply H3; eauto.
      eapply H1. eexists; eauto.
    Qed.

  End Equiv.
End MoreFMapFacts.


Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Compare_dec.
Import List.ListNotations.

Require Import Leapfrog.P4automaton.
Require Import Leapfrog.FinType.
Require Import Leapfrog.ConfRel.
Require Import Leapfrog.Relations.
Require Leapfrog.Bisimulations.Semantic.
Module BS := Leapfrog.Bisimulations.Semantic.

Section SemanticCoinductive.
  Variable (a: p4automaton).
  Notation conf := (configuration a).
  CoInductive bisimilar : rel conf :=
  | Bisimilar:
      forall q1 q2,
        (accepting q1 <-> accepting q2) ->
        (forall b, bisimilar (step q1 b) (step q2 b)) ->
        bisimilar q1 q2
  .

  Lemma bisimilar_coalg_implies_sem_bisim:
    forall q1 q2,
      bisimilar q1 q2 ->
      BS.bisimilar q1 q2.
  Proof.
    intros.
    exists bisimilar.
    split.
    - unfold BS.bisimulation.
      intros.
      inversion H0; firstorder.
    - tauto.
  Qed.

  Lemma sem_bisim_implies_bisimilar_coalg:
    forall q1 q2,
      BS.bisimilar q1 q2 ->
      bisimilar q1 q2.
  Proof.
    cofix C.
    intros.
    constructor.
    - unfold BS.bisimilar, BS.bisimulation in *.
      firstorder.
    - intros.
      eapply C.
      unfold BS.bisimilar, BS.bisimulation in *.
      firstorder.
  Qed.

End SemanticCoinductive.


(** Injection from ordinals (less than epsilon0) in CNF into hydras.

 Pierre Castéran, LaBRI and Univ. Bordeaux

We define a function [iota : T1 -> Hydra] such that if [alpha < beta], then there exists a battle from [iota beta] to [iota alpha].

Note that [iota] is not a bijection, but is sufficient for proving
impossibility lemmas or minoration of battle lengths (see Hydra_Theorems).
*)

From Coq Require Import Relation_Operators.

From hydras Require Import Hydra_Lemmas Epsilon0 Canon Paths  .
Import Hydra_Definitions.

(** Let us transform any ordinal term into an hydra *)

(* begin snippet iotaDef *)

Fixpoint iota (a : T1) : Hydra :=
  match a with
  | zero => head
  | cons c n b => node (hcons_mult (iota c) (S n) (iotas b))
  end
with iotas (a : T1) :  Hydrae :=
       match a with
       | zero => hnil
       | cons a0 n b  => hcons_mult (iota a0) (S n) (iotas b)
       end.
(* end snippet iotaDef *)

(**  We now prove  a lot of technical lemmas that relate Hydras and
ordinals. *)

Lemma iota_iotas : forall alpha, nf alpha ->
                                 node (iotas alpha) =  iota alpha .
Proof.
  induction alpha.
  - reflexivity.
  - intros; now cbn.
Qed.

Lemma iotas_succ : forall alpha, nf alpha ->
                                 iotas (T1.succ alpha) =
                                 hy_app (iotas alpha) (hcons head hnil).
Proof.
  induction  alpha.
  - cbn; trivial.
  - destruct alpha1; intros.
    + T1_inversion H.
      subst alpha2;  replace (cons zero n zero) with (FS  n).
      * rewrite succ_compatS;   cbn;  clear  H;  induction n;simpl;auto.
        repeat f_equal;   injection IHn; auto.
      *  reflexivity.
    +   rewrite succ_rw1; simpl hy_app.
          simpl iotas; repeat f_equal; rewrite <- hcons_mult_app;
          rewrite IHalpha2; auto.
       *  eauto with T1.
       *  discriminate.
Qed.

Lemma hy_app_l_nil : forall l, hy_app l hnil = l.
Proof.
  induction l;cbn; auto;  rewrite IHl;auto.
Qed.

Lemma iota_succ_R1 : forall  o, nf o -> R1 (iota (T1.succ o)) (iota o).
Proof.
  intros; repeat rewrite <- iota_iotas; auto.
  -   rewrite iotas_succ; auto ;   constructor.
      replace  (iotas o) with (hy_app (iotas o) hnil) at 2.
      +   apply S0_app ;   constructor.
      +   now rewrite hy_app_l_nil.
  -  now apply succ_nf.
Qed.

Lemma iota_succ_round_n : forall  i alpha,
    nf alpha ->  round_n i (iota (T1.succ alpha)) (iota alpha).
Proof.
   left;  now apply iota_succ_R1.
Qed.

Lemma iota_succ_round : forall  o, nf o -> iota (T1.succ o) -1-> iota o.
Proof.
  intros; exists 0; left; now apply iota_succ_R1.
Qed.

Lemma iota_rw1 :
  forall i alpha,  nf alpha -> T1limit alpha = true ->
                   iota (canonS (cons alpha 0 zero) i) =
                   hyd1 (iota (canonS alpha i)).
Proof.
  intros i alpha H H0; unfold canonS; rewrite  canonS_lim1; auto.
Qed.

Lemma iota_rw2 :
  forall i n alpha,  nf alpha -> T1limit alpha = true ->
                     iota (canonS (cons alpha (S n) zero) i) =
                     node (hcons_mult (iota alpha) (S n)
                                      (hcons
                                         (iota (canonS alpha i)) hnil)).
Proof.
  intros i n alpha H H0; unfold canonS; rewrite  canonS_lim2; auto.
Qed.

Lemma iota_rw3 :
  forall i  alpha,  nf alpha ->
                    iota (canonS (cons (T1.succ alpha) 0 zero) i) =
                    node (hcons_mult (iota alpha) (S i) hnil).
Proof.
  intros i  alpha H; unfold canonS;  rewrite  canonS_phi0_succ_eqn; auto.
Qed.

Lemma iota_rw4 :
  forall i n  alpha ,  nf alpha ->
                       iota (canonS (cons (T1.succ alpha) (S n) zero) i) =
                       node (hcons_mult (iota (T1.succ alpha)) (S n)
                                        (hcons_mult (iota alpha) (S i) hnil)).
Proof.
  intros i  n alpha H; unfold canonS;  rewrite  canonS_cons_succ_eqn2; auto.
Qed.

Lemma iota_tail :
  forall i   alpha n beta,
    nf (cons alpha n beta) ->
    beta <> zero ->
    iota (canonS (cons alpha n beta) i) =
    node (hcons_mult (iota alpha) (S n) (iotas (canonS beta i)) ).
Proof.
  intros i   alpha n beta H H0; unfold canonS; rewrite  canon_tail; auto.
Qed.

Lemma R1_hcons : forall h s1 s2, R1 (node s1) (node s2) ->
                                 R1 (node (hcons h s1)) (node (hcons h s2)).
Proof. inversion 1;split;now right. Qed.

Lemma R1_hcons_mult  : forall n h s1 s2,
    R1 (node s1) (node s2) ->
    R1 (node (hcons_mult  h n s1))
       (node (hcons_mult  h n s2)).
Proof. inversion 1; split; now apply hcons_mult_S0. Qed.

Lemma R1_R2 : forall h h', R1 h h' -> R2 0 (hyd1 h) (hyd1  h').
Proof.
  intros; destruct h, h'; left;
    change (hcons (node h0) hnil) with (hcons_mult (node h0) 1 hnil);
    now left.
Qed.

(* The sequence s contains a head *)

Inductive mem_head : Hydrae -> Prop :=
  hh_1 : forall s, mem_head (hcons head s)
| hh_2 : forall h s, mem_head s -> mem_head (hcons h s).

Lemma S0_mem_head : forall s s', S0 s s' -> mem_head s.
Proof.
  induction 1.
  -  left.
  -  now right.
Qed.

Lemma mem_head_mult_inv : forall n h s, mem_head (hcons_mult h n s) ->
                                        h = head \/ mem_head s.
Proof.
  induction n; cbn ; auto.
  inversion 1;  auto.
Qed.

Lemma R1_mem_head : forall l l', R1 (node l) (node l') -> mem_head l.
Proof.
  inversion 1;   eapply S0_mem_head; eauto.
Qed.

Lemma limit_no_head : forall alpha, nf alpha -> T1limit alpha = true ->
                                    ~ mem_head (iotas alpha).
Proof.
  induction alpha.
  - discriminate.
  - intros; simpl;  destruct (T1limit_cases H).
    +  auto.
    +  destruct a;  subst; intro H2;  inversion H2.
       destruct alpha1.
       *    destruct H1;auto.
       *    discriminate H4.
       *  destruct  (mem_head_mult_inv _ _ _ H4).
          destruct alpha1.
          { destruct H1;   auto.  }
          discriminate H6.
          inversion H6.
    +  intro H7;
         change
           (hcons (iota alpha1) (hcons_mult (iota alpha1) n (iotas alpha2)))
           with   (hcons_mult (iota alpha1) (S n) (iotas alpha2)) in H7.
       destruct  (mem_head_mult_inv _ _ _ H7).
       *    destruct alpha1.
            destruct a.
            destruct H2;auto.
            discriminate.
       *   destruct IHalpha2;  eauto with T1.
           tauto.
Qed.

Lemma limit_no_R1 : forall alpha, nf alpha ->
                                  T1limit alpha = true ->
                                  forall h', ~ R1 (iota alpha) h'.
Proof.
  intros alpha H H0 h' H1; generalize ( limit_no_head _ H H0).
  intro H2; case_eq  (iota alpha); case_eq h';intros.
  subst h';rewrite <- iota_iotas in H1; auto.
  generalize (R1_mem_head _ _ H1).
  tauto.
Qed.

Lemma iota_of_succ :
  forall beta, nf beta ->
               iota (T1.succ beta) =
               match (iota beta) with
                 node s => node (hy_app s (hcons head hnil))
               end.
Proof.
  intros;  rewrite <- iota_iotas; auto.
  rewrite (iotas_succ); auto.
  rewrite <- iota_iotas; auto.
  apply succ_nf;auto.
Qed.

(* begin hide *)

Section DS_iota.
  Variable alpha : T1.
  Variable i : nat.
  Hypothesis Halpha : nf alpha.
  Hypothesis nonzero : alpha <> zero.

  Remark alpha_pos : LT zero  alpha.
  Proof.   now apply not_zero_lt.   Qed.

  Hypothesis Hrec : forall beta,
      beta <> zero -> LT beta  alpha ->
      forall gamma,  gamma = canonS beta i ->
                     round_n i (iota beta) (iota gamma).

  Lemma DS_iota_1 : forall gamma, nf gamma -> alpha = T1.succ gamma ->
                                  round_n i (iota alpha)
                                          (iota (canonS alpha i)).
  Proof.
    intros; subst alpha; rewrite canonS_succ; auto.
    now apply iota_succ_round_n.
  Qed.

  Lemma iota_phi0 : forall alpha, nf alpha ->
                                  iota (T1.phi0 alpha)= hyd1 (iota alpha).
  Proof.
    intros; now simpl.
  Qed.

  Lemma DS_iota_2 : forall lambda,
      nf lambda -> alpha = T1.phi0 lambda ->
      T1limit lambda ->
      round_n i (iota alpha) (iota (canonS alpha i)).
  Proof.
    intros;subst alpha.
    repeat rewrite iota_phi0; trivial.
    assert (nz : lambda <> zero).
    { eapply T1limit_not_zero; eauto. }
    right;  specialize (Hrec lambda nz (head_LT_cons  Halpha)).
    (* unfold T1.phi0; *) rewrite iota_rw1; trivial.
    right; left;  destruct (Hrec (canonS lambda i)); auto.
    assert False by (eapply limit_no_R1; eauto); contradiction.
  Qed.

  Lemma DS_iota_3 : forall  gamma,   nf gamma ->
                                     alpha = T1.phi0 (T1.succ gamma) ->
                                     round_n i (iota alpha)
                                             (iota (canonS alpha i)).
  Proof.
    intros; subst alpha; (* unfold T1.phi0; *) rewrite iota_rw3; auto.
    -  simpl iota;  rewrite (iota_of_succ gamma); auto.
       case_eq (iota gamma).
       right;  left;  simpl hy_app;  left.
       split; clear H0 ; induction h; auto.
       +  simpl; left.
       +  simpl; right;  auto.
  Qed.

  Section Proof_case_4.
    Variable lambda: T1.
    Hypothesis Hlambda : nf lambda.
    Hypothesis Hlim : T1limit lambda.
    Variable n : nat.
    Hypothesis Hn : alpha = cons lambda (S n) zero.

    Remark rem1 : canonS alpha i = cons lambda n (T1.phi0 (canonS lambda i)).
    Proof.
      subst alpha;  unfold canonS; rewrite canonS_lim2; auto.
    Qed.

    Lemma canonS_iota_4 :  round_n i (iota alpha) (iota (canonS alpha i)).
    Proof.
      rewrite rem1;  subst alpha;  simpl.
      right;  right ;  right; rewrite <- hcons_mult_comm.
      apply hcons_mult_S2.
      left;  specialize (Hrec lambda).
      assert (lambda t1< cons lambda (S n) zero)%t1.
      {  apply head_LT_cons; auto with T1. }
      specialize (Hrec (T1limit_not_zero Hlambda Hlim)
                       H  (canonS lambda i) (refl_equal _)).
      destruct Hrec; [| trivial];
        assert False by (eapply limit_no_R1; eauto); contradiction.
    Qed.

  End Proof_case_4.

  Section Proof_case_5.
    Variable gamma: T1.
    Hypothesis Hgamma : nf gamma.
    Variable n : nat.
    Hypothesis Hn : alpha = cons (T1.succ gamma) (S n) zero.

    Remark rem2 : canonS alpha i =
                  cons (T1.succ gamma)  n (cons gamma i zero).
    Proof.
      subst alpha;  unfold canonS; now rewrite canonS_cons_succ_eqn2.
    Qed.

    Remark rem3 : iota (canonS alpha i) =
                  node (hy_app (hcons_mult (iota (T1.succ gamma)) (S n) hnil)
                               (hcons_mult (iota gamma) (S i) hnil)).
    Proof.
      rewrite rem2; simpl; rewrite (iota_of_succ gamma); [| trivial].
      - case_eq (iota gamma).
        +  intros;  rewrite <- hcons_mult_comm; f_equal.
           rewrite <-  hcons_mult_app; simpl; rewrite  hcons_mult_comm;
             f_equal.
    Qed.

    Lemma canonS_iota_5 :  round_n i (iota alpha) (iota (canonS alpha i)).
    Proof.
      rewrite rem3;  subst alpha.
      simpl (iota (cons (T1.succ gamma) (S n) zero)); simpl hy_app.
      assert (R1 (iota (T1.succ gamma)) (iota  gamma)).
      {    apply iota_succ_R1; auto. }
      assert (S1 i (hcons (iota (T1.succ gamma)) hnil)
                 (hcons_mult (iota gamma) (S i) hnil)).
      {  left; auto. }
      generalize (S1_app i (hcons_mult (iota (T1.succ gamma)) n hnil) _ _ H0);
        intro H2; right.
      left; apply S1_next.
      simpl in H2; simpl.
      rewrite <- hcons_mult_app in H2.
      replace (hcons_mult (iota (T1.succ gamma)) n
                          (hy_app hnil (hcons (iota (T1.succ gamma)) hnil)))
        with
          (hy_app (hcons_mult (iota (T1.succ gamma)) n hnil)
                  (hcons (iota (T1.succ gamma)) hnil))
        in H2.
      - replace (hcons (iota (T1.succ gamma))
                       (hcons_mult (iota (T1.succ gamma)) n hnil))
          with (hy_app (hcons_mult (iota (T1.succ gamma)) n hnil)
                       (hcons (iota (T1.succ gamma)) hnil)).
        + apply S1_app;  auto.
        + generalize (iota (T1.succ gamma)) as h;intro.
          rewrite <- hcons_mult_app.
          simpl hy_app.
          now rewrite  <-  hcons_mult_comm.
      -  generalize (iota (T1.succ gamma)) as h;intro.
         simpl hy_app;  rewrite <- hcons_mult_app.
         simpl hy_app; auto.
    Qed.

  End Proof_case_5.

  Section Proof_case_6.
    Variables beta gamma: T1.
    Hypothesis Hbeta : nf beta.
    Hypothesis Hgamma : nf gamma.
    Hypothesis gamma_pos : gamma <> zero.
    Variable n : nat.
    Hypothesis Hn : alpha = cons  beta n gamma.

    Remark rem6 : canonS alpha i = cons beta n (canonS gamma i).
    Proof.
      subst alpha;  unfold canonS; rewrite canon_tail; auto with T1.
    Qed.

    Remark rem61 : gamma t1< alpha.
    Proof.
      subst alpha;  now apply tail_LT_cons.
    Qed.

    Remark rem62 : round_n i (iota gamma) (iota  (canonS gamma i)).
    Proof.
      eapply Hrec; auto;  apply rem61.
    Qed.

    Lemma canonS_iota_6 :  round_n i (iota alpha) (iota (canonS alpha i)).
    Proof.
      rewrite rem6;  destruct rem62; subst alpha.
      -  simpl iota; left; apply R1_hcons; apply R1_hcons_mult;
           repeat rewrite iota_iotas.
         +  assumption.
         + apply nf_canon;auto.
         +  auto.
      -  right;  simpl; destruct n.
         +  simpl;
              replace  (hcons (iota beta) (iotas gamma)) with
                  (hy_app (hcons (iota beta) hnil) (iotas gamma)).
            replace  (hcons (iota beta) (iotas (canonS gamma i))) with
                (hy_app (hcons (iota beta)hnil) (iotas (canonS gamma i))).
            apply R2_app; repeat  rewrite iota_iotas; auto.
            eapply nf_canon;auto.
            simpl; auto.
            simpl; auto.
         + replace
             (hcons (iota beta) (hcons_mult (iota beta) (S n0) (iotas gamma)))
             with
               (hy_app (hcons (iota beta) (hcons_mult (iota beta) (S n0) hnil))
                       (iotas gamma)).
           replace
             (hcons (iota beta) (hcons_mult (iota beta) (S n0)
                                            (iotas (canonS gamma i))))
             with
               (hy_app (hcons (iota beta) (hcons_mult (iota beta) (S n0) hnil))
                       (iotas (canonS gamma i))).
           * apply R2_app;repeat  rewrite iota_iotas; auto.
             eapply nf_canon;auto.
           *  simpl; auto.
              simpl; auto.
              repeat f_equal.
              rewrite <- hcons_mult_app;  now simpl hy_app.
           * rewrite <- hcons_mult_comm; simpl; f_equal.
             rewrite  hcons_mult_comm; simpl; f_equal.
             now rewrite  <- hcons_mult_app.
    Qed.

  End Proof_case_6.

  Remark all_cases : exists beta n gamma,
      nf beta /\ nf gamma /\ alpha = cons beta n gamma.
  Proof.
    destruct alpha as [|  beta n gamma].
    - destruct nonzero; auto.
    - exists beta, n, gamma; split;eauto with T1.
  Qed.

  Lemma canonS_iota_final :  round_n i (iota alpha) (iota (canonS alpha i)).
  Proof.
    destruct all_cases as [beta [n [gamma Heq]]]; decompose [and] Heq.
    destruct (zero_limit_succ_dec Halpha).
    -   destruct s.
        +  contradiction.
        +  destruct n.
           * destruct (zero_limit_succ_dec H).
             { destruct s.
               -  subst beta; rewrite H2 in Halpha.
                  generalize (nf_of_finite Halpha).
                  intro; subst gamma alpha.
                  simpl iota;  left.
                  split; left.
               - destruct gamma.
                 + eapply DS_iota_2 with beta; auto.
                 + eapply canonS_iota_6.
                   eexact H1.
                   discriminate.
                   eexact H2.
             }
             destruct gamma.
             { destruct s as [gamma' [H3 H4]].
               subst beta;  eapply DS_iota_3 ; eauto.
             }
             eapply canonS_iota_6.
             eexact H1.
             discriminate.
             eauto.
           *
             destruct gamma.
             { destruct(zero_limit_succ_dec H).
               - destruct s.
                 + subst beta  alpha;  left.
                   split.
                   simpl (hcons_mult head (S (S n)) hnil).
                   left.
                 + eapply canonS_iota_4.
                   eexact H.
                   auto.
                   eauto.
               -  destruct s as [gamma [H3 H4]].
                  subst beta; eapply canonS_iota_5.
                  eexact H3.
                  eauto.
             }
             eapply canonS_iota_6.
             eexact H1.
             discriminate.
             eauto.
    -  destruct s as [delta [H3 H4]].
       eapply DS_iota_1; eauto.
  Qed.

End DS_iota.

(* end hide *)

Lemma canonS_iota_i : forall i alpha , nf alpha ->  alpha <> zero ->
                                round_n i (iota alpha) (iota (canonS alpha i)).
Proof.
  intros i alpha ; transfinite_induction_lt alpha.
  intros; eapply canonS_iota_final;eauto.
  intros beta H2 H3 gamma H4; rewrite H4; apply H; eauto with T1.
Qed.

(* begin snippet canonSIota *)

Lemma canonS_iota i a :
  nf a -> a <> 0 -> iota a -1-> iota (canon a (S i)). (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intros;  destruct (canonS_iota_i i a  H H0).
  - exists 0; now left.
  - exists i; now right.
Qed.
  (*||*)
  (* end snippet canonSIota *)

  Lemma canonS_rel_rounds : forall n alpha beta,
      nf alpha -> nf beta ->
      alpha <> zero ->
      beta = canonS alpha n ->
      iota alpha -+-> iota beta.
  Proof.
    inversion 4; subst; left; apply canonS_iota; auto.
  Qed.

Lemma trace_to_round_plus h' : forall t h,  trace_to h' t h -> round_plus h h'.
Proof.
 induction 1.
 - left; exists n; auto.
 - right with h'0. exists n; auto.
   apply IHtrace_to.
Qed.

Import MoreLists.
(* begin hide *)

Lemma trace_to_std_0 h' : forall l i h,
    trace_to h' (iota_from i (S l)) h ->
    rounds standard  i h (S l + i) h'.
Proof.
  induction l.
  simpl.
  intros.
  left.
  red.
  simpl.
  inversion H.
  auto.
  inversion H4.
  intros.
  inversion H. subst.

  right with h'0.
  simpl.
  auto.
  specialize (IHl (S i) h'0 H4).
  simpl.
  rewrite Nat.add_succ_r in IHl. auto.
Qed.

(* end hide *)

Lemma trace_to_std i h j h': (i <= j)%nat ->
                             trace_to h' (interval i j) h ->
                             rounds standard  i h (S j) h'.
Proof.
 unfold interval. intro H.
 simpl in H.  replace (S j - i)%nat with (S (j - i))%nat by lia.
 intro.
  apply trace_to_std_0 in H0.
   replace (S (j - i) + i)%nat with (S j) in H0 by lia. auto.
Qed.

Lemma path_toS_trace alpha s beta :
  path_toS beta s alpha -> nf alpha -> trace_to (iota beta) s (iota alpha).
Proof.
  induction 1.
  - destruct H.
    intro; left.
    subst.
    apply canonS_iota_i; auto.
  - intro.
    right with (iota gamma).
    destruct H.
    subst.
    apply   canonS_iota_i; auto.
    apply IHpath_toS.
    destruct H.
    subst.
    apply nf_canon.
    auto.
Qed.

  Lemma path_toS_round_plus alpha s beta :
    path_toS beta s alpha -> nf alpha ->
    iota alpha -+-> iota beta.
    intros; apply trace_to_round_plus with s.
    now apply path_toS_trace.
  Qed.

  (* begin snippet pathToRoundPlus *)

  Lemma path_to_round_plus a s b :
    path_to b s a -> nf a -> iota a -+-> iota b. (* .no-out *)
  (*| .. coq:: none |*)
  Proof.
    intros H H0; apply path_to_path_toS in H.
    now apply  path_toS_round_plus with (MoreLists.unshift s).
  Qed.
  (*||*)
  (* end snippet pathToRoundPlus *)

  Lemma acc_from_to_round_plus alpha beta :
    nf alpha -> nf beta -> alpha <> 0 ->
    acc_from alpha beta -> iota alpha -+-> iota beta.
  Proof.
    destruct 4.
    rewrite path_to_path_toS_iff in H2.
    eapply   path_toS_round_plus; eauto.
    eapply path_to_not_In_zero; eauto.
  Qed.

  (** Any strict inequality on [T1] can be converted into a (free) battle *)

  (* begin snippet LTToRoundPlus *)

  Lemma LT_to_round_plus a b : b t1< a ->  iota a -+-> iota b. (* .no-out *)
  (*| .. coq:: none |*)
  Proof.
    intros H; apply acc_from_to_round_plus; eauto with T1.
    - intro; subst; apply (not_LT_zero H).
    - apply LT_acc_from; eauto with T1.
  Qed.
 (*||*)
 (* end snippet LTToRoundPlus *)


Require Export Relations Classical ClassicalEpsilon Zwf.
Require Export Compare_dec.
Require Export List ZArith.

(* SECTION: Proving Tarski's fixpoint theorem. *)

Arguments antisymmetric : default implicits.
Arguments transitive : default implicits.
Arguments reflexive : default implicits.

Section cpos.
Variables (A:Type)(R:A->A->Prop).

Definition upper_bound (x:A)(f:nat -> A) :=
  forall n, R (f n) x.

Definition lub (x:A)(f:nat -> A) :=
  upper_bound x f /\ forall y, upper_bound y f -> R x y.

Lemma least_unique :
  antisymmetric R ->
  forall (P : A -> Prop)(x y: A),
  P x /\ (forall z, P z -> R x z) ->
  P y /\ (forall z, P z -> R y z) -> x = y.
Proof.
intuition.
Qed.

Lemma unique_lub :
  forall (f:nat->A)(x y: A),
     antisymmetric R ->
     lub x f -> lub y f -> x = y.
Proof.
intros f x y Ha Hx Hy.
apply least_unique with (fun x => upper_bound x f); auto.
Qed.

Definition chain (f:nat->A) := forall n, R (f n)(f (S n)).

Lemma chain_le :
  transitive R -> reflexive R ->
  forall f x y, chain f -> x <= y -> R (f x) (f y).
intros Ht Hr f x y Hc H; induction H; eauto.
Qed.

Definition complete :=
  forall f:nat->A, chain f -> exists x: A, lub x f.

End cpos.
Arguments upper_bound : default implicits.
Arguments lub : default implicits.
Arguments chain : default implicits.
Arguments complete : default implicits.

Section continuity.

Variables (A B:Type)(R :A->A->Prop)(R' :B->B->Prop).

Definition monotonic (f:A -> B) :=
    forall x y, R x y -> R' (f x) (f y).

Definition continuous (f:A -> B) :=
  forall (c: nat -> A),  chain R c ->
    forall (l:A), lub R l c ->
    lub R' (f l) (fun n => f (c n)).

Lemma continuous_imp_monotonic :
  forall f, reflexive R -> continuous f -> monotonic f.
Proof.
intros f Hr Hc x y Hxy.
assert (Hl : lub R' (f y) (fun n => f (match n with 0 => x | _ => y end))).
apply (Hc (fun n => match n with 0 => x | _ => y end)).
unfold chain; destruct n; auto.
split.
unfold upper_bound; destruct n; auto.
intros b H; exact (H 1).
destruct Hl as [Hu Hl']; exact (Hu 0).
Qed.

(* This theorem is not really used, but I keep it as a way to
   show that my definition of being continuous is close to the
   conventional one. *)

Lemma continuous_reverse :
  forall (f:A->B)(c :nat->A),
  antisymmetric R' -> chain R c ->
  continuous f ->
  forall (l:A), lub R l c ->
  forall (l':B), lub R' l' (fun n => f (c n)) ->
   l' = f l.
intros f c Ha Hch Hct l Hlub l' Hlub'.
assert (Hlub2 : lub R' (f l)(fun n => f (c n))).
exact (Hct c Hch l Hlub).
apply (unique_lub B R' (fun n => f (c n))); assumption.
Qed.

End continuity.
Arguments monotonic : default implicits.
Arguments continuous : default implicits.

Section Tarski_theory.

Variables (A:Type)(R:A->A->Prop)(bot : A)(f:A->A).

Hypotheses (Hr : reflexive R)(Ha : antisymmetric R)
   (Ht : transitive R) (Hc : complete R)
   (Hb : forall x, R bot x)(Hct : continuous R R f).

Definition least_fixpoint (f:A->A)(x:A):Prop :=
  x = f x /\ (forall y, y = f y -> R x y).

Fixpoint iter (k:nat)(x:A) : A :=
  match k with 0 => x | S p => f (iter p x) end.

Lemma f_monotonic : monotonic R R f.
apply continuous_imp_monotonic; auto.
Qed.

Lemma Hchain_iter_f_bot : chain R (fun n => iter n bot).
unfold chain. induction n.
simpl. apply Hb.
apply (f_monotonic (iter n bot) (iter (S n) bot)). assumption.
Qed.

Lemma phi_ub_iter_add_f :
   forall phi : A,
       upper_bound R phi (fun n => iter n bot) ->
       upper_bound R phi (fun n => f (iter n bot)).
intros phi Hup p; apply (Hup (S p)).
Qed.

Lemma f_phi_upper_bound :
   forall phi : A,
       upper_bound R phi (fun n => iter n bot) ->
       upper_bound R (f phi) (fun n => iter n bot).
intros phi Hup [ | p].
apply Hb.
apply (f_monotonic (iter p bot)); apply (Hup p).
Qed.

Lemma lub_iterates_fixpoint :
   forall phi : A, lub R phi (fun n => iter n bot) -> phi = f phi.
intros phi [Hub Hl]; apply Ha.
apply Hl; apply f_phi_upper_bound; assumption.
assert (Hfphi : lub R (f phi) (fun n => f (iter n bot))).
apply (Hct (fun n => iter n bot) Hchain_iter_f_bot phi);split;assumption.
destruct Hfphi as [Hub' Hl'].
apply Hl'; apply phi_ub_iter_add_f; assumption.
Qed.

Lemma phi_less_than_fixpoint :
  forall phi : A, lub R phi (fun n => iter n bot) ->
  forall psi : A, psi = f psi -> R phi psi.
intros phi [Hup Hl] psi Hfxp; apply Hl.
intros n; induction n.
simpl; auto.
simpl; rewrite Hfxp; apply f_monotonic; assumption.
Qed.

Theorem Tarski_least_fixpoint : exists phi: A, least_fixpoint f phi.
destruct (Hc (fun n => iter n bot) Hchain_iter_f_bot) as [phi Hlub].
exists phi.
split.
apply lub_iterates_fixpoint; auto.
apply phi_less_than_fixpoint; auto.
Qed.

Theorem least_fixpoint_lub_iterates :
  forall phi, least_fixpoint f phi -> lub R phi (fun n => iter n bot).
intros phi Hlfp.
destruct (Hc (fun n => iter n bot) Hchain_iter_f_bot) as [psi Hlub'].
replace phi with psi.
trivial.
symmetry.
apply least_unique with (1:= Ha) (P:= fun x => x = f x) (2:= Hlfp).
split.
apply lub_iterates_fixpoint; auto.
apply phi_less_than_fixpoint; auto.
Qed.

End Tarski_theory.
Arguments least_fixpoint : default implicits.

(* SECTION: basic properties of the basic discrete order. *)

Section opt_cpo.
Variable A: Type.

Inductive option_cpo : option A -> option A -> Prop :=
  option_cpo_none_bot : forall x: option A, option_cpo None x
| option_cpo_refl : forall x: option A, option_cpo x x.

Lemma reflexive_option_cpo : reflexive option_cpo.
Proof option_cpo_refl.

Hint Resolve option_cpo_refl option_cpo_none_bot reflexive_option_cpo : core.

Lemma antisym_option_cpo : antisymmetric option_cpo.
intros x y H; inversion H.
intros H'; inversion H'; trivial.
trivial.
Qed.

Lemma transitive_option_cpo_aux :
  forall (x y: option A),
   option_cpo x y -> forall z, option_cpo y z -> option_cpo x z.
intros x y H; inversion H; auto.
Qed.

Lemma transitive_option_cpo :  transitive option_cpo.
intros x y z H1 H2 ; apply transitive_option_cpo_aux with y ; assumption.
Qed.

Hint Resolve transitive_option_cpo : core.

Lemma chain_none_pred :
  forall f n p, chain option_cpo f ->
  p <= n -> f n = None -> f p = None.
intros f n p Hch Hpn. elim Hpn. auto.
intros m Hpm Hfmfp Hfsm. apply Hfmfp.
assert (Hcpo : option_cpo (f m) (f (S m))) by apply Hch.
inversion Hcpo; auto; rewrite <- Hfsm; auto.
Qed.

Theorem value_upper_bound :
  forall f x, chain option_cpo f -> f x <> None ->
  upper_bound option_cpo (f x) f.
intros f x Hchain Hneq y.
case (le_gt_dec x y); [intros Hlexy | intros Hltyx].
assert (Hcpo: option_cpo (f x) (f y)) by (apply chain_le; auto).
inversion Hcpo; [elim Hneq; auto | auto].
apply chain_le; auto with arith.
Qed.

Hint Resolve value_upper_bound : core.
Theorem complete_option_cpo : complete option_cpo.
intros f Hchain.
elim (classic (forall n, f n = None)).
intros Hn; exists (None (A:=A)).
split; intros p; try rewrite Hn; auto.
intros Hnotforall.
elim not_all_ex_not with
   (P:= fun x => f x = None) (1:= Hnotforall).
intros n Hneq; exists (f n); split; [auto | intros y; auto].
Qed.
End opt_cpo.
Global Hint Resolve option_cpo_refl option_cpo_none_bot reflexive_option_cpo : core.
Arguments option_cpo : default implicits.

(* SECTION: providing usable mathematical tools for a classical setting. *)

Axiom extensionality :
  forall A : Type, forall B : A -> Type,
    forall f g: forall x:A, B x,
      (forall x, f x = g x) -> f = g.

(* SECTION: lifting an order to the function space. *)
Section pointwise_update_function.
Variables (A B:Type)(f:A->B)(x:A)(v:B).

Definition p_v  (y:A) :=
     epsilon (inhabits v) (fun w => (y=x-> w =v)/\(y<>x->w=f y)).

Lemma pointwise_variant_eq : p_v x = v.
unfold p_v; elim (epsilon_spec (inhabits v)(fun w => (x=x->w=v)/\(x<>x->w=f x))).
auto.
exists v;split;[auto|intros Habs;case Habs;trivial].
Qed.

Lemma pointwise_variant_diff : forall y, y<> x -> p_v y = f y.
intros y Hn; unfold p_v;
 elim (epsilon_spec(inhabits v)(fun w =>(y=x->w=v)/\(y<>x->w=f y))).
intuition.
exists (f y);split;[intros Habs; elim Hn;auto|auto].
Qed.

End pointwise_update_function.

Arguments p_v : default implicits.
Arguments pointwise_variant_eq : default implicits.
Arguments pointwise_variant_diff : default implicits.

Section lift.

Variables (A B:Type)(R:B->B->Prop).
Hypothesis Hr : reflexive R.
Hypothesis Ha : antisymmetric R.
Hypothesis Ht : transitive R.
Hypothesis Hc : complete R.

Definition lift_order :=
   fun (f g:A->B)=> forall x, R (f x)(g x).

Lemma reflexive_lift : reflexive lift_order.
intros f x; apply Hr.
Qed.

Lemma antisymmetric_lift : antisymmetric lift_order.
intros f g HfRg HgRf.
apply extensionality with (B:= fun x:A => B).
intros x; apply (Ha (f x) (g x)); apply (HfRg x) || apply (HgRf x).
Qed.

Lemma transitive_lift : transitive lift_order.
intros f g h Hfg Hgh x; apply Ht with (g x).
apply (Hfg x).
apply (Hgh x).
Qed.

Lemma lift_lub : forall (f:A->B)(c:nat->A->B),
   (forall x, lub R (f x)(fun n=> c n x))-> lub lift_order f c.
Proof.
intros f c Hx; split.
intros n x; destruct (Hx x) as [Hu Hl]; apply Hu.
intros g Hug x; destruct (Hx x) as [_ Hl]; apply Hl.
intros n; apply (Hug n x).
Qed.

Lemma chain_lift_reverse :
  forall c, chain lift_order c -> forall x, chain R (fun n => c n x).
intros c Hch x n; apply (Hch n x).
Qed.

Lemma lift_complete : complete lift_order.
Proof.
intros c Hchain.
exists (fun x => epsilon(inhabits (c 0 x))(fun v => lub R v (fun n => c n x))).
apply lift_lub.
intros x; apply epsilon_spec.
apply Hc; apply chain_lift_reverse; assumption.
Qed.

Lemma lub_lift_reverse :
  forall (c:nat->A->B)(l:A->B),
  lub lift_order l c -> forall x, lub R (l x)(fun n => c n x).
Proof.
intros c l [Hub Hl] x.
split.
intros n; apply (Hub n x).
intros b' Hup'.
assert (Hupg' : upper_bound lift_order (p_v l x b') c).
intros n y; case (classic (y=x)).
intros Hyx; subst y; rewrite pointwise_variant_eq; apply Hup'.
intros Hn; rewrite pointwise_variant_diff; auto; apply Hub.
rewrite <- (pointwise_variant_eq l x b'); apply Hl; assumption.
Qed.

End lift.

Definition f_order (A B:Type) :=
  lift_order A (option B)(@option_cpo B).

Theorem reflexive_f_order : forall A B, reflexive (f_order A B).
intros A B f x; auto.
Qed.

Theorem antisymmetric_f_order : forall A B, antisymmetric (f_order A B).
intros; unfold f_order; apply antisymmetric_lift; apply antisym_option_cpo.
Qed.

Theorem transitive_f_order : forall A B, transitive (f_order A B).
intros; unfold f_order; apply transitive_lift; apply transitive_option_cpo.
Qed.

Theorem complete_f_order : forall A B, complete (f_order A B).
intros; unfold f_order; apply lift_complete; apply complete_option_cpo.
Qed.

(* The specific form of the Tarski least fixpoint theorem when used
  solely to define recursive functions. *)
Definition Tarski_fix
   (A B:Type) (f:(A->option B)->A->option B) : A->option B :=
  (epsilon (inhabits (fun x => None))
              (fun phi => least_fixpoint (f_order A B) f phi)).

Arguments Tarski_fix [A B].

Theorem Tarski_fix_prop :
    forall (A B:Type) (f : (A -> option B)->A -> option B),
      continuous (f_order A B)(f_order A B) f ->
      least_fixpoint (f_order A B) f (Tarski_fix f).
Proof.
intros A B f Hct; unfold Tarski_fix.
apply epsilon_spec.
assert (Ht := Tarski_least_fixpoint).
apply Tarski_least_fixpoint with (R:=f_order A B)
        (bot:=fun x:A=>@None B)
        (4:= (fun (g:A->option B) x => @option_cpo_none_bot B (g x))).
apply reflexive_f_order.
apply antisymmetric_f_order.
apply complete_f_order.
exact Hct.
Qed.

(* Properties of chains. *)

Theorem continuous_chain :
  forall (A B:Type)(R:A->A->Prop)
     R' (f:A->B), reflexive R -> continuous R R' f ->
    forall c, chain R c -> chain R' (fun x => f (c x)).
intros A B R R' f Hr Hct c Hch n;
    apply (continuous_imp_monotonic _ _ R _ _ Hr Hct (c n) (c (S n))).
auto.
Qed.

Theorem lub_some_witness1 :
   forall (A:Type) (c:nat -> option A)(v:A),
   lub (@option_cpo A) (Some v) c ->
   (exists n:nat, c n = Some v).
intros A c v [Hup Hl].
elim (classic (forall n, c n = None)).
intros Hnone.
assert (Hnone_aux : option_cpo (Some v) None).
apply Hl.
intros n.
rewrite Hnone; auto.
inversion Hnone_aux.
intros Hnot_all.
assert (Hex_not : exists n, c n <> None).
apply not_all_ex_not with (U:=nat)
  (P:= fun n => c n = None)(1:= Hnot_all).
destruct Hex_not as [n Hneq].
assert (Hopt: option_cpo (c n) (Some v)).
apply (Hup n).
exists n.
inversion Hopt; auto.
elim Hneq; auto.
Qed.

Theorem lub_some_witness :
   forall (A B:Type) c (a:A)(b:B)(f:A->option B), f a = Some b ->
   lub (lift_order A (option B) (option_cpo (A:=B))) f c  ->
   (exists n:nat, c n a = Some b).
intros A B c a b f Heq Hlub.
apply (lub_some_witness1 B (fun n => c n a) b).
assert (Hlub':= lub_lift_reverse A _ (@option_cpo B) c f Hlub a).
rewrite <- Heq; assumption.
Qed.

Theorem Tarski_fix_iterates_witness :
    forall (A B:Type) (f : (A -> option B)->A -> option B),
      continuous (f_order A B)(f_order A B) f->
      forall (x:A)(v:B), Tarski_fix f x = Some v ->
    exists n, iter (A->option B) f n (fun a => None) x = Some v.
intros A B f Hct x.
assert (H:lub (f_order A B) (Tarski_fix f)
              (fun n => iter _ f n (fun a=>None))).
apply least_fixpoint_lub_iterates.
apply reflexive_f_order.
apply antisymmetric_f_order.
apply complete_f_order.
intros g y; apply option_cpo_none_bot.
assumption.
apply Tarski_fix_prop.
assumption.
intros v Heq.
apply lub_some_witness with (A:=A)(B:=B)(1:= Heq)(2:=H).
Qed.

Theorem iterates_none_imp_fix_none :
  forall A B f,  continuous (f_order A B)(f_order A B) f-> forall x,
  (forall n, iter _ f n (fun z => None) x = None) ->
  Tarski_fix f x = None.
intros A B f Hct x Happr.
case_eq (Tarski_fix f x).
intros v Heq;
destruct (Tarski_fix_iterates_witness A B f Hct x v Heq) as
  [n Heq'].
rewrite (Happr n) in Heq'; discriminate.
trivial.
Qed.

(* SECTION: An order for functions that stay in the same type. *)

Definition f_order' (A:Type) :=  f_order A A.

Theorem reflexive_f_order' : forall A, reflexive (f_order' A).
intros; unfold f_order'; apply reflexive_f_order.
Qed.

Theorem antisymmetric_f_order' : forall A, antisymmetric (f_order' A).
intros; unfold f_order'; apply antisymmetric_f_order.
Qed.

Theorem transitive_f_order' : forall A, transitive (f_order' A).
intros; unfold f_order'; apply transitive_f_order.
Qed.

Theorem complete_f_order' : forall A, complete (f_order' A).
intros; unfold f_order'; apply complete_f_order.
Qed.

Global Hint Resolve reflexive_f_order' antisymmetric_f_order' transitive_f_order'
  complete_f_order' : core.


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

(** * Halting problem for FRACTRAN programs FRACTRAN_HALTING *)

Require Import Vector List Arith.

From Undecidability.Shared.Libs.DLW
  Require Import gcd rel_iter pos vec.

Reserved Notation "l '/F/' x ≻ y" (at level 70, no associativity).

Implicit Type l : list (nat*nat).

Definition fractran_regular (l : list (nat * nat)) := Forall (fun c => snd c <> 0) l.

Inductive fractran_step : list (nat*nat) -> nat -> nat -> Prop :=
  | in_fractran_0 : forall p q l n m, q*m = p*n -> (p,q)::l /F/ n ≻ m
  | in_fractran_1 : forall p q l n m', ~ (exists m, (p*n) = m * q) -> l /F/ n ≻ m' -> (p,q)::l /F/ n ≻ m'
where "l /F/ x ≻ y" := (fractran_step l x y).

Reserved Notation "l '/F/' x ▹ y" (at level 70, no associativity).

Inductive fractran_eval : list (nat*nat) -> nat -> nat -> Prop :=
| fractran_eval_stop P n : ~ (exists m, P /F/ n ≻ m) -> P /F/ n ▹ n
| fractran_eval_step P n m m' : P /F/ n ≻ m -> P /F/ m ▹ m' -> P /F/ n ▹ m'
where "l /F/ x ▹ y" := (fractran_eval l x y).

(* FRACTRAN Halting Problem *)
Definition Halt_FRACTRAN '(P, n) :=
  exists m, P /F/ n ▹ m.

Import Vector.VectorNotations.
From Undecidability.FRACTRAN Require Import prime_seq.

Fixpoint enc {k} i (v : Vector.t nat k) : nat :=
  match v with
  | @Vector.nil _ => 1
  | x :: v => (qs i) ^ x * enc (S i) v
  end.

Definition FRACTRAN_computable {k} (R : Vector.t nat k -> nat -> Prop) :=
  exists P : list (nat * nat), fractran_regular P /\
    forall v : Vector.t nat k,
      (forall m, R v m <-> exists j, fractran_eval P (ps 1 * enc 2 v) (j * (qs 1)^m) /\ ~ divides (qs 1) j).

(* left-unique step relation *)
Definition fractran_reversible (P : list (nat * nat)) :=
  forall n1 n2 m, P /F/ n1 ≻ m -> P /F/ n2 ≻ m -> n1 = n2.

(* Reversible FRACTRAN Halting Problem *)
Definition Halt_REV_FRACTRAN : { P : list (nat * nat) | fractran_reversible P } * nat -> Prop :=
  fun '(P, n) => exists m, (proj1_sig P) /F/ n ▹ m.

Module FRACTRANNotations.
Notation "l /F/ x ≻ y" := (fractran_step l x y).
Notation "l /F/ x ▹ y" := (fractran_eval l x y).
End FRACTRANNotations.