Require Import Coq.Program.Program.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Bool_nat.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.
Require Import Coq.Relations.Relations.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Wellfounded.Lexicographic_Product.

Generalizable All Variables.

Reserved Infix "⊓" (at level 40, left associativity).
Reserved Infix "⊔" (at level 36, left associativity).

Class Lattice (A : Type) := {
  meet : A -> A -> A where "x ⊓ y" := (meet x y);
  join : A -> A -> A where "x ⊔ y" := (join x y);

  meet_commutative : forall a b, a ⊓ b = b ⊓ a;
  meet_associative : forall a b c, (a ⊓ b) ⊓ c = a ⊓ (b ⊓ c);
  meet_absorptive  : forall a b, a ⊓ (a ⊔ b) = a;
  meet_idempotent  : forall a, a ⊓ a = a;

  join_commutative : forall a b, a ⊔ b = b ⊔ a;
  join_associative : forall a b c, (a ⊔ b) ⊔ c = a ⊔ (b ⊔ c);
  join_absorptive  : forall a b, a ⊔ (a ⊓ b) = a;
  join_idempotent  : forall a, a ⊔ a = a
}.

Infix "⊓" := meet (at level 40, left associativity).
Infix "⊔" := join (at level 36, left associativity).

Class Order (A : Set) := {
  ord : relation A;

  reflexive :> Reflexive ord;
  antisymmetric : forall {x y}, ord x y -> ord y x -> x = y;
  transitive :> Transitive ord
}.

Infix "≤" := ord (at level 50).

Class LOSet {A : Set} `(@Order A) `(@Lattice A) := {
  meet_consistent : forall a b, a ≤ b <-> a = a ⊓ b;
  join_consistent : forall a b, a ≤ b <-> b = a ⊔ b
}.

Section Lattice.

Context `{O : Order A}.
Context `{L : Lattice A}.
Context `{@LOSet A O L}.

Theorem meet_is_glb : forall a b : A,
  forall x, x ≤ a /\ x ≤ b <-> x ≤ a ⊓ b.
Proof.
  split; intros.
    intuition.
    apply meet_consistent in H1.
    apply meet_consistent in H2.
    apply meet_consistent.
    rewrite <- meet_associative, <- H1.
    assumption.
  apply meet_consistent in H0.
  rewrite H0; clear H0.
  split; apply meet_consistent.
    rewrite meet_associative.
    rewrite (meet_commutative (a ⊓ b) a).
    rewrite <- (meet_associative a).
    rewrite meet_idempotent.
    reflexivity.
  rewrite meet_associative.
  rewrite meet_associative.
  rewrite meet_idempotent.
  reflexivity.
Qed.

Theorem meet_prime : forall a b : A,
  forall x, a ≤ x \/ b ≤ x -> a ⊓ b ≤ x.
Proof.
  intros.
  destruct H0;
  apply meet_consistent in H0;
  apply meet_consistent; [rewrite meet_commutative|];
  rewrite meet_associative;
  rewrite <- H0; reflexivity.
Qed.

Theorem join_is_lub : forall a b : A,
  forall x, a ≤ x /\ b ≤ x <-> a ⊔ b ≤ x.
Proof.
  split; intros.
    intuition.
    apply join_consistent in H1.
    apply join_consistent in H2.
    apply join_consistent.
    rewrite join_associative, <- H2.
    assumption.
  apply join_consistent in H0.
  rewrite H0; clear H0.
  split; apply join_consistent.
    rewrite <- join_associative.
    rewrite <- join_associative.
    rewrite join_idempotent.
    reflexivity.
  rewrite (join_commutative a b).
  rewrite <- join_associative.
  rewrite <- join_associative.
  rewrite join_idempotent.
  reflexivity.
Qed.

Theorem join_prime : forall a b : A,
  forall x, x ≤ a \/ x ≤ b -> x ≤ a ⊔ b.
Proof.
  intros.
  destruct H0;
  apply join_consistent in H0;
  apply join_consistent; [|rewrite join_commutative];
  rewrite <- join_associative;
  rewrite <- H0; reflexivity.
Qed.

Set Decidable Equality Schemes.

Inductive Term : Set :=
  | Var  : nat  -> Term
  | Meet : Term -> Term -> Term
  | Join : Term -> Term -> Term.

Lemma Meet_acc_l x y : Meet x y <> x.
Proof.
  induction x;
  unfold not; intros;
  try discriminate.
  inversion H0; subst.
  contradiction.
Qed.

Lemma Meet_acc_r x y : Meet x y <> y.
Proof.
  induction y;
  unfold not; intros;
  try discriminate.
  inversion H0; subst.
  contradiction.
Qed.

Lemma Join_acc_l x y : Join x y <> x.
Proof.
  induction x;
  unfold not; intros;
  try discriminate.
  inversion H0; subst.
  contradiction.
Qed.

Lemma Join_acc_r x y : Join x y <> y.
Proof.
  induction y;
  unfold not; intros;
  try discriminate.
  inversion H0; subst.
  contradiction.
Qed.

Fixpoint length (t : Term) : nat :=
  match t with
  | Var n => 1
  | Meet t1 t2 => 1 + length t1 + length t2
  | Join t1 t2 => 1 + length t1 + length t2
  end.

Fixpoint depth (t : Term) : nat :=
  match t with
  | Var n => 0
  | Meet t1 t2 => 1 + max (depth t1) (depth t2)
  | Join t1 t2 => 1 + max (depth t1) (depth t2)
  end.

Inductive Subterm : Term -> Term -> Prop :=
  | Meet1 : forall t1 t2, Subterm t1 (Meet t1 t2)
  | Meet2 : forall t1 t2, Subterm t2 (Meet t1 t2)
  | Join1 : forall t1 t2, Subterm t1 (Join t1 t2)
  | Join2 : forall t1 t2, Subterm t2 (Join t1 t2).

Definition Subterm_inv_t : forall x y, Subterm x y -> Prop.
Proof.
  intros [] [] f;
  match goal with
  | [ H : Subterm ?X (Meet ?Y ?Z) |- Prop ] =>
    destruct (Term_eq_dec X Y); subst;
    [ destruct (Term_eq_dec X Z); subst;
      [ exact (f = Meet1 _ _ \/ f = Meet2 _ _)
      | exact (f = Meet1 _ _) ]
    | destruct (Term_eq_dec X Z); subst;
      [ exact (f = Meet2 _ _)
      | exact False ] ]
  | [ H : Subterm ?X (Join ?Y ?Z) |- Prop ] =>
    destruct (Term_eq_dec X Y); subst;
    [ destruct (Term_eq_dec X Z); subst;
      [ exact (f = Join1 _ _ \/ f = Join2 _ _)
      | exact (f = Join1 _ _) ]
    | destruct (Term_eq_dec X Z); subst;
      [ exact (f = Join2 _ _)
      | exact False ] ]
  | _ => exact False
  end.
Defined.

Corollary Subterm_inv x y f : Subterm_inv_t x y f.
Proof.
  pose proof Term_eq_dec.
  destruct f, t1, t2; simpl;
  destruct (Term_eq_dec _ _); subst;
  try destruct (Term_eq_dec _ _); subst;
  try (rewrite e || rewrite <- e; clear e);
  try (rewrite e0 || rewrite <- e0; clear e0);
  try congruence;
  try rewrite <- Eqdep_dec.eq_rect_eq_dec; eauto; simpl; intuition;
  try rewrite <- Eqdep_dec.eq_rect_eq_dec; eauto; simpl; intuition;
  try (unfold eq_rect; destruct e0; intuition);
  try (unfold eq_rect; destruct e; intuition).
Qed.

Program Instance Subterm_Irreflexive : Irreflexive Subterm.
Next Obligation.
  repeat intro.
  pose proof (Subterm_inv _ _ H0).
  inversion H0; subst; simpl in *.
  - now apply (Meet_acc_l x t2).
  - now apply (Meet_acc_r t1 x).
  - now apply (Join_acc_l x t2).
  - now apply (Join_acc_r t1 x).
Qed.

Lemma Subterm_wf : well_founded Subterm.
Proof.
  constructor; intros.
  inversion H0; subst; simpl in *;
  induction y;
  induction t1 || induction t2;
  simpl in *;
  constructor; intros;
  inversion H1; subst; clear H1;
  try (apply IHy1; constructor);
  try (apply IHy2; constructor).
Defined.

Reserved Notation "〚 t 〛 env" (at level 9).

Fixpoint eval (t : Term) (env : nat -> A) : A :=
  match t with
  | Var n => env n
  | Meet t1 t2 => 〚t1〛env ⊓ 〚t2〛env
  | Join t1 t2 => 〚t1〛env ⊔ 〚t2〛env
  end where "〚 t 〛 env" := (eval t env).

Definition Leq   (s t : Term) : Prop := forall env, 〚s〛env ≤ 〚t〛env.
Arguments Leq _ _ /.

(* Note that Equiv can be computed from Leq. *)
Definition Equiv (s t : Term) : Prop := forall env, 〚s〛env = 〚t〛env.
Arguments Equiv _ _ /.

Reserved Infix "≲" (at level 30).

Definition R := symprod Term Term Subterm Subterm.
Arguments R /.

Open Scope lazy_bool_scope.

Ltac meets_and_joins leq :=
  repeat destruct (leq (_, _) _);
  simpl in *;
  subst;
  repeat match goal with
  | [ H : (_, _) = (_, _) |- _ ] => progress (inversion H; subst)
  | [ H : bool |- _ ] => destruct H
  end;
  try discriminate;
  simpl in *;
  repeat match goal with
  | [ |- _ ⊔ _ ≤ _ ] => apply join_is_lub; split; firstorder idtac
  | [ |- _ ≤ _ ⊔ _ ] => apply join_prime; firstorder idtac
  | [ |- _ ≤ _ ⊓ _ ] => apply meet_is_glb; split; firstorder idtac
  | [ |- _ ⊓ _ ≤ _ ] => apply meet_prime; firstorder idtac
  end.

Local Obligation Tactic :=
  program_simpl; try (constructor; constructor).

Set Transparent Obligations.

(* Whitman's decision procedure. *)
Program Fixpoint leq (p : Term * Term) {wf R p} :
  { b : bool | b = true -> Leq (fst p) (snd p) } :=
  match p with
  (* 1. If s = Var i and t = Var j, then s ≲ t holds iff i = j. *)
  | (Var i, Var j) => nat_eq_bool i j

  (* 2. If s = Join s1 s2, then s ≲ t holds iff s1 ≲ t and s2 ≲ t. *)
  | (Join s1 s2, t) =>
    exist _ (proj1_sig (leq (s1, t)) &&& proj1_sig (leq (s2, t))) _

  (* 3. If t = Meet t1 t2, then s ≲ t holds iff s ≲ t1 and s ≲ t2. *)
  | (s, Meet t1 t2) =>
    exist _ (proj1_sig (leq (s, t1)) &&& proj1_sig (leq (s, t2))) _

  (* 4. If s = Var i and t = Join t1 t2, then s ≲ t holds iff s ≲ t1 or s ≲ t2. *)
  | (Var i, Join t1 t2) =>
    exist _ (proj1_sig (leq (Var i, t1)) ||| proj1_sig (leq (Var i, t2))) _

  (* 5. If s = Meet s1 s2 and t = Var i, then s ≲ t holds iff s1 ≲ t or s2 ≲ t. *)
  | (Meet s1 s2, Var i) =>
    exist _ (proj1_sig (leq (s1, Var i)) ||| proj1_sig (leq (s2, Var i))) _

  (* 6. If s = Meet s1 s2 and t = Join t1 t2, then s ≲ t holds iff s1 ≲ t or
        s2 ≲ t or s ≲ t1 or s ≲ t2. *)
  | (Meet s1 s2, Join t1 t2) =>
    exist _ (proj1_sig (leq (s1, Join t1 t2)) |||
             proj1_sig (leq (s2, Join t1 t2)) |||
             proj1_sig (leq (Meet s1 s2, t1)) |||
             proj1_sig (leq (Meet s1 s2, t2))) _
  end.
Next Obligation.
  destruct (nat_eq_bool i j); simpl in *; subst.
  rewrite y; reflexivity.
Defined.
Next Obligation. meets_and_joins leq. Defined.
Next Obligation. meets_and_joins leq. Defined.
Next Obligation. meets_and_joins leq. Defined.
Next Obligation. meets_and_joins leq. Defined.
Next Obligation.
  repeat destruct (leq (_, _)); simpl in *.
  destruct x.  apply meet_prime; left;  apply o;  reflexivity.
  destruct x0. apply meet_prime; right; apply o0; reflexivity.
  destruct x1. apply join_prime; left;  apply o1; reflexivity.
  destruct x2. apply join_prime; right; apply o2; reflexivity.
  discriminate.
Defined.
Next Obligation.
  apply wf_symprod;
  apply Subterm_wf.
Defined.

Notation "s ≲ t" := (leq (s, t)) (at level 30).

Definition leq_correct {t u : Term} (Heq : ` (t ≲ u) = true) :
  forall env, 〚t〛env ≤ 〚u〛env := proj2_sig (t ≲ u) Heq.

Inductive Logic : Set :=
  | LLe   : Term  -> Term  -> Logic
  | LAnd  : Logic -> Logic -> Logic
  | LOr   : Logic -> Logic -> Logic
  | LImpl : Logic -> Logic -> Logic.

Fixpoint logicDenote (t : Logic) (env : nat -> A) : Prop :=
  match t with
  | LLe   x y => 〚x〛env ≤ 〚y〛env
  | LAnd  x y => logicDenote x env /\ logicDenote y env
  | LOr   x y => logicDenote x env \/ logicDenote y env
  | LImpl x y => logicDenote x env -> logicDenote y env
  end.

Inductive AndOr {A B : Type} : Type :=
  | AO_Terms : A -> B    -> AndOr
  | AO_And   : AndOr -> AndOr -> AndOr
  | AO_Or    : AndOr -> AndOr -> AndOr.

Program Fixpoint normLe (p : Term * Term) {wf (R) p} : @AndOr Term Term :=
  match p with
  | (Meet a b, c) => AO_Or  (normLe (a, c)) (normLe (b, c))
  | (Join a b, c) => AO_And (normLe (a, c)) (normLe (b, c))
  | (c, Meet a b) => AO_And (normLe (c, a)) (normLe (c, b))
  | (c, Join a b) => AO_Or  (normLe (c, a)) (normLe (c, b))
  | (a, b) => AO_Terms a b
  end.
Next Obligation.
  intuition; match goal with [ H : _ = _ |- _ ] => inversion H end.
Defined.
Next Obligation.
  intuition; match goal with [ H : _ = _ |- _ ] => inversion H end.
Defined.
Next Obligation.
  intuition; match goal with [ H : _ = _ |- _ ] => inversion H end.
Defined.
Next Obligation.
  apply measure_wf.
  apply wf_symprod;
  apply Subterm_wf.
Defined.

Fixpoint denoteAndOr (t : @AndOr Term Term) : Logic :=
  match t with
  | AO_Terms x y => LLe x y
  | AO_And   x y => LAnd (denoteAndOr x) (denoteAndOr y)
  | AO_Or    x y => LOr (denoteAndOr x) (denoteAndOr y)
  end.

Program Fixpoint logicNorm (t : Logic) : Logic :=
  match t with
  | LLe a b => denoteAndOr (normLe (a, b))

  | LAnd  x y => LAnd (logicNorm x) (logicNorm y)
  | LOr   x y => LOr  (logicNorm x) (logicNorm y)

  | LImpl x y =>
    match logicNorm y with
    | LImpl y z => LImpl (LAnd (logicNorm x) y) z
    | y => LImpl (logicNorm x) y
    end
  end.

Theorem logicNorm_sound : forall x env,
  logicDenote x env <->
  logicDenote (logicNorm x) env.
Proof.
Admitted.

(*
Definition markVars (t : Term) (env : nat -> A) (f : nat -> bool) :
  nat -> bool :=
  let fix go t f :=
      match t with
      | Var x    => fun n => (x =? n) ||| f n
      | Meet x y => go x (go y f) (* jww (2017-06-18): correct? *)
      | Join x y => go x (go y f)
      end in
  go t (fun _ => false).

Fixpoint markLogic (t : Logic) (env : nat -> A) : Prop :=
  match t with
  | LLe   x y => 〚x〛env ≤ 〚y〛env
  | LAnd  x y => logicDenote x env /\ logicDenote y env
  | LOr   x y => logicDenote x env \/ logicDenote y env
  | LImpl x y => logicDenote x env -> logicDenote y env
  end.

Fixpoint logicCheck (t : Logic) (env : nat -> A) : Prop :=
  match t with
  | LLe   x y => 〚x〛env ≤ 〚y〛env
  | LAnd  x y => logicDenote x env /\ logicDenote y env
  | LOr   x y => logicDenote x env \/ logicDenote y env
  | LImpl x y => logicDenote x env -> logicDenote y env
  end.

Program Fixpoint determine_truth (t : Logic) {struct t} :
  { b : bool | b = true -> forall env, logicDenote t env } :=
  match t with
  | LLe   x y => leq (x, y)
  | LAnd  x y => exist _ (` (determine_truth x) &&& ` (determine_truth y)) _
  | LOr   x y => exist _ (` (determine_truth x) ||| ` (determine_truth y)) _
  | LImpl x y => exist _ (if ` (determine_truth x)
                          then ` (determine_truth y)
                          else false) _
  end.
Next Obligation. destruct x0; intuition. Defined.
Next Obligation. destruct x0; intuition. Defined.
Next Obligation. destruct x0; intuition. Defined.
*)

End Lattice.

Notation "〚 t 〛 env" := (@eval _ _ t env) (at level 9).
Notation "s ≲ t" := (@leq _ _ _ _ (s, t)) (at level 30).

Import ListNotations.

Ltac inList x xs :=
  match xs with
  | tt => false
  | (x, _) => true
  | (_, ?xs') => inList x xs'
  end.

Ltac addToList x xs :=
  let b := inList x xs in
  match b with
  | true => xs
  | false => constr:((x, xs))
  end.

Ltac allVars xs e :=
  match e with
  | ?e1 ⊓ ?e2 =>
    let xs := allVars xs e1 in
    allVars xs e2
  | ?e1 ⊔ ?e2 =>
    let xs := allVars xs e1 in
    allVars xs e2
  | _ => addToList e xs
  end.

Ltac lookup x xs :=
  match xs with
  | (x, _) => O
  | (_, ?xs') =>
    let n := lookup x xs' in
    constr:(S n)
  end.

Ltac reifyTerm env t :=
  match t with
  | ?X1 ⊓ ?X2 =>
    let r1 := reifyTerm env X1 in
    let r2 := reifyTerm env X2 in
    constr:(Meet r1 r2)
  | ?X1 ⊔ ?X2 =>
    let r1 := reifyTerm env X1 in
    let r2 := reifyTerm env X2 in
    constr:(Join r1 r2)
  | ?X =>
    let n := lookup X env in
    constr:(Var n)
  end.

Ltac functionalize xs :=
  let rec loop n xs' :=
    match xs' with
    | (?x, tt) => constr:(fun _ : nat => x)
    | (?x, ?xs'') =>
      let f := loop (S n) xs'' in
      constr:(fun m : nat => if m =? n then x else f m)
    end in
  loop 0 xs.

Ltac reify :=
  match goal with
  | [ |- ?S ≤ ?T ] =>
    let xs  := allVars tt S in
    let xs' := allVars xs T in
    let r1  := reifyTerm xs' S in
    let r2  := reifyTerm xs' T in
    let env := functionalize xs' in
    (* pose xs'; *)
    (* pose env; *)
    (* pose r1; *)
    (* pose r2; *)
    change (〚r1〛env ≤ 〚r2〛env)
  end.

Ltac lattice := reify; apply leq_correct; vm_compute; auto.

Example sample_1 `{LOSet A} : forall a b : A,
  a ≤ a ⊔ b.
Proof. intros; lattice. Qed.

Lemma running_example `{LOSet A} : forall a b : A,
  a ⊓ b ≤ a ⊔ b.
Proof.
  intros a b.
  rewrite meet_consistent.
  rewrite meet_associative.
  rewrite join_commutative.
  rewrite meet_absorptive.
  reflexivity.
Qed.

Lemma running_example' `{LOSet A} : forall a b : A,
  a ⊓ b ≤ a ⊔ b.
Proof. intros; lattice. Qed.

Lemma median_inequality `{LOSet A} : forall x y z : A,
  (x ⊓ y) ⊔ (y ⊓ z) ⊔ (z ⊓ x) ≤ (x ⊔ y) ⊓ (y ⊔ z) ⊓ (z ⊔ x).
Proof. intros; lattice. Qed.

Ltac allVarsLogic xs e :=
  match e with
  | ?X1 ≤ ?X2 =>
    let xs := allVars xs X1 in
    allVars xs X2
  | ?X1 /\ ?X2 =>
    let xs := allVarsLogic xs X1 in
    allVarsLogic xs X2
  | ?X1 \/ ?X2 =>
    let xs := allVarsLogic xs X1 in
    allVarsLogic xs X2
  | ~ ?X1 =>
    allVarsLogic xs X1
  | ?X1 -> ?X2 =>
    let xs := allVarsLogic xs X1 in
    allVarsLogic xs X2
  end.

Ltac reifyLogic env t :=
  match t with
  | ?X1 ≤ ?X2 =>
    let r1 := reifyTerm env X1 in
    let r2 := reifyTerm env X2 in
    constr:(LLe r1 r2)
  | ?X1 /\ ?X2 =>
    let r1 := reifyLogic env X1 in
    let r2 := reifyLogic env X2 in
    constr:(LAnd r1 r2)
  | ?X1 \/ ?X2 =>
    let r1 := reifyLogic env X1 in
    let r2 := reifyLogic env X2 in
    constr:(LOr r1 r2)
  | ?X1 -> ?X2 =>
    let r1 := reifyLogic env X1 in
    let r2 := reifyLogic env X2 in
    constr:(LImpl r1 r2)
  end.

Ltac lattice' :=
  match goal with
  | [ |- ?P ] =>
    let xs := allVarsLogic tt P in
    let r1 := reifyLogic xs P in
    let env := functionalize xs in
    (* pose xs; *)
    (* pose r1; *)
    (* pose env; *)
    change (logicDenote r1 env);
    apply logicNorm_sound;
    let p := fresh "p" in
    let Heqp := fresh "Heqp" in
    remember (logicNorm _) as p eqn:Heqp;
    vm_compute in Heqp;
    rewrite Heqp; clear Heqp p
    (* vm_compute; *)
    (* intuition idtac *)
  end.

Lemma example_3 `{LOSet A} : forall a b c : A,
  b ≤ a ⊔ b ->
  a ⊓ c ≤ a ->
  a ⊓ b ≤ c ->
  a ⊓ c ≤ b.
Proof.
  intros a b c.
  lattice'.
  simpl.
  intuition.
Admitted.

Lemma median_inequality' `{LOSet A} : forall x y z : A,
  (x ⊓ y) ⊔ (y ⊓ z) ⊔ (z ⊓ x) ≤ (x ⊔ y) ⊓ (y ⊔ z) ⊓ (z ⊔ x).
Proof.
  intros.
  lattice.
Qed.


Require Export D1_DistanceProp.

Section AXIS.

Require Export Arith.

Variables A B : Point.

Hypothesis Hab : A <> B.

Definition StrongGraduation : forall n : nat,
	{N : Point | HalfLine A N B /\ Distance A N = DistTimesn n A B /\ (n > 0 -> A <> N)}.
Proof.
	intro n.
	 case n.
	  exists A; repeat split.
	   canonize.
	     elim (NotClockwiseAAB A x H).
	   intro H; inversion H.
	  induction n0.
	   exists B; repeat split.
	    canonize.
	    simpl in |- *.
	      rewrite NullDist; rewrite LS0NeutralRight; trivial.
	    intuition.
	   destruct IHn0 as (N, (H1, (H2, H3))).
	     assert (H : A <> N).
	    intuition.
	    destruct (ExistsBetweenEquidistant N A A B) as (P, (H4, H5)).
	     auto.
	     trivial.
	     exists P; repeat split.
	      assert (H6 := BetweenSymHalfLine _ _ _ H4).
	        assert (H7 := HalfLineSym A N P H H6).
	        canonize.
	      change
	        (DistTimesn (S (S n0)) A B) with (LSplus (Distance A B)
	                                            (DistTimesn (S n0) A B)) in |- *.
	        rewrite <- H2; rewrite <- H5; rewrite LSplusComm.
	       rewrite ChaslesBetween.
	        trivial.
	        apply BetweenSym; trivial.
	       apply (EquiDistantDistinct A B); trivial.
	         autoDistance.
	       trivial.
	      intros _; exact (BetweenDistinctCA _ _ _ H4).
Defined.

Definition Graduation : forall n : nat,
	{N : Point | HalfLine A N B /\ Distance A N = DistTimesn n A B}.
Proof.
	intro n; destruct (StrongGraduation n) as (P, H0); exists P; intuition.
Defined.

End AXIS.


Require Import SecOrder.
Require Import P_occurs_in_alpha.
Require Import ST_setup.
Require Import Correctness_ST.
Require Import Arith.EqNat.
Require Import List_machinery_impl My_List_Map my_arith__my_leb_nat.
Require Import Unary_Predless nList_egs Rep_Pred_FOv Indicies Unary_Predless_l List.
(*
  Uniform_Mod_Lemmas8a
*)

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

Definition num_occ (alpha : SecOrder) (Q : predicate) : nat :=
  length (indicies alpha Q).

Lemma num_occ_conjSO2 : forall (alpha1 alpha2 : SecOrder) (Q : predicate),
  num_occ (conjSO alpha1 alpha2) Q =  (length (indicies alpha1 Q)) +
                                       (length (indicies alpha2 Q)).
Proof.
  intros.
  unfold num_occ.
  rewrite indicies_conjSO.
  rewrite app_length.
  unfold indicies.
  do 3 rewrite list_map_length.
  reflexivity.
Qed.

Lemma num_occ_disjSO2 : forall (alpha1 alpha2 : SecOrder) (Q : predicate),
  num_occ (disjSO alpha1 alpha2) Q =  (length (indicies alpha1 Q)) +
                                       (length (indicies alpha2 Q)).
Proof.
  intros.
  unfold num_occ.
  rewrite indicies_disjSO.
  rewrite app_length.
  unfold indicies.
  do 3 rewrite list_map_length.
  reflexivity.
Qed.

Lemma num_occ_predSO : forall (P Q : predicate) (x : FOvariable),
  num_occ (predSO P x) Q = match P, Q with
                           | Pred Pn, Pred Qm =>
                          if beq_nat Pn Qm then 1 else 0
                          end.
Proof.
  intros.
  destruct P as [Pn]; destruct Q as [Qm]; destruct x as [xn].
  unfold num_occ.
  unfold indicies.
  simpl.
  rewrite list_map_length.
  case (beq_nat Pn Qm); simpl; reflexivity.
Qed.

Lemma num_occ_allSO : forall (alpha : SecOrder) (P Q : predicate),
  num_occ (allSO P alpha) Q = match P, Q with
                           | Pred Pn, Pred Qm =>
                          if beq_nat Pn Qm then 1 + num_occ alpha Q else num_occ alpha Q
                          end.
Proof.
  intros.
  destruct P as [Pn]; destruct Q as [Qm].
  unfold num_occ.
  unfold indicies.
  simpl.
  do 2 rewrite list_map_length.
  case (beq_nat Pn Qm); simpl; reflexivity.
Qed.

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

Fixpoint is_in_l (l : list nat) (i : nat) : bool :=
  match l with
  | nil => false
  | cons n l' => if beq_nat i n then true else is_in_l l' i
  end.

Lemma is_in_l_app : forall (l1 l2 : list nat) (i : nat),
  is_in_l (l1 ++ l2) i = if is_in_l l1 i
                          then true
                          else is_in_l l2 i.
Proof.
  intros.
  induction l1.
    simpl; reflexivity.

    simpl.
    rewrite IHl1.
    case (beq_nat i a);
      reflexivity.
Qed.

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

Fixpoint num_occ_diff_l (l : list nat) (i : nat) : nat :=
  if is_in_l l i then 0 else
  match l with
  | nil => 0
  | cons n l' => if Nat.leb n i
                    then 1 + num_occ_diff_l l' i
                    else num_occ_diff_l l' i
  end.

Lemma num_occ_diff_l_defn : forall (l : list nat) (i : nat),
  num_occ_diff_l l i =
  if is_in_l l i then 0 else
  match l with
  | nil => 0
  | cons n l' => if Nat.leb n i
                    then 1 + num_occ_diff_l l' i
                    else num_occ_diff_l l' i
  end.
Proof.
  intros.
  unfold num_occ_diff_l.
  induction l; simpl; reflexivity.
Qed.

Lemma num_occ_diff_l_cons : forall (l : list nat) (a i : nat),
  num_occ_diff_l (cons a l) i =
    if is_in_l (cons a l) i
       then 0
       else if Nat.leb a i
               then 1 + num_occ_diff_l l i
               else num_occ_diff_l l i.
Proof.
  intros; simpl.
  reflexivity.
Qed.

Lemma num_occ_diff_l_app : forall (l1 l2 : list nat) (i : nat),
  is_in_l l1 i = false ->
    is_in_l l2 i = false ->
      num_occ_diff_l (app l1 l2) i =
        (num_occ_diff_l l1 i) + (num_occ_diff_l l2 i).
Proof.
  induction l1.
    intros.
    simpl; reflexivity.

    intros l2 i H1 H2.
    rewrite num_occ_diff_l_cons.
    rewrite H1.
    simpl in *.
    case_eq (beq_nat i a); intros Hbeq; rewrite Hbeq in *.
      discriminate.

      rewrite is_in_l_app.
      rewrite IHl1.
      rewrite H1.
      rewrite H2.
      case (Nat.leb a i).
        simpl; reflexivity.

        reflexivity.

      assumption.

      assumption.
Qed.

Definition num_occ_diff (alpha : SecOrder) (Q : predicate) (i : nat)
                                              : nat :=
  num_occ_diff_l (indicies alpha Q) i.

Lemma num_occ_diff_relatSO : forall ( x y : FOvariable)
                                   (Q : predicate) (i : nat),
  num_occ_diff (relatSO x y) Q i = 0.
Proof.
  intros x y Q i.
  unfold num_occ_diff.
  unfold indicies.
  destruct x; destruct y.
  simpl.
  reflexivity.
Qed.

Lemma num_occ_diff_eqFO : forall ( x y : FOvariable)
                                   (Q : predicate) (i : nat),
  num_occ_diff (eqFO x y) Q i = 0.
Proof.
  intros x y Q i.
  unfold num_occ_diff.
  unfold indicies.
  destruct x; destruct y.
  simpl.
  reflexivity.
Qed.

Lemma num_occ_diff_allFO : forall (alpha : SecOrder) (x : FOvariable)
                                  (Q : predicate) (i : nat),
  num_occ_diff (allFO x alpha) Q i =
    num_occ_diff alpha Q i.
Proof.
  intros.
  unfold num_occ_diff.
  unfold num_occ_diff_l.
  reflexivity.
Qed.

Lemma num_occ_diff_exFO : forall (alpha : SecOrder) (x : FOvariable)
                                  (Q : predicate) (i : nat),
  num_occ_diff (exFO x alpha) Q i =
    num_occ_diff alpha Q i.
Proof.
  intros.
  unfold num_occ_diff.
  unfold num_occ_diff_l.
  unfold indicies.
  simpl.
  destruct x.
  reflexivity.
Qed.

Lemma num_occ_diff_negSO : forall (alpha : SecOrder)
                                  (Q : predicate) (i : nat),
  num_occ_diff (negSO alpha) Q i =
    num_occ_diff alpha Q i.
Proof.
  intros.
  unfold num_occ_diff.
  unfold num_occ_diff_l.
  unfold indicies.
  simpl.
  reflexivity.
Qed.

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

Lemma num_occ_diff_l_nil : forall (l : list nat),
  (num_occ_diff_l l 0) = 0.
Proof.
  induction l.
    simpl; reflexivity.

    destruct a.
      reflexivity.

      simpl.
      rewrite IHl.
      case (is_in_l l 0); reflexivity.
Qed.

Lemma num_occ_diff_nil : forall (alpha : SecOrder) (P : predicate),
  (num_occ_diff alpha P 0) = 0.
Proof.
  intros.
  unfold num_occ_diff.
  apply num_occ_diff_l_nil.
Qed.

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

Lemma num_occ_relatSO : forall (x y : FOvariable) (Q : predicate),
   num_occ (relatSO x y) Q = 0.
Proof.
  intros.
  destruct x; destruct y; destruct Q.
  unfold num_occ.
  unfold indicies.
  simpl.
  reflexivity.
Qed.

Lemma num_occ_eqFO : forall (x y : FOvariable) (Q : predicate),
   num_occ (eqFO x y) Q = 0.
Proof.
  intros.
  destruct x; destruct y; destruct Q.
  unfold num_occ.
  unfold indicies.
  simpl.
  reflexivity.
Qed.

Lemma num_occ_negSO : forall (alpha : SecOrder) (P : predicate),
  num_occ (negSO alpha) P = num_occ alpha P.
Proof.
   intros.
  unfold num_occ.
  unfold indicies.
  simpl.
  reflexivity.
Qed.

Lemma num_occ_allFO : forall (alpha : SecOrder) (x : FOvariable)
                             (P : predicate),
  num_occ (allFO x alpha) P = num_occ alpha P.
Proof.
   intros.
  unfold num_occ.
  unfold indicies.
  simpl.
  reflexivity.
Qed.

Lemma num_occ_exFO : forall (alpha : SecOrder) (x : FOvariable)
                             (P : predicate),
  num_occ (exFO x alpha) P = num_occ alpha P.
Proof.
   intros.
  unfold num_occ.
  unfold indicies.
  simpl.
  destruct x.
  reflexivity.
Qed.

Lemma num_occ_conjSO : forall (alpha1 alpha2 : SecOrder)
                             (P : predicate),
  num_occ (conjSO alpha1 alpha2) P = num_occ alpha1 P + num_occ alpha2 P.
Proof.
   intros.
  unfold num_occ.
  unfold indicies.
  simpl.
  rewrite app_length.
  rewrite list_map_length.
  rewrite list_map_length.
  rewrite list_map_length.
  rewrite indicies_l_rev_app.
  rewrite app_length.
  rewrite list_map_length.
  reflexivity.
Qed.

Lemma num_occ_disjSO : forall (alpha1 alpha2 : SecOrder)
                             (P : predicate),
  num_occ (disjSO alpha1 alpha2) P = num_occ alpha1 P + num_occ alpha2 P.
Proof.
   intros.
  unfold num_occ.
  unfold indicies.
  simpl.
  rewrite app_length.
  rewrite list_map_length.
  rewrite list_map_length.
  rewrite list_map_length.
  rewrite indicies_l_rev_app.
  rewrite app_length.
  rewrite list_map_length.
  reflexivity.
Qed.

Lemma num_occ_implSO : forall (alpha1 alpha2 : SecOrder)
                             (P : predicate),
  num_occ (implSO alpha1 alpha2) P = num_occ alpha1 P + num_occ alpha2 P.
Proof.
   intros.
  unfold num_occ.
  unfold indicies.
  simpl.
  rewrite app_length.
  rewrite list_map_length.
  rewrite list_map_length.
  rewrite list_map_length.
  rewrite indicies_l_rev_app.
  rewrite app_length.
  rewrite list_map_length.
  reflexivity.
Qed.

Lemma num_occ_preds_in : forall (alpha : SecOrder) (P : predicate),
  Nat.leb (num_occ alpha P) (length (preds_in alpha)) = true.
Proof.
  intros.
  induction alpha;
    try destruct p as [Qm]; try destruct f as [xn];
    try destruct P as [Pn]; try destruct f0 as [xm];
    try (unfold num_occ in *; unfold indicies in *; simpl);
    try reflexivity; try  rewrite list_map_length in *;
    try rewrite list_map_length in IHalpha;
    try rewrite list_map_length in IHalpha1;
    try rewrite list_map_length in IHalpha2;
    try (case (beq_nat Qm Pn); simpl; reflexivity);
    try assumption;
    try (rewrite indicies_l_rev_app;
    do 2 rewrite app_length;
    rewrite list_map_length;
    apply leb_plus_gen; assumption);
    (case_eq (beq_nat Qm Pn); intros Hbeq; [simpl | apply leb_suc_r];
      assumption).
Qed.

Lemma  num_occ_ind_l_rev : forall (alpha : SecOrder) (P : predicate),
  num_occ alpha P = length (indicies_l_rev (preds_in alpha) P).
Proof.
  intros alpha P.
  unfold num_occ.
  unfold indicies.
  rewrite list_map_length.
  reflexivity.
Qed.

Lemma num_occ_rep_pred : forall alpha cond P x,
is_unary_predless cond = true ->
num_occ (replace_pred alpha P x cond) P = 0.
Proof.
  intros alpha cond P x Hcond.
  unfold num_occ.
  rewrite length_ind.
  induction alpha;
    try destruct p as [Pn]; try destruct P as [Qm];
    try destruct f; try destruct f0;
    simpl in *; try reflexivity;
    try assumption;
    try (rewrite indicies_l_rev_app; rewrite app_length;
    rewrite list_map_length;
    rewrite IHalpha1; rewrite IHalpha2;
    reflexivity).
    case_eq (beq_nat Qm Pn); intros Hbeq.
      rewrite preds_in_rep_FOv.
      rewrite un_predless_preds_in; try assumption.
      reflexivity.

      simpl.
      rewrite beq_nat_comm.
      rewrite Hbeq.
      reflexivity.

    case_eq (beq_nat Qm Pn); intros Hbeq.
      assumption.

      simpl.
      rewrite beq_nat_comm.
      rewrite Hbeq.
      assumption.

    case_eq (beq_nat Qm Pn); intros Hbeq.
      assumption.

      simpl.
      rewrite beq_nat_comm.
      rewrite Hbeq.
      assumption.
Qed.

Lemma num_occ_rep_pred_0 : forall (alpha cond : SecOrder) (P Q : predicate)
                                  (x : FOvariable),
is_unary_predless cond = true ->
num_occ alpha P = 0 ->
num_occ (replace_pred alpha Q x cond) P = 0.
Proof.
  induction alpha; intros cond P Q x Hcond Hnum;
  unfold num_occ in *; rewrite length_ind in *;
  simpl in *;
    try destruct Q as [Qm]; try destruct p as [Pn];
    try destruct f as [xn]; try destruct f0; try destruct P as [Rn];
    try destruct x as [ym];
    try reflexivity;
    try (simpl in *;
    specialize (IHalpha cond (Pred Rn) (Pred Qm) (Var ym) Hcond);
    do 2 rewrite length_ind in *;
    apply IHalpha; assumption);

    try (simpl;
    rewrite indicies_l_rev_app in *;
    rewrite app_length in *;
    rewrite list_map_length;
    rewrite list_map_length in Hnum;
    specialize (IHalpha1 cond (Pred Rn) (Pred Qm) (Var ym) Hcond);
    specialize (IHalpha2 cond (Pred Rn) (Pred Qm) (Var ym) Hcond);
    do 2 rewrite length_ind in *;
    rewrite IHalpha1; [rewrite IHalpha2 | ];
      [reflexivity |
      rewrite arith_plus_comm in Hnum;
      apply eq_nat_zero in Hnum; assumption |
      apply eq_nat_zero in Hnum; assumption]);

   try (    simpl in *;
    specialize (IHalpha cond (Pred Rn) (Pred Qm) (Var ym) Hcond);
    do 2 rewrite length_ind in IHalpha;
    case_eq (beq_nat Pn Rn); intros Hbeq2; rewrite Hbeq2 in *;
      [simpl in *; discriminate |];

      case (beq_nat Qm Pn);
        [|simpl; rewrite Hbeq2];
        apply IHalpha; assumption).

    simpl in *;
    case_eq (beq_nat Qm Pn); intros Hbeq.
      apply rep_FOv_is_unary_predless with (x := (Var ym)) (y := (Var xn)) in Hcond.
      apply un_predless_preds_in in Hcond.
      rewrite Hcond.
      reflexivity.

      simpl.
      case_eq (beq_nat Pn Rn); intros Hbeq2; rewrite Hbeq2 in *.
        simpl in *; discriminate.

        reflexivity.
Qed.

Lemma num_occ_rep_pred__l_0 : forall (alpha : SecOrder) l l1 l2 P Q x cond,
is_unary_predless_l l2 = true ->
is_unary_predless cond = true ->
num_occ (replace_pred_l alpha l l1 l2) P = 0 ->
num_occ (replace_pred (replace_pred_l alpha l l1 l2) Q x cond) P = 0.
Proof.
  intros alpha l l1 l2 P Q x cond Hun1 Hun2 Hnum.
  apply num_occ_rep_pred_0; assumption.
Qed.

Lemma num_occ_rep_pred2 : forall (alpha cond : SecOrder)
                                 (P Q : predicate) (x : FOvariable),
is_unary_predless cond = true ->
match P, Q with
| Pred Pn, Pred Qm =>
beq_nat Pn Qm = false
end ->
num_occ (replace_pred alpha P x cond) Q =
num_occ alpha Q.
Proof.
  intros alpha cond P Q x Hcond Hbeq.
  destruct P as [Pn]; destruct Q as [Qm].
  unfold num_occ.
  do 2 rewrite length_ind.
  induction alpha;
    try destruct p as [Rn]; try destruct f;
    try destruct f0;
    try reflexivity;
    try (    simpl; assumption);
    try (simpl; do 2 rewrite indicies_l_rev_app;
    do 2 rewrite app_length;
    do 2 rewrite list_map_length;
    rewrite IHalpha1;
    rewrite IHalpha2;
    reflexivity);

    simpl;
    case_eq (beq_nat Rn Qm); intros Hbeq2;
      case_eq (beq_nat Pn Rn); intros Hbeq3.
        rewrite <- (beq_nat_true _ _ Hbeq2) in *;
        rewrite <- (beq_nat_true _ _ Hbeq3) in Hbeq;
        rewrite <- beq_nat_refl in Hbeq;
        discriminate.

        simpl; rewrite Hbeq2; reflexivity.

        simpl.
        apply rep_FOv_is_unary_predless with (x := x)
              (y := (Var n)) in Hcond.
        apply un_predless_preds_in in Hcond.
        rewrite Hcond.
        reflexivity.

        simpl.
        rewrite Hbeq2.
        reflexivity.
(* allSO *)
        rewrite <- (beq_nat_true _ _ Hbeq2) in *;
        rewrite <- (beq_nat_true _ _ Hbeq3) in Hbeq;
        rewrite <- beq_nat_refl in Hbeq;
        discriminate.

        simpl; rewrite Hbeq2; simpl;  rewrite IHalpha ; reflexivity.

        assumption.

        simpl; rewrite Hbeq2; assumption.
(* exSO *)
        rewrite <- (beq_nat_true _ _ Hbeq2) in *;
        rewrite <- (beq_nat_true _ _ Hbeq3) in Hbeq;
        rewrite <- beq_nat_refl in Hbeq;
        discriminate.

        simpl; rewrite Hbeq2; simpl;  rewrite IHalpha ; reflexivity.

        assumption.

        simpl; rewrite Hbeq2; assumption.
Qed.


(*|
######################################
Proving Termination of Function in Coq
######################################

:Link: https://stackoverflow.com/q/46928911
|*)

(*|
Question
********

I am having trouble proving termination of the following function:

.. coq:: none
|*)

Require Import Arith Ascii.

Inductive regex : Set :=
| Empty   : regex
| Epsilon : regex
| Symbol  : ascii -> regex
| Union   : regex -> regex -> regex
| Concat  : regex -> regex -> regex
| Star    : regex -> regex.

Lemma eq_regex_dec : forall u v : regex, {u = v} + {u <> v}.
Proof. decide equality. apply ascii_dec. Defined.

Fixpoint le_regex u v : bool :=
  match u, v with
  | Empty       , _            => true
  | _           , Empty        => false
  | Epsilon     , _            => true
  | _           , Epsilon      => false
  | Symbol a    , Symbol b     => nat_of_ascii a <=? nat_of_ascii b
  | Symbol _    , _            => true
  | _           , Symbol _     => false
  | Star u      , Star v       => le_regex u v
  | Star u      , _            => true
  | _           , Star v       => false
  | Union u1 u2 , Union v1 v2  => if eq_regex_dec u1 v1
                                  then le_regex u2 v2
                                  else le_regex u1 v1
  | Union _ _   , _            => true
  | _           , Union _ _    => false
  | Concat u1 u2, Concat v1 v2 => if eq_regex_dec u1 v1
                                  then le_regex u2 v2
                                  else le_regex u1 v1
  end.

(*||*)

Fail Fixpoint norm_union u v : regex :=
  match u, v with
  | Empty    , v         => v
  | u        , Empty     => u
  | Union u v, w         => norm_union u (norm_union v w)
  | u        , Union v w => if eq_regex_dec u v
                            then Union v w
                            else if le_regex u v
                                 then Union u (Union v w)
                                 else Union v (norm_union u w)
  | u        , v         => if eq_regex_dec u v
                            then u
                            else if le_regex u v
                                 then Union u v
                                 else Union v u
  end. (* .fails *)

(*|
where ``regex`` is the type of regular expressions and ``le_regex``
implements a total ordering on regular expressions. The source is page
five of `this <http://www21.in.tum.de/~krauss/papers/rexp.pdf>`__
document. The function occurs as part of a normalization function for
regular expressions (formalized in Isabelle/HOL). The ``le_regex``
function is adapted from the same paper. I am using ``ascii`` to avoid
parameterizing ``regex`` by a decidable total ordering (and want to
extract the program).
|*)

Reset Initial. (* .none *)
Require Import Arith Ascii. (* .none *)
Inductive regex : Set :=
| Empty   : regex
| Epsilon : regex
| Symbol  : ascii -> regex
| Union   : regex -> regex -> regex
| Concat  : regex -> regex -> regex
| Star    : regex -> regex.

Lemma eq_regex_dec : forall u v : regex, {u = v} + {u <> v}.
Proof. decide equality. apply ascii_dec. Defined.

Fixpoint le_regex u v : bool :=
  match u, v with
  | Empty       , _            => true
  | _           , Empty        => false
  | Epsilon     , _            => true
  | _           , Epsilon      => false
  | Symbol a    , Symbol b     => nat_of_ascii a <=? nat_of_ascii b
  | Symbol _    , _            => true
  | _           , Symbol _     => false
  | Star u      , Star v       => le_regex u v
  | Star u      , _            => true
  | _           , Star v       => false
  | Union u1 u2 , Union v1 v2  => if eq_regex_dec u1 v1
                                  then le_regex u2 v2
                                  else le_regex u1 v1
  | Union _ _   , _            => true
  | _           , Union _ _    => false
  | Concat u1 u2, Concat v1 v2 => if eq_regex_dec u1 v1
                                  then le_regex u2 v2
                                  else le_regex u1 v1
  end.

(*|
I think the correct approach is to define a decreasing measure and use
``Program Fixpoint`` to prove termination. However, I'm having trouble
coming up with the correct measure (attempts based on the number of
operators have been unsuccessful). I have tried factoring the work
into separate functions, but ran into similar problems. Any help would
be appreciated, or hints pointing in the right direction.
|*)

(*|
Answer (Yves)
*************

Your code is more complex than what is usually handled with a measure
function, because you have a nested recursive call in the following
line:

.. code-block:: coq

    Union u v, w         => norm_union u (norm_union v w)  (* line 5 *)

I suggest that you should not return a value in type ``regex``, but in
type ``{r : regex | size r < combined_size u v}`` for suitable notions
of ``size`` and ``combined_size``.

After several hours of study on your problem, it also turns out that
your recursion relies on lexical ordering of the arguments.
``norm_union v w`` may well return ``Union v w``, so you need that the
argument pair ``(u, Union v w)`` is smaller than ``(Union u v, w)``.
So if you really want to use a measure, you need the weight of the
left-hand side to be larger than the weight of the right-hand side,
and you need the measure of a component of a ``Union`` to be less than
the measure of the whole.

Because of the lexical ordering nature, I chose to not use a measure
but a well-founded order. Also, I don't know ``Program Fixpoint`` well
enough, so I developed a solution to your problem using another tool.
The solution I came up with can be seen `here on github
<https://github.com/ybertot/norm_union_example>`__. At least this
shows all the decrease conditions that need to be proved.
|*)

(*|
Answer (Yves)
*************

After an extra day of work, I now have a more complete answer to this
question. It is still visible at `this link
<https://github.com/ybertot/norm_union_example>`__. This solution
deserves a few comments.

First, I am using a function constructor called ``Fix`` (the long name
is ``Coq.Init.Wf.Fix``). This is a higher order function that can be
used to define functions by well-founded recursion. I need a well
founded order for this, this order is called ``order``. Well founded
orders were studied intensively in the early 2000s and they are still
at the foundation of the ``Program Fixpoint`` command.

Second, the code you wrote performs case analyses on two values of
type ``regex`` simultaneously, so this leads to 36 cases (a bit less,
because there is no case analysis on the second argument when the
first one is ``Empty``). You don't see the 36 cases in your code,
because several constructors are covered by the same rule where the
pattern is just a variable. To avoid this multiplication of cases, I
devised a specific inductive type for the case analyses. I called this
specific type ``arT``. Then I define a function ``ar`` that maps any
element of type ``regex`` to the corresponding element of ``arT``. The
type ``arT`` has three constructors instead of six, so pattern
matching expressions will contain much less code and proofs will be
less verbose.

Then I proceeded to define ``norm_union`` using ``Fix``. As usual in
Coq (and in most theorem provers, including Isabelle), the language of
recursive definitions ensures that recursive functions always
terminate. In this case, this is done by imposing that recursive calls
only happen on arguments that are *smaller* than the function's input.
In this case, this is done by describing the body of the recursive
function by a function that takes as first argument the initial input
and as second argument the function that will be used to represent the
recursive calls. The name of this function is ``norm_union_F`` and its
type is as follows:

.. code-block:: coq

    forall p : regex * regex,
      forall g : (forall p', order p' p ->
                             {r : regex | size_regex r <= size_2regex p'}),
        {r : regex | size_regex r <= size_2regex p}

In this type description, the name of the function used to represent
recursive calls is ``g`` and we see that the type of ``g`` imposes
that it can only be used on pairs of ``regex`` terms that are smaller
than the initial argument ``p`` for the order named ``order``. In this
type description, we also see I chose to express that the returned
type of the recursive calls is not ``regex`` but ``{r : regex |
size_regex r <= size_2regex p'}``. This is because we have to handle
*nested* recursion, where outputs of recursive calls will be used as
inputs of other recursive calls. **This is the main trick of this
answer.**

Then we have the body of the ``norm_union_F`` function:

.. coq:: none
|*)

Require Import Psatz Relation_Operators.

Fixpoint size_regex u :=
  match u with
  | Union u v => size_regex u + size_regex v + 1
  | _ => 0
  end.

Definition size_2regex (p : regex * regex) :=
  let (u, v) := p in
  size_regex u + size_regex v + 1.

Inductive arT (u : regex) : Type :=
| arE : u = Empty -> arT u
| arU : forall v w, u = Union v w -> arT u
| arO : u <> Empty -> (forall v w, u <> Union v w) -> arT u.

Definition ar u : arT u.
Proof.
  destruct u as [| |s|u v| |];
    [apply arE; auto | apply arO| apply arO | apply (arU _ u v); auto |
      apply arO | apply arO ]; discriminate.
Defined.

Lemma th1 p : size_regex (snd p) <= size_2regex p.
Proof.
  destruct p. unfold size_2regex. simpl. lia.
Qed.

Lemma th2' p u v (h : fst p = Union u v) :
  size_regex (Union u v) <= size_2regex p.
Proof.
  destruct p. rewrite <- h. unfold size_2regex. simpl. lia.
Qed.

Definition order : regex * regex -> regex * regex -> Prop :=
  fun p1 p2 =>
    lexprod nat (fun _ =>  nat)
            lt (fun _ => lt)
            (existT _ (size_2regex p1) (size_regex (fst p1)))
            (existT _ (size_2regex p2) (size_regex (fst p2))).

Lemma th3' p u v (h : fst p = Union u v) :
  order (v, snd p) p.
Proof.
  destruct p. unfold order. apply left_lex. simpl.
  simpl in h. rewrite h. simpl. lia.
Qed.

Lemma th4' p u v (eq1 : fst p = Union u v) (h : order (v, snd p) p)
      r (rs : size_regex r <= size_2regex (v, snd p)) :
  order (u, r) p.
Proof.
  destruct p as [p1 p2]. simpl in eq1. rewrite eq1.
  simpl in rs |- *.
  apply le_lt_or_eq in rs. destruct rs as [rlt | req].
  - now apply left_lex; simpl; lia.
  - unfold order. simpl.
    replace (size_regex u + size_regex r + 1) with
      (size_regex u + size_regex v + 1 + size_regex p2 + 1) by
      ring [req].
    apply right_lex. lia.
Qed.

Lemma th5' p u v (eq1 : (fst p) = Union u v)
      r1 (r1s : size_regex r1 <= size_2regex (v, snd p))
      r2 (r2s : size_regex r2 <= size_2regex (u, r1)) :
  size_regex r2 <= size_2regex p.
Proof.
  destruct p as [p1 p2]. simpl in eq1, r1s, r2s |- *.
  rewrite eq1. simpl. lia.
Qed.

Lemma th7' p v w (eq2 : snd p = Union v w) :
  size_regex (Union v w) <= size_2regex p.
Proof. destruct p. rewrite <- eq2. simpl. lia. Qed.

Lemma th8' p v w (eq1 : snd p = Union v w) :
  size_regex (Union (fst p) (Union v w)) <= size_2regex p.
Proof.
  destruct p. rewrite <- eq1. simpl. lia.
Qed.

Lemma th9' p v w (eq2 : snd p = Union v w) :
  order (fst p, w) p.
Proof.
  destruct p as [p1 p2]. simpl in eq2 |- *.
  rewrite eq2. apply left_lex. simpl. lia.
Qed.

Lemma th10' p v w (eq2 : snd p = Union v w)
      r (rs : size_regex r <= size_2regex (fst p, w)) :
  size_regex (Union v r) <= size_2regex p.
Proof.
  destruct p as [p1 p2]. simpl in eq2, rs |- *.
  rewrite eq2. simpl. lia.
Qed.

Lemma th11' p : size_regex (fst p) <= size_2regex p.
Proof.
  destruct p as [p1 p2]. simpl. lia.
Qed.

Lemma th12' p : size_regex (Union (fst p) (snd p)) <= size_2regex p.
Proof.
  destruct p. simpl. lia.
Qed.

Lemma th13' p : size_regex (Union (snd p) (fst p)) <= size_2regex p.
Proof.
  destruct p. simpl. lia.
Qed.

(*||*)

Definition norm_union_F : forall p : regex * regex,
  forall g : (forall p', order p' p ->
                         {r : regex | size_regex r <= size_2regex p'}),
    {r : regex | size_regex r <= size_2regex p} :=
  fun p norm_union =>
    match ar (fst p) with
    | arE _ eq1 => exist _ (snd p) (th1 p)
    | arU _ u v eq1 =>
        match ar (snd p) with
        | arE _ eq2 => exist _ (Union u v) (th2' _ _ _ eq1)
        | _ => exist _ (proj1_sig
                          (norm_union (u,
                                        proj1_sig (norm_union (v, snd p)
                                                              (th3' _ _ _ eq1)))
                                      (th4' _ _ _ eq1 (th3' _ _ _ eq1)
                                            (proj1_sig (norm_union (v, snd p)
                                                                   (th3' _ _ _ eq1)))
                                            _)))
                     (th5' _ _ _ eq1
                           (proj1_sig (norm_union (v, snd p)
                                                  (th3' _ _ _ eq1)))
                           (proj2_sig (norm_union (v, snd p)
                                                  (th3' _ _ _ eq1)))
                           (proj1_sig
                              (norm_union
                                 (u, proj1_sig (norm_union (v, snd p)
                                                           (th3' _ _ _ eq1)))
                                 (th4' _ _ _ eq1 (th3' _ _ _ eq1)
                                       (proj1_sig (norm_union (v, snd p)
                                                              (th3' _ _ _ eq1)))
                                       (proj2_sig (norm_union (v, snd p)
                                                              (th3' _ _ _ eq1))))))
                           (proj2_sig
                              (norm_union
                                 (u, proj1_sig (norm_union (v, snd p)
                                                           (th3' _ _ _ eq1)))
                                 (th4' _ _ _ eq1 (th3' _ _ _ eq1)
                                       (proj1_sig (norm_union (v, snd p)
                                                              (th3' _ _ _ eq1)))
                                       (proj2_sig (norm_union (v, snd p)
                                                              (th3' _ _ _ eq1)))))))
        end
    | arO _ d1 d2 =>
        match ar (snd p) with
        | arE _ eq2 => exist _ (fst p) (th11' _)
        | arU _ v w eq2 =>
            if eq_regex_dec (fst p) v then
              exist _ (Union v w) (th7' _ _ _ eq2)
            else if le_regex (fst p) v then
                   exist _ (Union (fst p) (Union v w)) (th8' _ _ _ eq2)
                 else exist _ (Union v (proj1_sig (norm_union (fst p, w)
                                                              (th9' _ _ _ eq2))))
                            (th10' _ _ _ eq2
                                   (proj1_sig (norm_union (fst p, w)
                                                          (th9' _ _ _ eq2)))
                                   (proj2_sig (norm_union (fst p, w)
                                                          (th9' _ _ _ eq2))))
        | arO _ d1 d2 =>
            if eq_regex_dec (fst p) (snd p) then
              exist _ (fst p) (th11' _)
            else if le_regex (fst p) (snd p) then
                   exist _ (Union (fst p) (snd p)) (th12' _)
                 else exist _ (Union (snd p) (fst p)) (th13' _)
        end
    end.

(*|
In this code, all output values are within an ``exist _`` context: not
only do we produce the output value, but we also show that the size of
this value is smaller than the combined size of the input pair of
values. More over, all recursive calls are within a ``proj1_sig``
context, so that we forget the size information at the moment of
constructing the output value. But also, all recursive calls, here
represented by calls to the function named ``norm_union`` also have a
proof that the input to the recursive call is indeed smaller than the
initial input. All the proofs are in `the complete development
<https://github.com/ybertot/norm_union_example>`__.

It would probably be possible to use tactics like ``refine`` to define
``norm_union_F``, you are invited to explore.

Then we define the truly recursive function ``norm_union_1``:

.. coq:: none
|*)

Require Import Wellfounded.

Lemma well_founded_order : well_founded order.
Proof.
  unfold order.
  apply (wf_inverse_image
           (regex * regex) {x : nat & nat}
           (lexprod nat (fun _ => nat) lt (fun _ => lt))
           (fun p => (existT _ (size_2regex p) (size_regex (fst p))))).
  apply wf_lexprod; intros; apply Nat.lt_wf_0.
Qed.

(*||*)

Definition norm_union_1 : forall p : regex * regex,
    {x | size_regex x <= size_2regex p} :=
  Fix well_founded_order (fun p => {x | size_regex x <= size_2regex p})
      norm_union_F.

(*|
Note that the output of ``norm_union_1`` has type ``{x | size_regex x
<= size_2regex p}``. This is not the type you asked for. So we define
a new function, which is really the one you want, simply by forgetting
the logical information that the output has a size smaller than the
input.
|*)

Definition norm_union u v : regex := proj1_sig (norm_union_1 (u, v)).

(*|
You might still doubt that this is the right function, the one you
asked for. To convince ourselves, we are going to prove a lemma that
expresses exactly what you would have said in a definition.

We first prove the corresponding lemma for ``norm_union_1``. This
relies on a theorem associated to the ``Fix`` function, name
``Fix_eq``. The proof that needs to be done is fairly routine (it
always is, it could be done automatically, but I never came around to
developing the automatic tool for that).

Then we finish with most interesting lemma, the one for
``norm_union``. Here is the statement:
|*)

Lemma norm_union_eqn u v :
  norm_union u v =
    match u, v with
    | Empty    , v         => v
    | u        , Empty     => u
    | Union u v, w         => norm_union u (norm_union v w)
    | u        , Union v w => if eq_regex_dec u v
                              then Union v w
                              else if le_regex u v
                                   then Union u (Union v w)
                                   else Union v (norm_union u w)
    | u        , v         => if eq_regex_dec u v
                              then u
                              else if le_regex u v
                                   then Union u v
                                   else Union v u
    end.

(*|
Please note that the right-hand-side of this equation is exactly the
code that you gave in your initial question (I simply copy-pasted it).
The proof of this final theorem is also fairly systematic.

Now, I made the effort of following exactly your request, but after
the fact I discovered that there is a simple implementation of the
same functionality, using three recursive functions. The first one
flattens binary trees of ``Union`` to make then look like list, and
the other two sort these union with respect to the order ``le_regex``
while removing duplicates as soon as they are uncovered. Such an
implementation would workaround the need for nested recursion.

If you still want to stick to nested recursion and need to refer to
the technique described here, it was first published in a paper by
Balaa and Bertot at TPHOLs2000. That paper is difficult to read
because it was written at a time when Coq was using a different
syntax.
|*)


(*|
####################################################
Just a universally quantified hypotesis in Coq proof
####################################################

:Link: https://stackoverflow.com/q/19053778
|*)

(*|
Question
********

Another hard goal (for me, of course) is the following:
|*)

Goal ~(forall P Q : nat -> Prop,
          (exists x, P x) /\ (exists x, Q x) -> (exists x, P x /\ Q x)).
Proof.
Abort. (* .none *)

(*|
I absolutely have no idea of what could I do. If I introduce
something, I get a universal quantifier in the hypotesis, and then I
can't do anything with it.

I suppose that it exists a standard way for managing such kind of
situations, but I was not able to find it out.
|*)

(*|
Answer (Ptival)
***************

To progress in that proof, you will have to exhibit an instance of
``P`` and an instance of ``Q`` such that your hypothesis produces a
contradiction.

A simple way to go is to use:

.. code-block:: coq

    P : fun x => x = 0
    Q : fun x => x = 1

In order to work with the hypothesis introduced, you might want to use
the tactic ``specialize``:
|*)

Goal ~(forall P Q : nat -> Prop,
          (exists x, P x) /\ (exists x, Q x) -> (exists x, P x /\ Q x)).
Proof.
  intro H.
  specialize (H (fun x => x = 0) (fun x => x = 1)).

(*|
It allows you to apply one of your hypothesis on some input (when the
hypothesis is a function). From now on, you should be able to derive a
contradiction easily.

Alternatively to ``specialize``, you can also do:
|*)

  Undo. (* .none *)
  pose proof (H (fun x => x = 0) (fun x => x = 1)) as Happlied.
Abort. (* .none *)

(*|
Which will conserve ``H`` and give you another term ``Happlied`` (you
choose the name) for the application.
|*)

(*|
Answer (Matteo Zanchi)
**********************

The answer of Ptival did the trick. Here is the code of the complete
proof:
|*)

Goal ~(forall P Q : nat -> Prop,
          (exists x, P x) /\ (exists x, Q x) -> (exists x, P x /\ Q x)).
Proof.
  unfold not. intros.
  destruct (H (fun x => x = 0) (fun x => x = 1)).
  - split.
    + exists 0. reflexivity.
    + exists 1. reflexivity.
  - destruct H0. rewrite H0 in H1. inversion H1.
Qed.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 8: Abstract Interpretation and Dataflow Analysis
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap Imp.
Export Imp.

Set Implicit Arguments.

(* Reduced version of code from AbstractInterpretation.v *)

Record absint := {
  Domain :> Set;
  Top : Domain;
  Constant : nat -> Domain;
  Add : Domain -> Domain -> Domain;
  Subtract : Domain -> Domain -> Domain;
  Multiply : Domain -> Domain -> Domain;
  Join : Domain -> Domain -> Domain;
  Represents : nat -> Domain -> Prop
}.

Record absint_sound (a : absint) : Prop := {
  TopSound : forall n, a.(Represents) n a.(Top);

  ConstSound : forall n, a.(Represents) n (a.(Constant) n);

  AddSound : forall n na m ma, a.(Represents) n na
                               -> a.(Represents) m ma
                               -> a.(Represents) (n + m) (a.(Add) na ma);
  SubtractSound: forall n na m ma, a.(Represents) n na
                                   -> a.(Represents) m ma
                                   -> a.(Represents) (n - m) (a.(Subtract) na ma);
  MultiplySound : forall n na m ma, a.(Represents) n na
                                    -> a.(Represents) m ma
                                    -> a.(Represents) (n * m) (a.(Multiply) na ma);

  AddMonotone : forall na na' ma ma', (forall n, a.(Represents) n na -> a.(Represents) n na')
                                      -> (forall n, a.(Represents) n ma -> a.(Represents) n ma')
                                      -> (forall n, a.(Represents) n (a.(Add) na ma)
                                                    -> a.(Represents) n (a.(Add) na' ma'));
  SubtractMonotone : forall na na' ma ma', (forall n, a.(Represents) n na -> a.(Represents) n na')
                                           -> (forall n, a.(Represents) n ma -> a.(Represents) n ma')
                                           -> (forall n, a.(Represents) n (a.(Subtract) na ma)
                                                         -> a.(Represents) n (a.(Subtract) na' ma'));
  MultiplyMonotone : forall na na' ma ma', (forall n, a.(Represents) n na -> a.(Represents) n na')
                                           -> (forall n, a.(Represents) n ma -> a.(Represents) n ma')
                                           -> (forall n, a.(Represents) n (a.(Multiply) na ma)
                                                         -> a.(Represents) n (a.(Multiply) na' ma'));

  JoinSoundLeft : forall x y n, a.(Represents) n x
                                -> a.(Represents) n (a.(Join) x y);
  JoinSoundRight : forall x y n, a.(Represents) n y
                                 -> a.(Represents) n (a.(Join) x y)
}.

Global Hint Resolve TopSound ConstSound AddSound SubtractSound MultiplySound
     AddMonotone SubtractMonotone MultiplyMonotone
     JoinSoundLeft JoinSoundRight : core.

Definition astate (a : absint) := fmap var a.

Fixpoint absint_interp (e : arith) a (s : astate a) : a :=
  match e with
  | Const n => a.(Constant) n
  | Var x => match s $? x with
             | None => a.(Top)
             | Some xa => xa
             end
  | Plus e1 e2 => a.(Add) (absint_interp e1 s) (absint_interp e2 s)
  | Minus e1 e2 => a.(Subtract) (absint_interp e1 s) (absint_interp e2 s)
  | Times e1 e2 => a.(Multiply) (absint_interp e1 s) (absint_interp e2 s)
  end.

Definition merge_astate a : astate a -> astate a -> astate a :=
  merge (fun x y =>
           match x with
           | None => None
           | Some x' =>
             match y with
             | None => None
             | Some y' => Some (a.(Join) x' y')
             end
           end).

Definition subsumed a (s1 s2 : astate a) :=
  forall x, match s1 $? x with
            | None => s2 $? x = None
            | Some xa1 =>
              forall xa2, s2 $? x = Some xa2
                          -> forall n, a.(Represents) n xa1
                                       -> a.(Represents) n xa2
            end.

Theorem subsumed_refl : forall a (s : astate a),
  subsumed s s.
Proof.
  unfold subsumed; simplify.
  cases (s $? x); equality.
Qed.

Global Hint Resolve subsumed_refl : core.

Lemma subsumed_use : forall a (s s' : astate a) x n t0 t,
  s $? x = Some t0
  -> subsumed s s'
  -> s' $? x = Some t
  -> Represents a n t0
  -> Represents a n t.
Proof.
  unfold subsumed; simplify.
  specialize (H0 x).
  rewrite H in H0.
  eauto.
Qed.

Lemma subsumed_use_empty : forall a (s s' : astate a) x n t0 t,
  s $? x = None
  -> subsumed s s'
  -> s' $? x = Some t
  -> Represents a n t0
  -> Represents a n t.
Proof.
  unfold subsumed; simplify.
  specialize (H0 x).
  rewrite H in H0.
  equality.
Qed.

Global Hint Resolve subsumed_use subsumed_use_empty : core.

Lemma subsumed_trans : forall a (s1 s2 s3 : astate a),
  subsumed s1 s2
  -> subsumed s2 s3
  -> subsumed s1 s3.
Proof.
  unfold subsumed; simplify.
  specialize (H x); specialize (H0 x).
  cases (s1 $? x); simplify.
  cases (s2 $? x); eauto.
  cases (s2 $? x); eauto.
  equality.
Qed.

Lemma subsumed_merge_left : forall a, absint_sound a
  -> forall s1 s2 : astate a,
    subsumed s1 (merge_astate s1 s2).
Proof.
  unfold subsumed, merge_astate; simplify.
  cases (s1 $? x); trivial.
  cases (s2 $? x); simplify; try equality.
  invert H0; eauto.
Qed.

Global Hint Resolve subsumed_merge_left : core.

Lemma subsumed_add : forall a, absint_sound a
  -> forall (s1 s2 : astate a) x v1 v2,
  subsumed s1 s2
  -> (forall n, a.(Represents) n v1 -> a.(Represents) n v2)
  -> subsumed (s1 $+ (x, v1)) (s2 $+ (x, v2)).
Proof.
  unfold subsumed; simplify.
  cases (x ==v x0); subst; simplify; eauto.
  invert H2; eauto.
  specialize (H0 x0); eauto.
Qed.

Global Hint Resolve subsumed_add : core.

(** * Flow-sensitive analysis *)

Definition compatible a (s : astate a) (v : valuation) : Prop :=
  forall x xa, s $? x = Some xa
               -> exists n, v $? x = Some n
                            /\ a.(Represents) n xa.

Lemma compatible_add : forall a (s : astate a) v x na n,
  compatible s v
  -> a.(Represents) n na
  -> compatible (s $+ (x, na)) (v $+ (x, n)).
Proof.
  unfold compatible; simplify.
  cases (x ==v x0); simplify; eauto.
  invert H1; eauto.
Qed.

Global Hint Resolve compatible_add : core.

(* A similar result follows about soundness of expression interpretation. *)
Theorem absint_interp_ok : forall a, absint_sound a
  -> forall (s : astate a) v e,
    compatible s v
    -> a.(Represents) (interp e v) (absint_interp e s).
Proof.
  induct e; simplify; eauto.
  cases (s $? x); auto.
  unfold compatible in H0.
  apply H0 in Heq.
  invert Heq.
  propositional.
  rewrite H2.
  assumption.
Qed.

Global Hint Resolve absint_interp_ok : core.

Definition astates (a : absint) := fmap cmd (astate a).

Fixpoint absint_step a (s : astate a) (c : cmd) (wrap : cmd -> cmd) : option (astates a) :=
  match c with
  | Skip => None
  | Assign x e => Some ($0 $+ (wrap Skip, s $+ (x, absint_interp e s)))
  | Sequence c1 c2 =>
    match absint_step s c1 (fun c => wrap (Sequence c c2)) with
    | None => Some ($0 $+ (wrap c2, s))
    | v => v
    end
  | If _ then_ else_ => Some ($0 $+ (wrap then_, s) $+ (wrap else_, s))
  | While e body => Some ($0 $+ (wrap Skip, s) $+ (wrap (Sequence body (While e body)), s))
  end.

Lemma command_equal : forall c1 c2 : cmd, sumbool (c1 = c2) (c1 <> c2).
Proof.
  repeat decide equality.
Qed.

Theorem absint_step_ok : forall a, absint_sound a
  -> forall (s : astate a) v, compatible s v
  -> forall c v' c', step (v, c) (v', c')
                     -> forall wrap, exists ss s', absint_step s c wrap = Some ss
                                                   /\ ss $? wrap c' = Some s'
                                                   /\ compatible s' v'.
Proof.
  induct 2; simplify.

  do 2 eexists; propositional.
  simplify; equality.
  eauto.

  eapply IHstep in H0; auto.
  invert H0.
  invert H2.
  propositional.
  rewrite H2.
  eauto.

  do 2 eexists; propositional.
  simplify; equality.
  assumption.

  do 2 eexists; propositional.
  cases (command_equal (wrap c') (wrap else_)).
  simplify; equality.
  simplify; equality.
  assumption.

  do 2 eexists; propositional.
  simplify; equality.
  assumption.

  do 2 eexists; propositional.
  simplify; equality.
  assumption.

  do 2 eexists; propositional.
  cases (command_equal (wrap Skip) (wrap (body;; while e loop body done))).
  simplify; equality.
  simplify; equality.
  assumption.
Qed.

Inductive abs_step a : astate a * cmd -> astate a * cmd -> Prop :=
| AbsStep : forall s c ss s' c',
  absint_step s c (fun x => x) = Some ss
  -> ss $? c' = Some s'
  -> abs_step (s, c) (s', c').

Global Hint Constructors abs_step : core.

Definition absint_trsys a (c : cmd) := {|
  Initial := {($0, c)};
  Step := abs_step (a := a)
|}.

Inductive Rabsint a : valuation * cmd -> astate a * cmd -> Prop :=
| RAbsint : forall v s c,
  compatible s v
  -> Rabsint (v, c) (s, c).

Global Hint Constructors abs_step Rabsint : core.

Theorem absint_simulates : forall a v c,
  absint_sound a
  -> simulates (Rabsint (a := a)) (trsys_of v c) (absint_trsys a c).
Proof.
  simplify.
  constructor; simplify.

  exists ($0, c); propositional.
  subst.
  constructor.
  unfold compatible.
  simplify.
  equality.

  invert H0.
  cases st1'.
  eapply absint_step_ok in H1; eauto.
  invert H1.
  invert H0.
  propositional.
  eauto.
Qed.

Definition merge_astates a : astates a -> astates a -> astates a :=
  merge (fun x y =>
           match x with
           | None => y
           | Some x' =>
             match y with
             | None => Some x'
             | Some y' => Some (merge_astate x' y')
             end
           end).

Inductive oneStepClosure a : astates a -> astates a -> Prop :=
| OscNil :
  oneStepClosure $0 $0
| OscCons : forall ss c s ss' ss'',
  oneStepClosure ss ss'
  -> match absint_step s c (fun x => x) with
     | None => ss'
     | Some ss'' => merge_astates ss'' ss'
     end = ss''
  -> oneStepClosure (ss $+ (c, s)) ss''.

Definition subsumeds a (ss1 ss2 : astates a) :=
  forall c s1, ss1 $? c = Some s1
               -> exists s2, ss2 $? c = Some s2
                             /\ subsumed s1 s2.

Theorem subsumeds_refl : forall a (ss : astates a),
  subsumeds ss ss.
Proof.
  unfold subsumeds; simplify; eauto.
Qed.

Global Hint Resolve subsumeds_refl : core.

Lemma subsumeds_add : forall a (ss1 ss2 : astates a) c s1 s2,
  subsumeds ss1 ss2
  -> subsumed s1 s2
  -> subsumeds (ss1 $+ (c, s1)) (ss2 $+ (c, s2)).
Proof.
  unfold subsumeds; simplify.
  cases (command_equal c c0); subst; simplify; eauto.
  invert H1; eauto.
Qed.

Global Hint Resolve subsumeds_add : core.

Lemma subsumeds_empty : forall a (ss : astates a),
  subsumeds $0 ss.
Proof.
  unfold subsumeds; simplify.
  equality.
Qed.

Lemma subsumeds_add_left : forall a (ss1 ss2 : astates a) c s,
  ss2 $? c = Some s
  -> subsumeds ss1 ss2
  -> subsumeds (ss1 $+ (c, s)) ss2.
Proof.
  unfold subsumeds; simplify.
  cases (command_equal c c0); subst; simplify; eauto.
  invert H1; eauto.
Qed.

Inductive interpret a : astates a -> astates a -> astates a -> Prop :=
| InterpretDone : forall ss1 any ss2,
  oneStepClosure ss1 ss2
  -> subsumeds ss2 ss1
  -> interpret ss1 any ss1
| InterpretStep : forall ss worklist ss' ss'',
  oneStepClosure worklist ss'
  -> interpret (merge_astates ss ss') ss' ss''
  -> interpret ss worklist ss''.

Lemma oneStepClosure_sound : forall a, absint_sound a
  -> forall ss ss' : astates a, oneStepClosure ss ss'
  -> forall c s s' c', ss $? c = Some s
                       -> abs_step (s, c) (s', c')
                          -> exists s'', ss' $? c' = Some s''
                                         /\ subsumed s' s''.
Proof.
  induct 2; simplify.

  equality.

  cases (command_equal c c0); subst; simplify.

  invert H2.
  invert H3.
  rewrite H5.
  unfold merge_astates; simplify.
  rewrite H7.
  cases (ss' $? c').
  eexists; propositional.
  unfold subsumed; simplify.
  unfold merge_astate; simplify.
  cases (s' $? x); try equality.
  cases (a0 $? x); simplify; try equality.
  invert H1; eauto.
  eauto.

  apply IHoneStepClosure in H3; auto.
  invert H3; propositional.
  cases (absint_step s c (fun x => x)); eauto.
  unfold merge_astates; simplify.
  rewrite H3.
  cases (a0 $? c'); eauto.
  eexists; propositional.
  unfold subsumed; simplify.
  unfold merge_astate; simplify.
  specialize (H4 x0).
  cases (s' $? x0).
  cases (a1 $? x0); try equality.
  cases (x $? x0); try equality.
  invert 1.
  eauto.

  rewrite H4.
  cases (a1 $? x0); equality.
Qed.

Lemma absint_step_monotone_None : forall a (s : astate a) c wrap,
    absint_step s c wrap = None
    -> forall s' : astate a, absint_step s' c wrap = None.
Proof.
  induct c; simplify; try equality.
  cases (absint_step s c1 (fun c => wrap (c;; c2))); equality.
Qed.

Lemma absint_interp_monotone : forall a, absint_sound a
  -> forall (s : astate a) e s' n,
    a.(Represents) n (absint_interp e s)
    -> subsumed s s'
    -> a.(Represents) n (absint_interp e s').
Proof.
  induct e; simplify; eauto.

  cases (s' $? x); eauto.
  cases (s $? x); eauto.
Qed.

Global Hint Resolve absint_interp_monotone : core.

Lemma absint_step_monotone : forall a, absint_sound a
    -> forall (s : astate a) c wrap ss,
      absint_step s c wrap = Some ss
      -> forall s', subsumed s s'
                    -> exists ss', absint_step s' c wrap = Some ss'
                                   /\ subsumeds ss ss'.
Proof.
  induct c; simplify.

  equality.

  invert H0.
  eexists; propositional.
  eauto.
  apply subsumeds_add; eauto.

  cases (absint_step s c1 (fun c => wrap (c;; c2))).

  invert H0.
  eapply IHc1 in Heq; eauto.
  invert Heq; propositional.
  rewrite H2; eauto.

  invert H0.
  eapply absint_step_monotone_None in Heq; eauto.
  rewrite Heq; eauto.

  invert H0; eauto.

  invert H0; eauto.
Qed.

Lemma abs_step_monotone : forall a, absint_sound a
  -> forall (s : astate a) c s' c',
    abs_step (s, c) (s', c')
    -> forall s1, subsumed s s1
                  -> exists s1', abs_step (s1, c) (s1', c')
                                 /\ subsumed s' s1'.
Proof.
  invert 2; simplify.
  eapply absint_step_monotone in H4; eauto.
  invert H4; propositional.
  apply H3 in H6.
  invert H6; propositional; eauto.
Qed.

Lemma interpret_sound' : forall c a, absint_sound a
  -> forall ss worklist ss' : astates a, interpret ss worklist ss'
    -> ss $? c = Some $0
    -> invariantFor (absint_trsys a c) (fun p => exists s, ss' $? snd p = Some s
                                                           /\ subsumed (fst p) s).
Proof.
  induct 2; simplify; subst.

  apply invariant_induction; simplify; propositional; subst; simplify; eauto.

  invert H3; propositional.
  cases s.
  cases s'.
  simplify.
  eapply abs_step_monotone in H4; eauto.
  invert H4; propositional.
  eapply oneStepClosure_sound in H4; eauto.
  invert H4; propositional.
  eapply H1 in H4.
  invert H4; propositional.
  eauto using subsumed_trans.

  apply IHinterpret.
  unfold merge_astates; simplify.
  rewrite H2.
  cases (ss' $? c); trivial.
  unfold merge_astate; simplify; equality.
Qed.

Theorem interpret_sound : forall c a (ss : astates a),
  absint_sound a
  -> interpret ($0 $+ (c, $0)) ($0 $+ (c, $0)) ss
  -> invariantFor (absint_trsys a c) (fun p => exists s, ss $? snd p = Some s
                                                         /\ subsumed (fst p) s).
Proof.
  simplify.
  eapply interpret_sound'; eauto.
  simplify; equality.
Qed.

Ltac interpret_simpl := unfold merge_astates, merge_astate;
                       simplify; repeat simplify_map.
Ltac oneStepClosure := apply OscNil
                       || (eapply OscCons; [ oneStepClosure
                                           | interpret_simpl; reflexivity ]).
Ltac interpret1 := eapply InterpretStep; [ oneStepClosure | interpret_simpl ].
Ltac interpret_done := eapply InterpretDone; [ oneStepClosure
  | repeat (apply subsumeds_add_left || apply subsumeds_empty); (simplify; equality) ].


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Import NZAxioms NZBase NZAdd.

Module Type NZMulProp (Import NZ : NZAxiomsSig')(Import NZBase : NZBaseProp NZ).
Include NZAddProp NZ NZBase.

Theorem mul_0_r : forall n, n * 0 == 0.
Proof.
nzinduct n; intros; now nzsimpl.
Qed.

Theorem mul_succ_r : forall n m, n * (S m) == n * m + n.
Proof.
intros n m; nzinduct n. now nzsimpl.
intro n. nzsimpl. rewrite succ_inj_wd, <- add_assoc, (add_comm m n), add_assoc.
now rewrite add_cancel_r.
Qed.

Hint Rewrite mul_0_r mul_succ_r : nz.

Theorem mul_comm : forall n m, n * m == m * n.
Proof.
intros n m; nzinduct n. now nzsimpl.
intro. nzsimpl. now rewrite add_cancel_r.
Qed.

Theorem mul_add_distr_r : forall n m p, (n + m) * p == n * p + m * p.
Proof.
intros n m p; nzinduct n. now nzsimpl.
intro n. nzsimpl. rewrite <- add_assoc, (add_comm p (m*p)), add_assoc.
now rewrite add_cancel_r.
Qed.

Theorem mul_add_distr_l : forall n m p, n * (m + p) == n * m + n * p.
Proof.
intros n m p.
rewrite (mul_comm n (m + p)), (mul_comm n m), (mul_comm n p).
apply mul_add_distr_r.
Qed.

Theorem mul_assoc : forall n m p, n * (m * p) == (n * m) * p.
Proof.
intros n m p; nzinduct n. now nzsimpl.
intro n. nzsimpl. rewrite mul_add_distr_r.
now rewrite add_cancel_r.
Qed.

Theorem mul_1_l : forall n, 1 * n == n.
Proof.
intro n. now nzsimpl'.
Qed.

Theorem mul_1_r : forall n, n * 1 == n.
Proof.
intro n. now nzsimpl'.
Qed.

Hint Rewrite mul_1_l mul_1_r : nz.

Theorem mul_shuffle0 : forall n m p, n*m*p == n*p*m.
Proof.
intros n m p. now rewrite <- 2 mul_assoc, (mul_comm m).
Qed.

Theorem mul_shuffle1 : forall n m p q, (n * m) * (p * q) == (n * p) * (m * q).
Proof.
intros n m p q. now rewrite 2 mul_assoc, (mul_shuffle0 n).
Qed.

Theorem mul_shuffle2 : forall n m p q, (n * m) * (p * q) == (n * q) * (m * p).
Proof.
intros n m p q. rewrite (mul_comm p). apply mul_shuffle1.
Qed.

Theorem mul_shuffle3 : forall n m p, n * (m * p) == m * (n * p).
Proof.
intros n m p. now rewrite mul_assoc, (mul_comm n), mul_assoc.
Qed.

End NZMulProp.


Require Import Program.Basics.
Require Import Category.
Require Import Std.prod.

Hint Resolve prod_proj.

Open Scope program_scope.

(** Polymorphic lens: views the current part [A] from the whole [S] and updates
    the part [A] with a new version of it [B], which is reflected in the whole
    [T]. *)
Record pLens (S T A B : Type) := mkPLens
{ view : S -> A
; update : S -> B -> T
}.
Arguments mkPLens [S T A B].
Arguments view [S T A B].
Arguments update [S T A B].

(** Monomorphic lens *)
Definition lens S A : Type := pLens S S A A.

(** Very well-behaved lens. *)
Record lensDec {S A} (ln : lens S A) := mkLensDec
{ view_update : forall s, update ln s (view ln s) = s
; update_view : forall s a, view ln (update ln s a) = a
; update_update : forall s a1 a2, update ln (update ln s a1) a2 = update ln s a2
}.

Instance Category_lens : Category lens :=
{ identity A := mkPLens id (fun _ => id)
; compose A B C ln1 ln2 := mkPLens
    (view ln2 ∘ view ln1)
    (fun s => update ln1 s ∘ update ln2 (view ln1 s))
}.

Instance CategoryDec_lens : CategoryDec lens.
Proof.
  split; simpl; intros; destruct cab; auto.
Qed.

Lemma lensDec_identity : forall A, lensDec (@identity lens _ A).
Proof. split; auto. Qed.

Lemma lensDec_compose :
  forall {A B C} (ln1 : lens A B) (ln2 : lens B C),
    lensDec ln1 -> lensDec ln2 -> lensDec (compose ln1 ln2).
Proof.
  intros.
  destruct H.
  destruct H0.
  split; simpl; unfold Basics.compose; intros.

  - (* view_update *)
    rewrite view_update1.
    now rewrite view_update0.

  - (* update_view *)
    rewrite update_view0.
    now rewrite update_view1.

  - (* update_update *)
    rewrite update_update0.
    rewrite update_view0.
    now rewrite update_update1.
Qed.

(** Provides access to the first component of a product. *)
Definition first {A B} : lens (A * B) A :=
  mkPLens fst (fun s a' => (a', snd s)).

Definition firstDec {A B} : lensDec (@first A B).
Proof.
  split; simpl; auto.
Qed.

(** Provides access to the second component of a product. *)
Definition second {A B} : lens (A * B) B :=
  mkPLens snd (fun s b' => (fst s, b')).

Definition secondDec {A B} : lensDec (@second A B).
Proof.
  split; simpl; auto.
Qed.

(** Profunctor lens *)

Require Import Profunctor.

Definition LensP (S T A B : Type) : Type := forall p `{Cartesian p}, p A B -> p S T.

Definition LensP' (S A : Type) : Type := LensP S S A A.

(** Monadic lens *)

Require Import Monad.

Record mLens (S A : Type) (m : Type -> Type) `{Monad m} := mkMLens
{ mview   : S -> A
; mupdate : S -> A -> m S
}.

Arguments mkMLens [S A m _ _ _].
Arguments mview [S A m _ _ _].
Arguments mupdate [S A m _ _ _].

(** Well-behaved monadic lens *)

Record mLensLaws {S A m} `{Monad m} (mln : mLens S A m) := mkMLensLaws
{ mview_mupdate : forall s, mupdate mln s (mview mln s) = ret s
; mupdate_mview : forall B (k : S -> A -> m B) s a,
    mupdate mln s a >>= (fun s' => k s' (mview mln s')) =
    mupdate mln s a >>= (fun s' => k s' a)
}.


From mathcomp Require Import all_ssreflect perm algebra.zmodp.
From mathcomp Require Import zify.
Require Import more_tuple nsort.

Import Order POrderTheory TotalTheory.

(******************************************************************************)
(*  Definition of the Batcher odd-even merge sorting algorithm                *)
(*                                                                            *)
(*      batcher_merge == the connector that links i to i.+1 for i odd         *)
(*  batcher_merge_rec == the recursive network that calls itself on           *)
(*                       the even and odd parts and then apply batcher_merge  *)
(*                    == the network that calls itself on the top and bottom  *)
(*                       parts and then apply batcher_merge_rec               *)
(******************************************************************************)

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

Section Batcher.

Variable d : unit.
Variable A : orderType d.

Definition batcher_merge {m} : connector m := codd_jump 1.

Lemma cfun_batcher_merge n (t : n.-tuple A) :
  cfun batcher_merge t =
  [tuple
    if odd i then min (tnth t i) (tnth t (inext i))
    else max (tnth t i) (tnth t (ipred i)) | i < n].
Proof.
rewrite [LHS]cfun_odd_jump //.
apply/val_eqP/eqP=> /=; apply/eq_map => i;
      congr (if _ then min (tnth _ _) (tnth _ _)
             else max _ _).
  case: (n) i => //= n1 i; rewrite add1n.
  by have := ltn_ord i; rewrite ltnS; case: (ltngtP i n1).
congr (tnth _ _); apply/val_eqP/eqP=> /=.
rewrite /isub /ipred.
by case: (n) i => //= n1 i; case: (i : nat) => [|i1]; rewrite ?addn1 ?subn1.
Qed.

Fixpoint batcher_merge_rec_aux m : network (`2^ m.+1) :=
  if m is m1.+1 then rcons (neodup (batcher_merge_rec_aux m1)) batcher_merge
  else [:: cswap ord0 ord_max].

Lemma size_batcher_merge_rec_aux m : size (batcher_merge_rec_aux m) = m.+1.
Proof.
elim: m => [//| m IH] /=.
by rewrite size_rcons size_map size_zip minnn IH.
Qed.

Definition batcher_merge_rec m :=
  if m is m1.+1 then batcher_merge_rec_aux m1 else [::].

Lemma size_batcher_merge_rec m : size (batcher_merge_rec m) = m.
Proof. by case: m => //= m; rewrite size_batcher_merge_rec_aux. Qed.

Fixpoint batcher m : network (`2^ m) :=
  if m is m1.+1 then ndup (batcher m1) ++ batcher_merge_rec m1.+1
  else [::].

Lemma size_batcher m : size (batcher m) = (m * m.+1)./2.
Proof.
elim: m => [//|m IH].
rewrite [in LHS]/= size_cat size_map size_zip minnn.
rewrite size_batcher_merge_rec_aux IH.
by rewrite -addn2 mulnDr -!divn2 divnDMl // mulnC.
Qed.

End Batcher.

Lemma sorted_batcher_merge  (m : nat) (t : (m + m).-tuple bool) :
 noF (totake t) <= noF (tetake t) <= (noF (totake t)).+2 ->
 sorted <=%O (tetake t) -> sorted <=%O (totake t) ->
 sorted <=%O (cfun batcher_merge t).
Proof.
move=> /andP[FotLFet FotLFet2] eS oS.
pose i := noF (tetake t) - noF (totake t).
have i_le2 : i <= 2 by rewrite leq_subLR addn2.
have nFE : noF (tetake t) = noF (totake t) + i by rewrite addnC subnK.
have [ceS coF ncFE] := sorted_odd_jump (isT : odd 1) i_le2 eS oS nFE.
apply: sorted_tetake_totake => //.
rewrite ncFE leq_addr -[X in _ <= X]addn1 leq_add2l /=.
by rewrite leq_subLR addnC -leq_subLR -addnn leq_addr.
Qed.

(* This is the big proof could be improved : lots of repetitions *)
Lemma sorted_nfun_batcher_merge_rec m (t : (`2^ m.+1).-tuple bool) :
  sorted <=%O (ttake t) -> sorted <=%O (tdrop t) ->
  sorted <=%O (nfun (batcher_merge_rec_aux m) t).
Proof.
elim: m t => [t tS dS|m IH t tS dS /=].
  rewrite [batcher_merge_rec_aux 0]/= tsorted2 /=.
  by rewrite cswapE_min // cswapE_max // le_minl le_maxr lexx.
rewrite nfun_rcons nfun_eodup.
set n1 := nfun _ _; set n2 := nfun _ _.
have n1P : perm_eq n1 (tetake t) by apply: perm_nfun.
have n1S : sorted <=%O n1.
  apply: IH.
    by rewrite ttake_etakeE; apply: etake_sorted => // [] [] [] [].
  by rewrite tdrop_etakeE; apply: etake_sorted => // [] [] [] [].
have n2P : perm_eq n2 (totake t) by apply: perm_nfun.
have n2S : sorted <=%O n2.
  apply: IH.
  - by rewrite ttake_otakeE; apply: otake_sorted => // [] [] [] [].
  - by rewrite tdrop_otakeE; apply: otake_sorted => // [] [] [] [].
apply: sorted_batcher_merge; rewrite ?(tetakeK, totakeK) //.
have /isorted_boolP[[a1 b1] n1E] := n1S.
have /isorted_boolP[[a2 b2] n2E] := n2S.
rewrite !n1E !n2E !noE.
have /isorted_boolP[[a3 b3] tSE] := tS.
have /isorted_boolP[[a4 b4] dSE] := dS.
have /val_eqP tE := cat_ttake_tdrop t; rewrite /= tSE dSE in tE.
have /val_eqP eotE := eocat_tetake_totake t.
rewrite /= (eqP tE) !(etake_cat, otake_cat, etake_cat_nseq, otake_nseq,
                      etake_nseq, size_cat, size_nseq, otake_cat_nseq) in eotE.
have : ~~ odd (size (ttake t)) by rewrite size_tuple addnn odd_double.
rewrite tSE size_cat !size_nseq => /negPf b3O.
rewrite b3O in eotE; rewrite oddD in b3O.
have : ~~ odd (size (tdrop t)) by rewrite size_tuple addnn odd_double.
rewrite dSE size_cat !size_nseq oddD => /negPf b4O.
rewrite tetakeE totakeE (eqP tE) !(etake_cat, otake_cat, otake_nseq,
                                    etake_nseq, size_cat, size_nseq,
                                    uphalf_half)
         oddD n1E n2E in n1P n2P.
case: (boolP (odd a3)) b3O => [a3O /negP/negP b3O |/negPf a3E b3E].
  case: (boolP (odd a4)) b4O => [a4O /negP/negP b4O|/negPf a4E b4E].
(* First case *)
    rewrite a3O a4O b3O b4O [if true (+) true then _ else _]/= !add1n in n1P.
    rewrite a3O a4O b3O b4O [if true (+) true then _ else _]/= !add1n in n2P.
    have [/eqP Ea1 /eqP Eb1] : a1 == (a3./2 + a4./2).+2 /\
                               b1 == b3./2 + b4./2.
      move/allP/(_ false) : (n1P); move/allP/(_ true) : n1P.
      rewrite /= !(count_cat, count_nseq) /= !(count_cat, count_nseq) /=.
      rewrite !mul1n !mul0n !(addn0, add0n) !add1n !(addSn, addnS).
      rewrite !(mem_cat, inE, mem_nseq, eqxx, orbT, orTb, orFb, orbF,
                andbF, andbT) => Hb1 -> //; split=> //.
      by case: (b1) Hb1 => [|x] //; (do 2 case (_./2) => [|?]) => // ->.
    have [/eqP Ea2 /eqP Eb2] : a2 == a3./2 + a4./2 /\ b2 == (b3./2 + b4./2).+2.
      move/allP/(_ false) : (n2P); move/allP/(_ true) : n2P.
      rewrite /= !(count_cat, count_nseq) /= !(count_cat, count_nseq) /=.
      rewrite !mul1n !mul0n !(addn0, add0n, add1n, addSn, addnS).
      rewrite !(mem_cat, mem_nseq, inE, eqxx, orTb, andTb, andbT, orbT,
                andbF, orFb, orbF) => -> //.
      by case: (a2) => [|?]//; (do 2 (case: (_./2) => [|?]//)) => ->.
    by move=> {a3O b3O a4O b4O n1P n2P}//; lia.
(* Second case *)
  rewrite /= in b4E.
  rewrite a3O b3O a4E b4E [if true (+) true then _ else _]/=
          !add0n !add1n in n1P.
  rewrite a3O a4E b3O b4E [if true (+) true then _ else _]/= in n2P.
  have [/eqP Ea1 /eqP Eb1] : a1 == (a3./2 + a4./2).+1 /\ b1 == b3./2 + b4./2.
    move/allP/(_ false) : (n1P); move/allP/(_ true) : n1P.
    rewrite /= !(count_cat, count_nseq) /= .
    rewrite !mul1n !mul0n !(addn0, add0n) !add1n /=.
    rewrite !(mem_cat, inE, mem_nseq, eqxx, orbT, orTb, orFb, orbF,
              andbF, andbT) /= => Hb1 ->; split=> //.
    by case: (b1) Hb1 => [|x]; (do 2 case (_./2) => [|?]) => // ->.
  have [/eqP Ea2 /eqP Eb2] : a2 == a3./2 + a4./2 /\ b2 == (b3./2 + b4./2).+1.
    move/allP/(_ false) : (n2P); move/allP/(_ true) : n2P.
    rewrite /= !(count_cat, count_nseq) /= !(count_cat, count_nseq) /=.
    rewrite !mul1n !mul0n !(addn0, add0n, add1n, addSn, addnS).
    rewrite !(mem_cat, mem_nseq, inE, eqxx, orTb, andTb, andbT, orbT,
              andbF, orFb, orbF) => -> //.
    by case: (a2) => [|?]//; (do 2 (case: (_./2) => [|?]//)) => ->.
  by move=> {a3O b3O a4E b4E n1P n2P}//; lia.
case: (boolP (odd a4)) b4O => [a4O /negP/negP b4O|/negPf a4E b4E].
(* Third case *)
  rewrite /= in b3E.
  rewrite a3E b3E a4O [if false (+) false then _ else _]/= !add0n in n1P.
  rewrite a3E b3E a4O b4O [if false (+) false then _ else _]/= in n2P.
  have [/eqP Ea1 /eqP Eb1] : a1 == (a3./2 + a4./2).+1 /\ b1 == b3./2 + b4./2.
    move/allP/(_ false) : (n1P); move/allP/(_ true) : n1P.
    rewrite /= !(count_cat, count_nseq) /= !(count_cat, count_nseq) /=.
    rewrite !mul1n !mul0n !(addn0, add0n) !add1n !(addSn, addnS).
    rewrite !(mem_cat, inE, mem_nseq, eqxx, orbT, orTb, orFb, orbF,
              andbF, andbT) => Hb1 -> //; split => //.
    by case: (b1) Hb1 => // => [|x]; (do 2 case (_./2) => [|?]) => // ->.
  have [/eqP Ea2 /eqP Eb2] : a2 == a3./2 + a4./2 /\ b2 == (b3./2 + b4./2).+1.
    move/allP/(_ false) : (n2P); move/allP/(_ true) : n2P.
    rewrite /= !(count_cat, count_nseq) /= !(count_cat, count_nseq) /=.
    rewrite !mul1n !mul0n !(addn0, add0n, add1n, addSn, addnS).
    rewrite !(mem_cat, mem_nseq, inE, eqxx, orTb, andTb, andbT, orbT,
               andbF, orFb, orbF) => -> // Hb1; split => //.
    by case: (a2) Hb1 => [|?]//; (do 2 (case: (_./2) => [|?]//)) => ->.
  by move=> {a3E b3E a4O b4O n1P n2P}//; lia.
(* Fourth case *)
rewrite /= in a3E b3E b4E.
rewrite a3E b3E a4E b4E [if false (+) false then _ else _]/= !add0n in n1P.
rewrite a3E b3E a4E b4E [if false (+) false then _ else _]/= in n2P.
have [/eqP Ea1 /eqP Eb1] : a1 == a3./2 + a4./2 /\ b1 == b3./2 + b4./2.
  move/allP/(_ false) : (n1P); move/allP/(_ true) : n1P.
  rewrite /= !(count_cat, count_nseq) /=.
  rewrite !mul1n !mul0n !(addn0, add0n).
  rewrite !(mem_cat, inE, mem_nseq, eqxx, orbT, orTb, orFb, orbF,
            andbF, andbT) => Hb1 Ha1 //; split.
    by case: (a1) Ha1 => [|x]; (do 2 case (_./2) => [|?]) => // ->.
  by  case: (b1) Hb1 => [|x]; (do 2 case (_./2) => [|?]) => // ->.
have [/eqP Ea2 /eqP Eb2] : a2 == a3./2 + a4./2 /\ b2 == b3./2 + b4./2.
  move/allP/(_ false) : (n2P); move/allP/(_ true) : n2P.
  rewrite /= !(count_cat, count_nseq) /=.
  rewrite !mul1n !mul0n !(addn0, add0n, add1n, addSn, addnS).
  rewrite !(mem_cat, mem_nseq, inE, eqxx, orTb, andTb, andbT, orbT,
            andbF, orFb, orbF) => Hb2 Ha2; split.
    by case: (a2) Ha2 => [|?]//; (do 2 (case: (_./2) => [|?]//)) => ->.
  by case: (b2) Hb2 => [|?]//; (do 2 (case: (_./2) => [|?]//)) => ->.
by move=> {a3E b3E a4E b4E n1P n2P}//; lia.
Qed.

Lemma sorted_nfun_batcher_merge m (t : (`2^ m.+1).-tuple bool) :
  sorted <=%O (ttake t) -> sorted <=%O (tdrop t) ->
  sorted <=%O (nfun (batcher_merge_rec m.+1) t).
Proof. exact: sorted_nfun_batcher_merge_rec. Qed.

Lemma sorted_nfun_batcher m (t : (`2^ m).-tuple bool) :
  sorted <=%O (nfun (batcher m) t).
Proof.
elim: m t => [t|m IH t] /=; first by apply: tsorted01.
rewrite nfun_cat.
apply: sorted_nfun_batcher_merge_rec.
  by rewrite nfun_dup ttakeK; apply: IH.
by rewrite nfun_dup; rewrite tdropK; apply: IH.
Qed.

Lemma sorting_batcher m : batcher m \is sorting.
Proof. apply/forallP => x; apply: sorted_nfun_batcher. Qed.


(** * Indução em Coq *)

Set Warnings "-notation-overridden,-parsing".
Require Export aula05_listas.

(* ############################################### *)
(** * Listas polimórficas *)

(** Polimorfismo permite criar definições abstraindo
    os tipos de dados que serão manipulados. *)

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

(** Agora, [list] é uma função de [Type]s para
    [Type]s. Dado um tipo [X], [list X] é o conjunto
    de listas indutivamente definidas cujos elementos
    possuem tipo [X]. *)

Check list.
(* ===> list : Type -> Type *)
Check (nil nat).
(* ===> nil nat : list nat *)
Check (cons nat 3 (nil nat)).
(* ===> cons nat 3 (nil nat) : list nat *)
Check nil.
(* ===> nil : forall X : Type, list X *)
Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)

(** Funções sobre listas polimórficas. *)

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Example test_repeat1 :
  repeat nat 4 2 =
  cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity.  Qed.

Example test_repeat2 :
  repeat bool false 1 =
  cons bool false (nil bool).
Proof. reflexivity.  Qed.

(** Coq possui um mecanismo de inferência. *)

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Check repeat'.
(* ===> forall X : Type, X -> nat -> list X *)
Check repeat.
(* ===> forall X : Type, X -> nat -> list X *)

(** É importante ter um equilíbrio entre o
    que é inferido e o que é informado:
    - inferido: + prática, dificultar entendimento
    - informado: - prático, facilitar entendimento. *)

(** É possível indicar argumentos implícitos: [_]. *)

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

(** É possível omitir até o [_]. A diretiva
    [Arguments] especifica o nome de uma função
    (ou construtor) e, em seguida, lista os nomes
    dos seus argumentos, com chaves limitando
    os argumentos que serão implícitos. Se a
    função tiver argumentos sem nome, usar [_]. *)

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

(** Agora é possível escrever o seguinte. *)

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

(** Também é possível usar chaves na própria
    definição da função. *)
Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

(** Sugestão: usar a última opção para funções
    e a anterior para construtores indutivos.
    Em construtores, torna o tipo implícito
    até para o tipo sendo definido pelo construtor.

    Em alguns casos, será necessário informar
    explicitamente o tipo implícito: [@]. *)

Fail Definition mynil := nil.

(** Alternativas:
    - Declarar o tipo explicitamente
    - Tornar explícito o tipo implícito. *)

Definition mynil : list nat := nil.

Check @nil.
Definition mynil' := @nil nat.

(** Outras funções para listas polimórficas. *)

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) =
  (cons 2 (cons 1 nil)).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev (cons true nil) =
  cons true nil.
Proof. reflexivity.  Qed.

Example test_length1:
  length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity.  Qed.

(** Definindo uma sintaxe conveniente para listas. *)

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** Agora, podemos escrever listas da seguinte forma. *)

Definition list123''' := [1; 2; 3].
Check (list123''').

(** **** Exercise: (poly_exercises)  *)
(** Complete as provas a seguir. *)

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  (* COMPLETE AQUI *) Admitted.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  (* COMPLETE AQUI *) Admitted.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  (* COMPLETE AQUI *) Admitted.

(* ############################################### *)
(** * Pares polimórficos *)

Inductive prod (X Y : Type) : Type :=
| pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

(** A anotação [: type_scope] diz para Coq
    só usar esta abreviação ao processar tipos.
    Isto impede conflitos com o símbolo da
    multiplicação. *)

(** Algumas funções úteis. *)

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

(** A função a seguir combina lista de pares. *)

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Example combine_test1 :
  combine [1;2;3] [0;10]
  = [(1,0);(2,10)].
Proof. reflexivity. Qed.

(** **** Exercise: (split)  *)
(** A função [split] é a inversa direita de [combine]:
    dada uma lista de pares, retorna um par de listas. *)

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y)
(* SUBSTITUA COM ":= _sua_definição_ ." *). Admitted.

Example test_split:
  split [(1,false);(2,false)] =
  ([1;2],[false;false]).
Proof.
  (* COMPLETE AQUI *) Admitted.

(* ############################################### *)
(** * Option polimórfico *)

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

Arguments Some {X} _.
Arguments None {X}.

(** Reescrevendo [nth_error]. *)

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a
               else nth_error l' (pred n)
  end.

Example test_nth_error1 :
  nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 :
  nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 :
  nth_error [true] 2 = None.
Proof. reflexivity. Qed.

(** **** Exercise: (hd_error_poly)  *)
(** Complete a definição polimórfica
    da função [hd_error]. *)

Definition hd_error {X : Type} (l : list X)
           : option X
(* SUBSTITUA COM ":= _sua_definição_ ." *). Admitted.

Example test_hd_error1 :
  hd_error [1;2] = Some 1.
Proof. (* COMPLETE AQUI *) Admitted.

Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
Proof. (* COMPLETE AQUI *) Admitted.

(* ############################################### *)
(** * Leitura sugerida *)

(** Software Foundations: volume 1
  - Polymorphism
  https://softwarefoundations.cis.upenn.edu/lf-current/Poly.html
*)


Set Implicit Arguments.

(* A set of propositional variables. *)
Variable ap: Set.

(* Formulae in intuitionistic and classical propositinal logic. *)
Inductive fml: Set :=
  | fml_var: ap -> fml
  | fml_and: fml -> fml -> fml
  | fml_or: fml -> fml -> fml
  | fml_imp: fml -> fml -> fml
  | fml_bot: fml.

(* Notations.
 * We define level(and) := level( * ) == level(&&), level(or) := level(+) == level(||) and level(==>) slightly lower than +.
 * Since these formulae can't contain arithmetic expressions, there will be no clash.
 *)
Notation "s 'and' t" := (fml_and s t) (at level 40, left associativity).
Notation "s 'or' t" := (fml_or s t) (at level 50, left associativity).
Notation "s ==> t" := (fml_imp s t) (at level 55, right associativity).

Definition fml_not x := x ==> fml_bot.
Definition fml_top := fml_not fml_bot.


Require Import Ensembles.

Section KnasterTarski.
  Variable U : Type.
  Variable f : Ensemble U -> Ensemble U.
  Hypotheses monotone : forall X Y, Included _ X Y -> Included _ (f X) (f Y).

  Definition lfp : Ensemble U := fun x => forall X, Included _ (f X) X -> In _ X x.

  Lemma lfp_lower_bound X : Included _ (f X) X -> Included _ lfp X.
  Proof. intros HIncl ? HIn. apply HIn, HIncl. Qed.

  Lemma lfp_f_closed : Included _ (f lfp) lfp.
  Proof.
    intros ? Hf ? HIncl.
    eapply HIncl, monotone.
    - apply lfp_lower_bound, HIncl.
    - apply Hf.
  Qed.

  Lemma lfp_f_consistent : Included _ lfp (f lfp).
  Proof. intros ? HIn. apply HIn, monotone, lfp_f_closed. Qed.

  Definition gfp : Ensemble U := fun x => exists X, Included _ X (f X) /\ In _ X x.

  Lemma gfp_upper_bound X : Included _ X (f X) -> Included _ X gfp.
  Proof. intros HIncl ? HIn. exists X. eauto. Qed.

  Lemma gfp_f_consistent : Included _ gfp (f gfp).
  Proof.
    intros ? [? [HIncl HIn]].
    eapply monotone.
    - apply gfp_upper_bound, HIncl.
    - eapply HIncl, HIn.
  Qed.

  Lemma gfp_f_closed : Included _ (f gfp) gfp.
  Proof.
    intros ? HIn.
    exists (f gfp). split.
    - apply monotone, gfp_f_consistent.
    - apply HIn.
  Qed.
End KnasterTarski.


Definition N := 14.

Inductive tree : Type :=
| Leaf : tree
| Node : nat -> tree -> tree -> tree.

Fixpoint binary_tree c n :=
  match n with
  | 0 => Leaf
  | S n =>
    let t := binary_tree c n in
    Node c t t
  end.

Definition t0 := Eval vm_compute in binary_tree 0 N.
Definition t1 := Eval vm_compute in binary_tree 1 N.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.
Lemma lem : forall (x : lst) (y : natural), eq (rev (append x (Cons y Nil))) (Cons y (rev x)).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst) (z : natural), eq (rev (append x (append y (Cons z Nil)))) (Cons z (rev (append x y))).
Proof.
induction x.
- intros. simpl. rewrite IHx. reflexivity.
- intros.  simpl. lfind.
Admitted.