(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) TU Dortmund University, Dortmund, Germany
*)

(*
  Problem(s):
    Two-counter Machine Halting (CM2_HALT)
    Two-counter Machine Reversibility (CM2_REV)
    Reversible Two-counter Machine Halting (CM2_REV_HALT)
    Two-counter Machine Uniform Boundedness (CM2_UBOUNDED)
    Two-counter Machine Uniform Mortality (CM2_UMORTAL)
*)

Require Import List ssrfun.

(* a configuration consists of a state and two counter values *)
Definition Config : Set := nat * (nat * nat).

(* accessors for state, value1, value2 of configurations *)
Definition state (x: Config) : nat := fst x.
Arguments state !x /.
Definition value1 (x: Config) : nat := fst (snd x).
Arguments value1 !x /.
Definition value2 (x: Config) : nat := snd (snd x).
Arguments value2 !x /.

(* the instruction inc true maps
      a configuration (p, (v1, v2)) to (1+p, (v1, 1+v2))
    the instruction inc false maps
      a configuration (p, (v1, v2)) (1+p, (1+v1, v2))
    an instruction dec true q maps
      a configuration (p, (v1, 0)) to (1+p, (v1, 0))
      a configuration (p, (v1, 1+v2)) to (q, (v1, v2))
    an instruction dec false q maps
      a configuration (p, (0, v2)) to (1+p, (0, v2))
      a configuration (p, (1+v1, v2)) to (q, (v1, v2)) *)
Inductive Instruction : Set :=
  | inc : bool -> Instruction
  | dec : bool -> nat -> Instruction.

(* a two-counter machine is a list of instructions *)
Definition Cm2 : Set := list Instruction.

(* partial two-counter machine step function *)
Definition step (M: Cm2) (x: Config) : option Config :=
  match nth_error M (state x) with
  | None => None (* halting configuration *)
  | Some (inc b) => (* increase counter, goto next state*)
    Some (1 + (state x), ((if b then 0 else 1) + (value1 x), (if b then 1 else 0) + (value2 x)))
  | Some (dec b y) => (* decrease counter, if successful goto state y *)
    Some (
      if b then
        match value2 x with
        | 0 => (1 + (state x), (value1 x, 0))
        | S n => (y, (value1 x, n))
        end
      else
        match value1 x with
        | 0 => (1 + (state x), (0, value2 x))
        | S n => (y, (n, value2 x))
        end)
  end.

(* iterated partial two-counter machine step function *)
Definition steps (M: Cm2) (k: nat) (x: Config) : option Config :=
  Nat.iter k (obind (step M)) (Some x).

(* two-counter machine configuration reachability *)
Definition reaches (M: Cm2) (x y: Config) :=
  exists k, steps M k x = Some y.

(* does M eventually terminate starting from the configuration x? *)
Definition terminating (M: Cm2) (x: Config) :=
  exists k, steps M k x = None.

(* injectivity of the step function *)
Definition reversible (M : Cm2) : Prop :=
  forall x y z, step M x = Some z -> step M y = Some z -> x = y.

(* k bounds the number of reachable configurations from x *)
Definition bounded (M: Cm2) (k: nat) (x: Config) : Prop :=
  exists (L: list Config), (length L <= k) /\
    (forall (y: Config), reaches M x y -> In y L).

(* uniform bound for number of reachable configurations *)
Definition uniformly_bounded (M: Cm2) : Prop :=
  exists k, forall x, bounded M k x.

(* k bounds the number of steps in a terminating run from x *)
Definition mortal (M: Cm2) (k: nat) (x: Config) : Prop :=
  steps M k x = None.

(* uniform bound for number of steps until termination *)
Definition uniformly_mortal (M: Cm2) : Prop :=
  exists k, forall x, mortal M k x.

(* Two-counter Machine Halting:
   Given a two-counter machine M,
   does a run in M starting from configuration (0, (0, 0)) eventually halt? *)
Definition CM2_HALT : Cm2 -> Prop :=
  fun M => terminating M (0, (0, 0)).

(* Two-counter Machine Reversibility:
   Given a two-counter machine M,
   is the step function of M injective? *)
Definition CM2_REV : Cm2 -> Prop :=
  fun M => reversible M.

(* Reversible Two-counter Machine Halting:
   Given a reversible two-counter machine M and a configucation x,
   does a run in M starting from x eventually halt? *)
Definition CM2_REV_HALT : { M: Cm2 | reversible M } * Config -> Prop :=
  fun '((exist _ M _), x) => terminating M x.

(* Two-counter Machine Uniform Boundedness:
   Given a two-counter machine M,
   is there a uniform bound n,
   such that for any configuration x,
   the number of reacheable configurations from x is bounded by n? *)
Definition CM2_UBOUNDED : Cm2 -> Prop :=
  fun M => uniformly_bounded M.

(* Two-counter Machine Uniform Mortality:
   Given a two-counter machine M,
   is there a uniform bound n,
   such that for any configuration x,
   a run in M starting from x halts after at most n steps? *)
Definition CM2_UMORTAL : Cm2 -> Prop :=
  fun M => uniformly_mortal M.


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export Omega.
Require Export Zwf.
Require Export Relations.
Require Export Inverse_Image.
Require Export Transitive_Closure.

Ltac caseEq f := generalize (refl_equal f); pattern f at -1; case f.

Fixpoint bdiv_aux (b m n:nat){struct b} : nat*nat :=
  match b with
  | O => (0, 0)
  | S b' =>
      match le_gt_dec n m with
      | left H =>
          match bdiv_aux b' (m-n) n with
          | pair q r => (S q, r)
          end
      | right H => (0, m)
      end
  end.

Theorem bdiv_aux_correct1 :
 forall b m n:nat, m <= b -> 0 < n ->
 m = fst (bdiv_aux b m n) * n + snd (bdiv_aux b m n).
Proof.
 intros b; elim b; simpl.
 intros m n Hle; inversion Hle; auto.
 intros b' Hrec m n Hleb Hlt; case (le_gt_dec n m); simpl; auto.
 intros Hle; generalize (Hrec (m-n) n);
  case (bdiv_aux b' (m-n) n); simpl; intros q r Hrec'.
 rewrite <- plus_assoc; rewrite <- Hrec'; auto with arith.
 omega.
Qed.

Hypothesis bdiv_aux_correct2 :
 forall b m n:nat, m <= b -> 0 < n -> snd (bdiv_aux b m n) < n.

Definition bdiv :
  forall m n:nat, 0 < n -> {q:nat &{r:nat | m = q*n+r /\ r < n}}.
 refine
  (fun (m n:nat)(h:0 < n) =>
    let p := bdiv_aux m m n in
    existS (fun q:nat => {r : nat | m = q*n+r /\ r < n})
      (fst p)(exist _ (snd p) _)).
 unfold p; split.
 apply bdiv_aux_correct1; auto.
 intros; eapply bdiv_aux_correct2; eauto.
Defined.

Time Eval lazy beta iota zeta delta in (bdiv_aux 2000 2000 31).

Time Eval lazy beta delta iota zeta in
  match bdiv 2000 31 (lt_O_Sn 30) with
    existS q (exist r h) => (q,r)
  end.

Require Import Lt.

Theorem lt_Acc : forall n:nat, Acc lt n.
Proof.
 induction n.
 split; intros p H; inversion H.
 split.
 intros y H0.
 case (le_lt_or_eq _ _ H0).
 intro; apply Acc_inv with n; auto with arith.
 intro e; injection e; intro e1; rewrite e1; assumption.
Qed.

Theorem lt_wf : well_founded lt.
Proof.
 exact lt_Acc.
Qed.

Inductive Rpos_div2 : positive->positive->Prop :=
  Rpos1 : forall x:positive, Rpos_div2 x (xO x)
| Rpos2 : forall x:positive, Rpos_div2 x (xI x).
Theorem Rpos_div2_wf : well_founded Rpos_div2.
Proof.
 unfold well_founded; intros a; elim a;
  (intros; apply Acc_intro; intros y Hr; inversion Hr; auto).
Qed.

Definition div_type (m:nat) :=
  forall n:nat, 0 < n -> {q:nat &{r:nat | m = q*n+r /\ r < n}}.

Definition div_type' (m n q:nat) :=
  {r:nat | m = q*n+r /\ r < n}.

Definition div_type'' (m n q r:nat) := m = q*n+r /\ r < n.

Definition div_F :
  forall x:nat, (forall y:nat, y < x -> div_type y) -> div_type x.
 unfold div_type at 2.
 refine
  (fun m div_rec n Hlt =>
     match le_gt_dec n m with
     | left H_n_le_m =>
         match div_rec (m-n) _ n _ with
         | existS q (exist r H_spec) =>
             existS (div_type' m n)(S q)
               (exist (div_type'' m n (S q)) r _)
         end
     | right H_n_gt_m =>
         existS (div_type' m n) 0
            (exist (div_type'' m n 0) m _)
     end); unfold div_type''; auto with arith.
  elim H_spec; intros H1 H2; split; auto.
 rewrite (le_plus_minus n m H_n_le_m); rewrite H1; ring.
Qed.

Definition div :
  forall m n:nat, 0 < n -> {q:nat &{r:nat | m = q*n+r /\ r < n}} :=
  well_founded_induction lt_wf div_type div_F.

Parameter div2 : nat->nat.
Axiom div2_le : forall n:nat, div2 n <= n.
Hypothesis double_div2_le : forall x:nat, div2 x + div2 x <= x.

Hypothesis f_lemma :
  forall x v:nat, v <= div2 x -> div2 x + v <= x.

Hint Resolve div2_le f_lemma double_div2_le.

Definition nested_F :
  forall x:nat, (forall y:nat, y < x->{v:nat|v <= y})->{v:nat | v <= x}.
refine
  (fun x => match x return (forall y:nat, y < x ->{v:nat | v <= y})->
                          {v:nat | v <= x} with
              O => fun f => exist _ 0 _
            | S x' =>
              fun f => match f (div2 x') _ with
                        exist v H1 =>
                        match f (div2 x' + v) _ with
                          exist v1 H2 => exist _ (S v1) _
                        end
                      end
            end); auto with arith.
  apply le_n_S.
  eauto with arith.
Defined.

Definition nested_f :=
  well_founded_induction
    lt_wf (fun x:nat => {v:nat | v <= x}) nested_F.

Definition div_it_F (f:nat->nat->nat*nat)(m n:nat) :=
  match le_gt_dec n m with
  | left _ => let (q, r) := f (m-n) n in (S q, r)
  | right _ => (0, m)
  end.

Fixpoint iter (A:Set)(n:nat)(F:A->A)(g:A){struct n} : A :=
  match n with O => g | S p => F (iter A p F g) end.

Implicit Arguments iter [A].

Definition div_it_terminates :
  forall n m:nat, 0 < m ->
    {v:nat*nat |
     exists p:nat,
      (forall k:nat, p < k -> forall g:nat->nat->nat*nat,
           iter k div_it_F g n m = v)}.
 intros n; elim n using (well_founded_induction lt_wf).
 intros n' Hrec m Hlt.
 caseEq (le_gt_dec m n'); intros H Heq_test.
 case Hrec with (y := n'-m)(2 := Hlt); auto with arith.
 intros [q r]; intros Hex; exists (S q, r).
 elim Hex; intros p Heq.
 exists (S p).
 intros k.
 case k.
 intros; elim (lt_n_O (S p)); auto.
 intros k' Hplt g; simpl; unfold div_it_F at 1.
 rewrite Heq; auto with arith.
 rewrite Heq_test; auto.
 exists (0, n'); exists 0; intros k; case k.
 intros; elim (lt_irrefl 0); auto.
 intros k' Hltp g; simpl; unfold div_it_F at 1.
 rewrite Heq_test; auto.
Defined.

Definition div_it (n m:nat)(H:0 < m) : nat*nat :=
  let (v, _) := div_it_terminates n m H in v.

Definition max (m n:nat) : nat :=
  match le_gt_dec m n with left _ => n | right _ => m end.

Theorem max1_correct : forall n m:nat, n <= max n m.
 intros n m; unfold max; case (le_gt_dec n m); auto with arith.
Qed.

Theorem max2_correct : forall n m:nat, m <= max n m.
 intros n m; unfold max; case (le_gt_dec n m); auto with arith.
Qed.

Hint Resolve max1_correct max2_correct : arith.

Theorem div_it_fix_eqn :
 forall (n m:nat)(h:(0 < m)),
   div_it n m h =
   match le_gt_dec m n with
   | left H => let (q,r) := div_it (n-m) m h in (S q, r)
   | right H => (0, n)
   end.
Proof.
 intros n m h.
 unfold div_it; case (div_it_terminates n m h).
 intros v Hex1; case (div_it_terminates (n-m) m h).
 intros v' Hex2.
 elim Hex2; elim Hex1; intros p Heq1 p' Heq2.
 rewrite <- Heq1 with
     (k := S (S (max p p')))(g := fun x y:nat => v).
 rewrite <- Heq2 with (k := S (max p p'))(g := fun x y:nat => v).
 reflexivity.
 eauto with arith.
 eauto with arith.
Qed.

Theorem div_it_correct1 :
 forall (m n:nat)(h:0 < n),
   m = fst (div_it m n h) * n + snd (div_it m n h).
Proof.
 intros m; elim m using (well_founded_ind lt_wf).
 intros m' Hrec n h; rewrite div_it_fix_eqn.
 case (le_gt_dec n m'); intros H; trivial.
 pattern m' at 1; rewrite (le_plus_minus n m'); auto.
 pattern (m'-n) at 1.
 rewrite Hrec with (m'-n) n h; auto with arith.
 case (div_it (m'-n) n h); simpl; auto with arith.
Qed.

Reset div2.

Fixpoint div2 (n:nat) : nat :=
  match n with S (S p) => S (div2 p) | _ => 0 end.

Inductive log_domain : nat->Prop :=
  log_domain_1 : log_domain 1
| log_domain_2 :
    forall p:nat, log_domain (S (div2 p))-> log_domain (S (S p)).

Theorem log_domain_non_O : forall x:nat, log_domain x -> x <> 0.
Proof.
 intros x H; case H; intros; discriminate.
Qed.

Theorem log_domain_inv :
 forall x p:nat, log_domain x -> x = S (S p)-> log_domain (S (div2 p)).
Proof.
 intros x p H; case H; try (intros H'; discriminate H').
 intros p' H1 H2; injection H2; intros H3;
 rewrite <- H3; assumption.
Defined.

Fixpoint log (x:nat)(h:log_domain x){struct h} : nat :=
  match x as y return x = y -> nat with
  | 0 => fun h' => False_rec nat (log_domain_non_O x h h')
  | S 0 => fun h' => 0
  | S (S p) =>
       fun h' => S (log (S (div2 p))(log_domain_inv x p h h'))
  end (refl_equal x).

Inductive log2_domain : nat->Prop :=
  l21 : log2_domain 1
| l22 : forall x:nat,
        x <> 1 -> x <> 0 -> log2_domain (div2 x) -> log2_domain x.

Hypothesis log2_domain_non_zero : forall x:nat, log2_domain x -> x <> 0.

Theorem log2_domain_invert :
 forall x:nat, log2_domain x -> x <> 0 -> x <> 1 -> log2_domain (div2 x).
Proof.
 intros x h; case h.
 intros h1 h2; elim h2; reflexivity.
 intros; assumption.
Defined.

Fixpoint log2 (x:nat)(h:log2_domain x){struct h} : nat :=
  match eq_nat_dec x 0 with
  | left heq => False_rec nat (log2_domain_non_zero x h heq)
  | right hneq =>
      match eq_nat_dec x 1 with
      | left heq1 => 0
      | right hneq1 =>
          S (log2 (div2 x)(log2_domain_invert x h hneq hneq1))
      end
  end.
Scheme log_domain_ind2 := Induction for log_domain Sort Prop.

Fixpoint two_power (n:nat) : nat :=
  match n with
  | O => 1
  | S p => 2 * two_power p
  end.

Section proof_on_log.

 Hypothesis mult2_div2_le : forall x:nat, 2 * div2 x <= x.

Theorem pow_log_le :
 forall (x:nat)(h:log_domain x), two_power (log x h) <= x.
Proof.
 intros x h; elim h using log_domain_ind2.
 simpl; auto with arith.

 intros p l Hle.
 lazy beta iota zeta delta [two_power log_domain_inv log];
  fold log two_power.
 apply le_trans with (2 * S (div2 p)); auto with arith.
 exact (mult2_div2_le (S (S p))).
Qed.

End proof_on_log.

Section little_semantics.
Variables Var aExp bExp : Set.
Inductive inst : Set :=
  | Skip : inst
  | Assign : Var->aExp->inst
  | Sequence : inst->inst->inst
  | WhileDo : bExp->inst->inst.

Variables (state : Set)(evalA : state->aExp->option Z)
  (evalB : state -> bExp -> option bool)
  (exec : state->inst->state->Prop).
Open Scope Z_scope.

Definition extract_option (A:Set)(x:option A)(def:A) : A :=
  match x with
  | None => def
  | Some v => v
  end.
Implicit Arguments extract_option [A].
Implicit Arguments Some [A].

Inductive forLoops : inst->Prop :=
  | aForLoop :
      forall (e:bExp)(i:inst)(variant:aExp),
        (forall s s':state,
           evalB s e = Some true -> exec s i s' ->
           Zwf 0 (extract_option (evalA s' variant) 0)
             (extract_option (evalA s variant) 0))->
        forLoops i -> forLoops (WhileDo e i)
  | assignFor : forall (v:Var)(e:aExp), forLoops (Assign v e)
  | skipFor : forLoops Skip
  | sequenceFor :
      forall i1 i2:inst,
        forLoops i1 -> forLoops i2 -> forLoops (Sequence i1 i2).

End little_semantics.


From mathcomp Require Import ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import function.

Section FunctionTheories.

  Variable U:Type.
  Variable F: U -> U.
  Variables A B: Ensemble U.

  Theorem union_function_domain:
    forall (f:Ensemble (Ensemble (Ensemble U))) (X Y:Ensemble U),
      (f ≔ F ⊦ A ⟼ B) -> f '' (X ∪ Y) = (f '' X) ∪ (f '' Y).
  Proof.
    move => f X Y [Hf HfS].
    move: union_of_image_of_correspondence_eq => H.
    apply (H U (fun x y:U => y = F x) A B X Y f).
    apply Hf.
  Qed.

  Theorem union_inversion_mapping_domain:
    forall (f:Ensemble (Ensemble (Ensemble U))) (X Y:Ensemble U),
      (f ≔ F ⊦ A ⟼ B) -> f^-1 '' (X ∪ Y) = (f^-1 '' X) ∪ (f^-1 '' Y).
  Proof.
    move => f X Y H.
    inversion H as [Hf HfS].
    apply /Extensionality_Ensembles.
    +split => x H0.
     inversion H0 as [x0 [y0 H1]].
     rewrite -H2 in H1.
     inversion H1.
     inversion H3 as [y0' | y0'].
     inversion H4 as [x1 y1].
     ++left.
       split.
       exists y0.
       split.
       apply H5.
       rewrite -H2.
       rewrite -H8.
       split.
       apply H7.
     ++right.
       split.
       exists y0.
       split.
       apply H5.
       rewrite -H2.
       apply H4.
    +split.
     ++inversion H0.
       inversion H1 as [x0'].
       inversion H3 as [y].
       inversion H5.
       inversion H7 as [x1 y1].
       exists y.
       split.
       left.
       apply H6.
       apply H7.
     ++inversion H1 as [x0'].
       inversion H3 as [y].
       inversion H5.
       exists y.
       split.
       right.
       apply H6.
       apply H7.
  Qed.

  Theorem intersction_inversion_mapping_domain:
    forall (f:Ensemble (Ensemble (Ensemble U))) (X Y:Ensemble U),
      (f ≔ F ⊦ A ⟼ B) -> f^-1 '' (X ∩ Y) = (f^-1 '' X) ∩ (f^-1 '' Y).
  Proof.
    move => f X Y H.
    unfold Mapping in H.
    inversion H as [Hf HfS].
    rewrite Hf.
    apply /Extensionality_Ensembles.
    split => x H0.
    +inversion H0 as [x'].
     inversion H1 as [y].
     inversion H3.
     inversion H4 as [y'].
     split; split; exists y; split.
     apply H6.
     apply H5.
     apply H7.
     apply H5.
    +inversion H0 as [x'].
     inversion H1 as [x0].
     inversion H4 as [y].
     inversion H6.
     inversion H2 as [x0'].
     inversion H9 as [y'].
     inversion H11.
     inversion H8 as [x2 y2].
     inversion H14.
     inversion H13 as [x3 y3].
     inversion H18 as [x3' y3'].
     inversion H17.
     inversion H20.
     apply ordered_pair_iff in H15.
     inversion H15.
     apply ordered_pair_iff in H16.
     inversion H16.
     apply ordered_pair_iff in H19.
     inversion H19.
     apply ordered_pair_iff in H21.
     inversion H21.
     rewrite H28 in H22.
     rewrite H32 in H24.
     rewrite H27 in H22.
     rewrite H31 in H24.
     rewrite -H22 in H24.
     rewrite H33 in H24.
     rewrite H30 in H24.
     rewrite H29 in H24.
     rewrite H26 in H24.
     rewrite H24 in H12.
     split.
     exists y.
     split.
     split.
     apply H7.
     apply H12.
     rewrite H24 in H13.
     apply H13.
  Qed.

  Theorem included_image:
    forall (f:Ensemble (Ensemble (Ensemble U))) (A':Ensemble U),
      (f ≔ F ⊦ A ⟼ B) /\ A' ⊂ A -> f '' A' ⊂ f '' A.
  Proof.
    move: included_domain_to_included_image => H.
    move => f A'.
    case => [[Hf HfS] H0].
    apply (H U (fun x y:U => y = F x) A B f A' A).
    apply Hf.
    split; done.
  Qed.

  Theorem if_mapping_is_injection_then_inverse_mapping_is_unique:
    forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ F ⊦ A ⟼ B /\ Injection f -> forall (y x0 x1:U), (|y, x0|) ∈ f^-1 /\ (|y, x1|) ∈ f^-1 -> x0 = x1.
  Proof.
    move => f.
    case => [H HIf].
    move => y x0 x1.
    case => H0 H1.
    inversion H0.
    inversion H1.
    apply ordered_pair_swap in H2.
    apply ordered_pair_swap in H4.
    rewrite H2 in H3.
    rewrite H4 in H5.
    apply (HIf x0 x1 y).
    split.
    apply H3.
    apply H5.
  Qed.

  Theorem if_mapping_is_bijection_then_inverse_mapping_is_bijection:
    forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ F ⊦ A ⟼ B /\ Bijection f B -> 𝕯( f^-1 ) = B /\ 𝕽( f^-1 ) = A /\ Bijection (f^-1) A.
  Proof.
    move => f.
    case => Hf0 [ HSfI HSfB ].
    inversion Hf0 as [Hf HfS].
    +split.
     apply /Extensionality_Ensembles.
     ++split => y.
       move => H.
       inversion H as [y' ].
       inversion H0 as [y''].
       inversion H2 as [x].
       inversion H4.
       rewrite Hf in H6.
       inversion H6.
       inversion H8.
       rewrite H7 in H10.
       apply ordered_pair_swap in H5.
       rewrite H5 in H10.
       apply ordered_pair_in_direct_product_iff_and in H10.
       inversion H10.
       apply H12.
     ++move => HB.
       split.
       split.
       +++suff: exists x:U, (|x,y|) ∈ f.
          move => H0.
          inversion H0.
          exists x.
          split.
          apply H.
          apply HSfB.
     --apply HB.
    +split.
     apply /Extensionality_Ensembles.
     split => x.
    +move => HyRfi.
     inversion HyRfi as [x0].
     inversion H as [y0].
     inversion H1 as [y0'].
     inversion H3 as [x1 y1].
     apply ordered_pair_swap in H5.
     rewrite H5 in H4.
     rewrite Hf in H4.
     inversion H4.
     inversion H7.
     rewrite H6 in H9.
     apply ordered_pair_in_direct_product_iff_and in H9.
     inversion H9.
     apply H10.
    +move => HA.
     split.
     split.
     ++suff: exists y:U, (|x,y|) ∈ f.
       move => H0.
       inversion H0 as [y].
       exists y.
       split.
       apply H.
    -apply HfS.
     apply HA.
     split.
     move => y y' x.
     case => H0 H1.
     inversion H0.
     inversion H1.
     apply ordered_pair_swap in H.
     apply ordered_pair_swap in H3.
     rewrite Hf in H2.
     rewrite Hf in H4.
     inversion H2.
     inversion H6.
     inversion H4.
     inversion H10.
     rewrite H in H5.
     apply ordered_pair_iff in H.
     inversion H.
     apply ordered_pair_iff in H3.
     inversion H3.
     apply ordered_pair_iff in H5.
     inversion H5.
     apply ordered_pair_iff in H9.
     inversion H9.
     rewrite -H18.
     rewrite H7.
     rewrite H17.
     rewrite -H16.
     rewrite -H20.
     rewrite H11.
     rewrite H19.
     rewrite H15.
     reflexivity.
    +move => x HA.
     ++suff: exists y:U, (|x,y|) ∈ f.
       move => H0.
       inversion H0 as [y].
       exists y.
       split.
       apply H.
    -apply HfS.
     apply HA.
  Qed.

End FunctionTheories.

Require Export function.


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

Require Import List Arith.

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac utils_nat pos vec.

From Undecidability.MuRec
  Require Import recalg ra_utils recomp ra_recomp.

From Undecidability.H10.Dio
  Require Import dio_single.

Set Implicit Arguments.

Set Default Proof Using "Type".

Local Notation "'⟦' f '⟧'" := (@ra_rel _ f) (at level 0).

Section dio_poly.

  Variable (n m : nat).

  Fixpoint ra_dio_poly (p : dio_polynomial (pos n) (pos m)) : recalg (n+m).
  Proof.
    destruct p as [ c | i | x | [] p q ].
    + apply ra_cst_n, c.
    + apply ra_proj, pos_left, i.
    + apply ra_proj, pos_right, x.
    + apply ra_comp with (1 := ra_plus), (ra_dio_poly p##ra_dio_poly q##vec_nil).
    + apply ra_comp with (1 := ra_mult), (ra_dio_poly p##ra_dio_poly q##vec_nil).
  Defined.

  Fact ra_dio_poly_prim p : prim_rec (ra_dio_poly p).
  Proof.
    induction p as [ | | | [] ]; simpl; repeat (split; auto);
      intros j; analyse pos j; simpl; auto.
  Qed.

  Opaque ra_cst_n ra_plus ra_mult ra_inject ra_project ra_eq.

  Section ra_dio_poly_eval.

    Variable (v : vec nat (n+m)).

    Notation φ := (fun i => vec_pos v (pos_left _ i)).
    Notation ν := (fun i => vec_pos v (pos_right _ i)).

    Fact ra_dio_poly_val p : ⟦ra_dio_poly p⟧ v (dp_eval φ ν p).
    Proof.
      induction p as [ c | i | x | [] p Hp q Hq ]; simpl.
      + apply ra_cst_n_val.
      + cbv; auto.
      + cbv; auto.
      + exists (dp_eval φ ν p ## dp_eval φ ν q ## vec_nil); split.
        * apply ra_plus_val.
        * intros j; analyse pos j; simpl; auto.
      + exists (dp_eval φ ν p ## dp_eval φ ν q ## vec_nil); split.
        * apply ra_mult_val.
        * intros j; analyse pos j; simpl; auto.
    Qed.

    Variable (p q : dio_polynomial (pos n) (pos m)).

    Definition ra_dio_poly_eq : recalg (n+m).
    Proof using p q.
      apply ra_comp with (1 := ra_eq).
      refine (_##_##vec_nil); apply ra_dio_poly.
      + exact p.
      + exact q.
    Defined.

    Hint Resolve ra_dio_poly_prim : core.

    Fact ra_dio_poly_eq_prim : prim_rec ra_dio_poly_eq.
    Proof.
      simpl; split; auto.
      intros j; analyse pos j; auto.
    Qed.

    Fact ra_dio_poly_eq_val : { e | ⟦ra_dio_poly_eq⟧ v e /\ (e = 0 <-> dp_eval φ ν p = dp_eval φ ν q) }.
    Proof.
      destruct ra_eq_rel with (v := dp_eval φ ν p ## dp_eval φ ν q ## vec_nil) as (e & H1 & H2); simpl in H2.
      exists e; split; auto.
      simpl.
      exists (dp_eval φ ν p ## dp_eval φ ν q ## vec_nil); split; auto.
      intros i; analyse pos i; simpl; apply ra_dio_poly_val.
    Qed.

    Opaque ra_dio_poly_eq.

    Hint Resolve ra_dio_poly_eq_prim : core.

    Definition ra_dio_poly_test : recalg (S m).
    Proof using p q.
      apply ra_comp with (1 := ra_dio_poly_eq).
      apply vec_set_pos; intros i.
      destruct (pos_both _ _ i) as [ j | j ].
      + apply ra_comp with (1 := ra_project j), (ra_proj pos0 ## vec_nil).
      + apply ra_proj, pos_nxt, j.
    Defined.

    Fact ra_dio_poly_test_prim : prim_rec ra_dio_poly_test.
    Proof.
      simpl; split; auto.
      intros i.
      rewrite vec_pos_set.
      destruct (pos_both n m i).
      + simpl; split; auto.
        intros j; analyse pos j; simpl; auto.
      + simpl; auto.
    Qed.

    Fact ra_dio_poly_test_total : total ⟦ra_dio_poly_test⟧.
    Proof. apply prim_rec_tot, ra_dio_poly_test_prim. Qed.

  End ra_dio_poly_eval.

  Notation φ := (fun x w i => vec_pos (vec_app (project n x) w) (pos_left _ i)).
  Notation ν := (fun x w i => vec_pos (vec_app (project n x) w) (pos_right _ i)).

  Variable (p q : dio_polynomial (pos n) (pos m)).

  Fact ra_dio_poly_test_val x w : { e | ⟦ra_dio_poly_test p q⟧ (x##w) e /\ (e = 0 <-> dp_eval (φ x w) (ν x w) p
                                                                                = dp_eval (φ x w) (ν x w) q) }.
  Proof.
    destruct (ra_dio_poly_eq_val (vec_app (project n x) w) p q) as (e & H1 & H2).
    exists e; split; auto.
    exists (vec_app (project n x) w); split; auto.
    intros i; repeat rewrite vec_pos_set.
    generalize (pos_lr_both n m i).
    destruct (pos_both n m i) as [ j | j ]; intros Hj; subst i; simpl.
    * unfold vec_app; rewrite vec_pos_set, pos_both_left.
      exists (x##vec_nil); split.
      - apply ra_project_val.
      - intros k; analyse pos k; simpl; cbv; auto.
    * unfold vec_app; rewrite vec_pos_set, pos_both_right; reflexivity.
  Qed.

  Fact ra_dio_poly_test_rel v e : ⟦ra_dio_poly_test p q⟧ v e
                               -> e = 0 <-> dp_eval (φ (vec_head v) (vec_tail v))
                                                    (ν (vec_head v) (vec_tail v)) p
                                          = dp_eval (φ (vec_head v) (vec_tail v))
                                                    (ν (vec_head v) (vec_tail v)) q.
  Proof.
    vec split v with x; intros H; simpl vec_head; simpl vec_tail.
    destruct (ra_dio_poly_test_val x v) as (e' & H1 & H2).
    rewrite <- H2; clear H2.
    generalize (ra_rel_fun _ _ _ _ H H1); intros []; tauto.
  Qed.

  Opaque ra_dio_poly_test.

  Definition ra_dio_poly_find : recalg m.
  Proof using p q. apply ra_min, (ra_dio_poly_test p q). Defined.

  Lemma ra_dio_poly_find_rel w : (exists e, ⟦ra_dio_poly_find⟧ w e) <-> exists x, ⟦ra_dio_poly_test p q⟧ (x##w) 0.
  Proof.
    simpl; unfold s_min.
    apply μ_min_of_total.
    + intros ? ? ?; apply ra_rel_fun.
    + intros x; destruct (ra_dio_poly_test_val x w) as (e & ? & _).
      exists e; auto.
  Qed.

  (* ra_dio_poly_find terminates on w iff some solution of p(w,x1,...,xn) = q(w,x1,...,xn) exists

      so termination of ra_dio_poly_find terminates on w simulates the existence of a solution
      to a given diophantine equation *)

  Theorem ra_dio_poly_find_spec w :  ex (⟦ra_dio_poly_find⟧ w)
                                <-> exists v, dp_eval (vec_pos v) (vec_pos w) p
                                            = dp_eval (vec_pos v) (vec_pos w) q.
  Proof.
    rewrite ra_dio_poly_find_rel; split.
    + intros (x & Hx).
      destruct (ra_dio_poly_test_val x w) as (e & H1 & H2).
      generalize (ra_rel_fun _ _ _ _ H1 Hx); rewrite H2.
      exists (project n x); auto.
      eq goal H; f_equal; apply dp_eval_ext; intro; try rewrite vec_pos_app_left; auto;
        rewrite vec_pos_app_right; auto.
    + intros (v & Hv).
      exists (inject v).
      destruct (ra_dio_poly_test_val (inject v) w) as (e & H1 & H2).
      rewrite project_inject in H2.
      assert (e=0); try (subst; auto; fail).
      apply H2.
      eq goal Hv; f_equal; apply dp_eval_ext; intro; try rewrite vec_pos_app_left; auto;
        rewrite vec_pos_app_right; auto.
  Qed.

End dio_poly.

Opaque ra_dio_poly_find.

Section dio_ra_enum.

  (* Given p = q in dio_eq (pos 1) (pos m), given a total
     µ-rec function of type recalg 1 that enumerates the solutions

     given n compute x#w in vec nat (1+m). Compute
     p[x][w] = q[x][w]. If equal, return (S x), otherwise return 0 *)

   Variable (m : nat) (p q : dio_polynomial (pos m) (pos 1)).

   Let f := ra_dio_poly_test p q.

   Let Hf x w : {e : nat |
       ⟦ f ⟧ (x ## w) e /\
       (e = 0 <->
        dp_eval
          (fun i => vec_pos (vec_app (project m x) w) (pos_left 1 i))
          (fun i => vec_pos (vec_app (project m x) w) (pos_right m i))
          p =
        dp_eval
          (fun i => vec_pos (vec_app (project m x) w) (pos_left 1 i))
          (fun i => vec_pos (vec_app (project m x) w) (pos_right m i)) q) }.
  Proof. apply ra_dio_poly_test_val. Qed.

  Opaque f.

  Let g : recalg 1.
  Proof.
    apply ra_comp with (1 := ra_ite).
    refine (_##_##_##vec_nil).
    + apply ra_comp with (1 := f), ra_vec_project.
    + apply ra_comp with (1 := ra_succ).
      refine (_##vec_nil).
      apply (@ra_project 2 pos1).
    + apply ra_cst_n, 0.
  Defined.

  Opaque ra_decomp_l ra_decomp_r ra_project.

  Let Hg0 : prim_rec g.
  Proof.
    simpl; split; auto.
    intros j; analyse pos j; auto.
    + simpl; split; auto.
      * apply ra_dio_poly_test_prim.
      * intros j; analyse pos j; simpl; auto; split; auto.
    + simpl; split; auto.
      intros j; analyse pos j; auto.
  Qed.

  Let Hg1 x : ex (⟦g⟧ (x##vec_nil)).
  Proof. apply prim_rec_tot; auto. Qed.

  (* Not a very nice proof ... *)

  Let Hg x : (exists n, ⟦g⟧ (n##vec_nil) (S x)) <-> exists w, dp_eval (vec_pos w) (fun _ => x) p
                                                            = dp_eval (vec_pos w) (fun _ => x) q.
  Proof.
    split.
    + intros (n & w & H1 & H2).
      apply ra_ite_rel in H1.
      generalize (H2 pos0) (H2 pos1) (H2 pos2).
      clear H2; revert H1.
      repeat rewrite vec_pos_set.
      vec split w with a; vec split w with b; vec split w with c; vec nil w; clear w.
      simpl; intros H1 H2 H3 H4.
      destruct H3 as (w & H3 & H5).
      generalize (H5 pos0); revert H3; clear H5.
      vec split w with d; vec nil w; clear w; simpl; intros H3 H5.
      apply ra_project_rel in H5; simpl in H5.
      destruct H4 as (w & H4 & _); red in H4; clear w.
      destruct H2 as (w & H2 & H6).
      generalize (H6 pos0) (H6 pos1); clear H6.
      revert H2; vec split w with u; vec split w with v; vec nil w; clear w; simpl.
      intros H2 H6 H7.
      apply ra_project_rel in H6.
      apply ra_project_rel in H7.
      simpl in H5, H6, H7.
      subst c b d u v.
      apply ra_dio_poly_test_rel in H2; simpl in H2.
      exists (project m (decomp_l n)).
      apply proj1 in H2.
      destruct a; try discriminate.
      simpl in H1; injection H1; clear H1; intros H1.
      specialize (H2 eq_refl); subst x.
      eq goal H2; f_equal; apply dp_eval_ext;
        try (intros; rewrite vec_pos_app_left; auto);
        intros j _; analyse pos j; rewrite vec_pos_app_right; simpl; auto.
    + intros (w & Hw).
      destruct (Hf (inject w) (x##vec_nil)) as (e & H1 & H2).
      assert (e = 0) as He.
      { apply H2.
        eq goal Hw; f_equal; apply dp_eval_ext;
          try (intros j _; rewrite vec_pos_app_left; rewrite project_inject; auto);
          intros j _; analyse pos j; rewrite vec_pos_app_right; simpl; auto. }
      clear H2; subst e.
      exists (inject (inject w##x##vec_nil)).
      unfold g.
      exists (0##S x##0##vec_nil); split.
      * apply ra_ite_rel; simpl; auto.
      * intros j; rewrite vec_pos_set; analyse pos j; simpl.
        - exists (inject w ## x ## vec_nil); split; auto.
          intros j; analyse pos j; simpl.
          { apply ra_project_rel; simpl.
            rewrite decomp_l_recomp; auto. }
          { apply ra_project_rel; simpl.
            rewrite decomp_r_recomp, decomp_l_recomp; auto. }
        - exists (x##vec_nil); split; try (red; auto; fail).
          intros j; analyse pos j; simpl.
          apply ra_project_rel; simpl.
          rewrite decomp_r_recomp, decomp_l_recomp; auto.
        - exists vec_nil; split; try (red; auto; fail).
          intros j; analyse pos j.
  Qed.

  Theorem dio_poly_eq_2_ra_prim :
          { g : recalg 1 | prim_rec g
               /\ forall x, (exists n, ⟦g⟧ (n##vec_nil) (S x))
                         <-> exists w, dp_eval (vec_pos w) (fun _ => x) p
                                     = dp_eval (vec_pos w) (fun _ => x) q }.
  Proof. exists g; split; auto. Qed.

End dio_ra_enum.


Require Import init.

Require Import linear_base.

(* TODO: Deal with multilinear functions in general *)
Definition bilinear {U V1 V2 V3} `{
    Plus V1, Plus V2, Plus V3,
    ScalarMult U V1,
    ScalarMult U V2,
    ScalarMult U V3
} (f : V1 → V2 → V3) :=
    (∀ a v1 v2, f (a · v1) v2 = a · (f v1 v2)) ∧
    (∀ a v1 v2, f v1 (a · v2) = a · (f v1 v2)) ∧
    (∀ v1 v2 v3, f (v1 + v2) v3 = f v1 v3 + f v2 v3) ∧
    (∀ v1 v2 v3, f v1 (v2 + v3) = f v1 v2 + f v1 v3).

(* begin hide *)
Section Bilinear.

Context {U V1 V2 V3} `{
    UP : Plus U,
    UZ : Zero U,
    UN : Neg U,
    UO : One U,
    @PlusComm U UP,
    @PlusLid U UP UZ,
    @PlusLinv U UP UZ UN,

    V1P : Plus V1,
    V1Z : Zero V1,
    V1N : Neg V1,
    UV1 : ScalarMult U V1,
    @PlusComm V1 V1P,
    @PlusAssoc V1 V1P,
    @PlusLid V1 V1P V1Z,
    @PlusLinv V1 V1P V1Z V1N,
    @ScalarId U V1 UO UV1,
    @ScalarRdist U V1 UP V1P UV1,

    V2P : Plus V2,
    V2Z : Zero V2,
    V2N : Neg V2,
    UV2 : ScalarMult U V2,
    @PlusComm V2 V2P,
    @PlusAssoc V2 V2P,
    @PlusLid V2 V2P V2Z,
    @PlusLinv V2 V2P V2Z V2N,
    @ScalarId U V2 UO UV2,
    @ScalarRdist U V2 UP V2P UV2,

    V3P : Plus V3,
    V3Z : Zero V3,
    V3N : Neg V3,
    UV3 : ScalarMult U V3,
    @PlusComm V3 V3P,
    @PlusAssoc V3 V3P,
    @PlusLid V3 V3P V3Z,
    @PlusLinv V3 V3P V3Z V3N,
    @ScalarId U V3 UO UV3,
    @ScalarRdist U V3 UP V3P UV3
}.
(* end hide *)
Variables (f : V1 → V2 → V3) (f_bil : bilinear f).

Theorem bilinear_lscalar : ∀ a v1 v2, f (a · v1) v2 = a · (f v1 v2).
Proof.
    apply f_bil.
Qed.

Theorem bilinear_rscalar : ∀ a v1 v2, f v1 (a · v2) = a · (f v1 v2).
Proof.
    apply f_bil.
Qed.

Theorem bilinear_rdist : ∀ v1 v2 v3, f (v1 + v2) v3 = f v1 v3 + f v2 v3.
Proof.
    apply f_bil.
Qed.

Theorem bilinear_ldist : ∀ v1 v2 v3, f v1 (v2 + v3) = f v1 v2 + f v1 v3.
Proof.
    apply f_bil.
Qed.

Theorem bilinear_lanni : ∀ v, f 0 v = 0.
Proof.
    intros v.
    rewrite <- (scalar_lanni 0).
    rewrite bilinear_lscalar.
    apply scalar_lanni.
Qed.

Theorem bilinear_ranni : ∀ v, f v 0 = 0.
Proof.
    intros v.
    rewrite <- (scalar_lanni 0).
    rewrite bilinear_rscalar.
    apply scalar_lanni.
Qed.

Theorem bilinear_lneg : ∀ u v, f (-u) v = -(f u v).
Proof.
    intros u v.
    rewrite <- scalar_neg_one.
    rewrite bilinear_lscalar.
    rewrite scalar_neg_one.
    reflexivity.
Qed.

Theorem bilinear_rneg : ∀ u v, f u (-v) = -(f u v).
Proof.
    intros u v.
    rewrite <- scalar_neg_one.
    rewrite bilinear_rscalar.
    rewrite scalar_neg_one.
    reflexivity.
Qed.
(* begin hide *)
End Bilinear.
(* end hide *)


Require Import XR_Rsqr.
Require Import XR_Rmult_comm.
Require Import XR_Rmult_assoc.
Require Import XR_Rmult_eq_compat_l.
Require Import XR_Rmult_eq_compat_r.

Local Open Scope R_scope.

Lemma Rsqr_mult : forall x y:R, Rsqr (x * y) = Rsqr x * Rsqr y.
Proof.
  intros x y.
  unfold Rsqr.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  repeat rewrite <- Rmult_assoc.
  apply Rmult_eq_compat_r.
  rewrite Rmult_comm.
  reflexivity.
Qed.


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

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations utils fol_ops fo_sig fo_terms fo_logic.

Import fol_notations.

Set Default Proof Using "Type".

Set Implicit Arguments.

(* * First order definability and closure properties *)

Notation ø := vec_nil.

Opaque fo_term_subst fo_term_map fo_term_sem.

Section fo_definability.

  Variable (Σ : fo_signature) (ls : list (syms Σ)) (lr : list (rels Σ))
           (X : Type) (M : fo_model Σ X).

  Definition fot_definable (f : (nat -> X) -> X) :=
       { t | incl (fo_term_syms t) ls /\ forall φ, fo_term_sem M φ t = f φ }.

  Definition fol_definable (R : (nat -> X) -> Prop) :=
       { A | incl (fol_syms A) ls
          /\ incl (fol_rels A) lr
          /\ forall φ, fol_sem M φ A <-> R φ }.

  (* A FOL definable predicate is always extensional *)

  Fact fot_def_ext t : fot_definable t -> forall φ ψ, (forall n, φ n = ψ n) -> t φ = t ψ.
  Proof.
    intros (k & _ & Hk) phi psi H.
    rewrite <- Hk, <- Hk; apply fo_term_sem_ext; auto.
  Qed.

  Fact fol_def_ext R : fol_definable R -> forall φ ψ, (forall n, φ n = ψ n) -> R φ <-> R ψ.
  Proof.
    intros (A & _ & _ & HA) phi psi H.
    rewrite <- HA, <- HA; apply fol_sem_ext.
    intros; auto.
  Qed.

  (* We derive closure properties *)

  Fact fot_def_proj n : fot_definable (fun φ => φ n).
  Proof. exists (£ n); intros; split; rew fot; auto; intros _ []. Qed.

  Fact fot_def_map (f : nat -> nat) t :
           fot_definable t -> fot_definable (fun φ => t (fun n => φ (f n))).
  Proof.
    intros H; generalize (fot_def_ext H); revert H.
    intros (k & H1 & H2) H3.
    exists (fo_term_map f k); split.
    + rewrite fo_term_syms_map; auto.
    + intro phi; rewrite <- fo_term_subst_map; rew fot.
      rewrite H2; apply H3; intro; rew fot; auto.
  Qed.

  Fact fot_def_comp s v :
        In s ls
      -> (forall p, fot_definable (fun φ => vec_pos (v φ) p))
      -> fot_definable (fun φ => fom_syms M s (v φ)).
  Proof.
    intros H0 H; apply vec_reif_t in H.
    destruct H as (w & Hw).
    exists (in_fot _ w); split; rew fot.
    + intros x [ -> | H ]; auto; revert H.
      rewrite in_flat_map.
      intros (t & H1 & H2).
      apply in_vec_list, in_vec_inv in H1.
      destruct H1 as (p & <- ).
      revert H2; apply Hw.
    + intros phi; rew fot; f_equal.
      apply vec_pos_ext; intros p.
      rewrite vec_pos_map.
      apply Hw; auto.
  Qed.

  Fact fot_def_equiv f g :
         (forall φ, f φ = g φ) -> fot_definable f -> fot_definable g.
  Proof.
    intros E (t & H1 & H2); exists t; split; auto; intro; rewrite H2; auto.
  Qed.

  Fact fol_def_atom r v :
         In r lr
      -> (forall p, fot_definable (fun φ => vec_pos (v φ) p))
      -> fol_definable (fun φ => fom_rels M r (v φ)).
  Proof.
    intros H0 H; apply vec_reif_t in H.
    destruct H as (w & Hw).
    exists (@fol_atom _ _ w); msplit 2.
    + simpl; intro s; rewrite in_flat_map.
      intros (t & H1 & H2).
      apply in_vec_list, in_vec_inv in H1.
      destruct H1 as (p & <- ).
      revert H2; apply Hw.
    + simpl; intros ? [ -> | [] ]; auto.
    + intros phi; simpl.
      apply fol_equiv_ext; f_equal.
      apply vec_pos_ext; intros p.
      rewrite vec_pos_map; apply Hw; auto.
  Qed.

  Fact fol_def_True : fol_definable (fun _ => True).
  Proof. exists (⊥⤑⊥); intros; simpl; msplit 2; try red; simpl; tauto. Qed.

  Fact fol_def_False : fol_definable (fun _ => False).
  Proof. exists ⊥; intros; simpl; msplit 2; try red; simpl; tauto. Qed.

  Fact fol_def_equiv R T :
          (forall φ, R φ <-> T φ) -> fol_definable R -> fol_definable T.
  Proof.
    intros H (A & H1 & H2 & H3); exists A; msplit 2; auto; intro; rewrite <- H; auto.
  Qed.

  Fact fol_def_conj R T :
         fol_definable R -> fol_definable T -> fol_definable (fun φ => R φ /\ T φ).
  Proof.
    intros (A & H1 & H2 & H3) (B & HH4 & H5 & H6); exists (fol_bin fol_conj A B); msplit 2.
    1,2: simpl; intro; rewrite in_app_iff; intros []; auto.
    intro; simpl; rewrite H3, H6; tauto.
  Qed.

  Fact fol_def_disj R T :
         fol_definable R -> fol_definable T -> fol_definable (fun φ => R φ \/ T φ).
  Proof.
    intros (A & H1 & H2 & H3) (B & HH4 & H5 & H6); exists (fol_bin fol_disj A B); msplit 2.
    1,2: simpl; intro; rewrite in_app_iff; intros []; auto.
    intro; simpl; rewrite H3, H6; tauto.
  Qed.

  Fact fol_def_imp R T :
         fol_definable R -> fol_definable T -> fol_definable (fun φ => R φ -> T φ).
  Proof.
    intros (A & H1 & H2 & H3) (B & HH4 & H5 & H6); exists (fol_bin fol_imp A B); msplit 2.
    1,2: simpl; intro; rewrite in_app_iff; intros []; auto.
    intro; simpl; rewrite H3, H6; tauto.
  Qed.

  Fact fol_def_fa (R : X -> (nat -> X) -> Prop) :
          fol_definable (fun φ => R (φ 0) (fun n => φ (S n)))
       -> fol_definable (fun φ => forall x, R x φ).
  Proof.
    intros (A & H1 & H2 & H3); exists (fol_quant fol_fa A); msplit 2; auto.
    intro; simpl; apply forall_equiv.
    intro; rewrite H3; simpl; tauto.
  Qed.

  Fact fol_def_ex (R : X -> (nat -> X) -> Prop) :
          fol_definable (fun φ => R (φ 0) (fun n => φ (S n)))
       -> fol_definable (fun φ => exists x, R x φ).
  Proof.
    intros (A & H1 & H2 & H3); exists (fol_quant fol_ex A); msplit 2; auto.
    intro; simpl; apply exists_equiv.
    intro; rewrite H3; simpl; tauto.
  Qed.

  Fact fol_def_list_fa K l (R : K -> (nat -> X) -> Prop) :
           (forall k, In k l -> fol_definable (R k))
        -> fol_definable (fun φ => forall k, In k l -> R k φ).
  Proof.
    intros H.
    set (f := fun k Hk => proj1_sig (H k Hk)).
    exists (fol_lconj (list_in_map l f)); msplit 2.
    + rewrite fol_syms_bigop.
      intros s; simpl; rewrite <- app_nil_end.
      rewrite in_flat_map.
      intros (A & H1 & H2).
      apply In_list_in_map_inv in H1.
      destruct H1 as (k & Hk & ->).
      revert H2; apply (proj2_sig (H k Hk)); auto.
    + rewrite fol_rels_bigop.
      intros s; simpl; rewrite <- app_nil_end.
      rewrite in_flat_map.
      intros (A & H1 & H2).
      apply In_list_in_map_inv in H1.
      destruct H1 as (k & Hk & ->).
      revert H2; apply (proj2_sig (H k Hk)); auto.
    + intros phi.
      rewrite fol_sem_lconj; split.
      * intros H1 k Hk; apply (proj2_sig (H k Hk)), H1.
        change (In (f k Hk) (list_in_map l f)).
        apply In_list_in_map.
      * intros H1 A H2.
        apply In_list_in_map_inv in H2.
        destruct H2 as (k & Hk & ->).
        apply (proj2_sig (H k Hk)); auto.
  Qed.

  Fact fol_def_bounded_fa m (R : nat -> (nat -> X) -> Prop) :
             (forall n, n < m -> fol_definable (R n))
          -> fol_definable (fun φ => forall n, n < m -> R n φ).
  Proof.
    intros H.
    apply fol_def_equiv with (R := fun φ => forall n, In n (list_an 0 m) -> R n φ).
    + intros phi; apply forall_equiv; intro; rewrite list_an_spec; simpl; split; try tauto.
      intros H1 ?; apply H1; lia.
    + apply fol_def_list_fa.
      intros n Hn; apply H; revert Hn; rewrite list_an_spec; lia.
  Qed.

  Fact fol_def_list_ex K l (R : K -> (nat -> X) -> Prop) :
           (forall k, In k l -> fol_definable (R k))
        -> fol_definable (fun φ => exists k, In k l /\ R k φ).
  Proof.
    intros H.
    set (f := fun k Hk => proj1_sig (H k Hk)).
    exists (fol_ldisj (list_in_map l f)); msplit 2.
    + rewrite fol_syms_bigop.
      intros s; simpl; rewrite <- app_nil_end.
      rewrite in_flat_map.
      intros (A & H1 & H2).
      apply In_list_in_map_inv in H1.
      destruct H1 as (k & Hk & ->).
      revert H2; apply (proj2_sig (H k Hk)); auto.
    + rewrite fol_rels_bigop.
      intros s; simpl; rewrite <- app_nil_end.
      rewrite in_flat_map.
      intros (A & H1 & H2).
      apply In_list_in_map_inv in H1.
      destruct H1 as (k & Hk & ->).
      revert H2; apply (proj2_sig (H k Hk)); auto.
    + intros phi.
      rewrite fol_sem_ldisj; split.
      * intros (A & H1 & HA).
        apply In_list_in_map_inv in H1.
        destruct H1 as (k & Hk & ->).
        exists k; split; auto.
        apply (proj2_sig (H k Hk)); auto.
      * intros (k & Hk & H1).
        exists (f k Hk); split.
        - apply In_list_in_map.
        - apply (proj2_sig (H k Hk)); auto.
  Qed.

  Fact fol_def_subst (R : (nat -> X) -> Prop) (f : nat -> (nat -> X) -> X) :
          (forall n, fot_definable (f n))
       -> fol_definable R
       -> fol_definable (fun φ => R (fun n => f n φ)).
  Proof.
    intros H1 H2.
    generalize (fol_def_ext H2); intros H3.
    destruct H2 as (A & G1 & G2 & HA).
    set (rho := fun n => proj1_sig (H1 n)).
    exists (fol_subst rho A); msplit 2.
    + red; apply Forall_forall; apply fol_syms_subst.
      * intros n Hn; rewrite Forall_forall.
        intro; apply (fun n => proj2_sig (H1 n)).
      * apply Forall_forall, G1.
    + rewrite fol_rels_subst; auto.
    + intros phi.
      rewrite fol_sem_subst, HA.
      apply H3; intro; unfold rho; rew fot.
      apply (fun n => proj2_sig (H1 n)).
  Qed.

End fo_definability.

Create HintDb fol_def_db.

#[export] Hint Resolve fot_def_proj fot_def_map fot_def_comp fol_def_True fol_def_False : fol_def_db.

Tactic Notation "fol" "def" :=
   repeat ((  apply fol_def_conj
           || apply fol_def_disj
           || apply fol_def_imp
           || apply fol_def_ex
           || apply fol_def_fa
           || (apply fol_def_atom; intro)
           || apply fol_def_subst); auto with fol_def_db); auto with fol_def_db.

Section extra.

  Variable (Σ : fo_signature) (ls : list (syms Σ)) (lr : list (rels Σ))
           (X : Type) (M : fo_model Σ X).

  (* More closure properties *)

  Fact fol_def_iff R T :
         fol_definable ls lr M R
      -> fol_definable ls lr M T
      -> fol_definable ls lr M (fun φ => R φ <-> T φ).
  Proof.
    intros; fol def.
  Qed.

  Fact fol_def_subst2 R t1 t2 :
           fol_definable ls lr M (fun φ => R (φ 0) (φ 1))
        -> fot_definable ls M t1
        -> fot_definable ls M t2
        -> fol_definable ls lr M (fun φ => R (t1 φ) (t2 φ)).
  Proof.
    intros H1 H2 H3.
    set (f n := match n with
        | 0 => t1
        | 1 => t2
        | _ => fun φ => φ 0
      end).
    change (fol_definable ls lr M (fun φ => R (f 0 φ) (f 1 φ))).
    apply fol_def_subst with (2 := H1) (f := f).
    intros [ | [ | n ] ]; simpl; fol def.
  Qed.

  Let env_vec (φ : nat -> X) n := vec_set_pos (fun p => φ (@pos2nat n p)).
  Let env_env (φ : nat -> X) n k := φ (n+k).

  Fact fol_def_vec_fa n (R : vec X n -> (nat -> X) -> Prop) :
           (fol_definable ls lr M (fun φ => R (env_vec φ n) (env_env φ n)))
         -> fol_definable ls lr M (fun φ => forall v, R v φ).
  Proof.
    revert R; induction n as [ | n IHn ]; intros R HR.
    + revert HR; apply fol_def_equiv; intros phi; simpl.
      split; auto; intros ? v; vec nil v; auto.
    + set (T φ := forall v x, R (x##v) φ).
      apply fol_def_equiv with (R := T).
      * intros phi; unfold T; split.
        - intros H v; vec split v with x; auto.
        - intros H ? ?; apply (H (_##_)).
      * unfold T; apply IHn, fol_def_fa, HR.
  Qed.

  Fact fol_def_vec_ex n (R : vec X n -> (nat -> X) -> Prop) :
           (fol_definable ls lr M (fun φ => R (env_vec φ n) (env_env φ n)))
         -> fol_definable ls lr M (fun φ => exists v, R v φ).
  Proof.
    revert R; induction n as [ | n IHn ]; intros R HR.
    + revert HR; apply fol_def_equiv; intros phi; simpl.
      split.
      * exists vec_nil; auto.
      * intros (v & Hv); revert Hv; vec nil v; auto.
    + set (T φ := exists v x, R (x##v) φ).
      apply fol_def_equiv with (R := T).
      * intros phi; unfold T; split.
        - intros (v & x & Hv); exists (x##v); auto.
        - intros (v & Hv); revert Hv; vec split v with x; exists v, x; auto.
      * unfold T; apply IHn, fol_def_ex, HR.
  Qed.

  Fact fol_def_finite_fa I (R : I -> (nat -> X) -> Prop) :
            finite_t I
         -> (forall i, fol_definable ls lr M (R i))
         -> fol_definable ls lr M (fun φ => forall i : I, R i φ).
  Proof.
    intros (l & Hl) H.
    apply fol_def_equiv with (R := fun φ => forall i, In i l -> R i φ).
    + intros phi; apply forall_equiv; intro; split; auto.
    + apply fol_def_list_fa; auto.
  Qed.

  Fact fol_def_finite_ex I (R : I -> (nat -> X) -> Prop) :
            finite_t I
         -> (forall i, fol_definable ls lr M (R i))
         -> fol_definable ls lr M (fun φ => exists i : I, R i φ).
  Proof.
    intros (l & Hl) H.
    apply fol_def_equiv with (R := fun φ => exists i, In i l /\ R i φ).
    + intros phi; apply exists_equiv; intro; split; auto; tauto.
    + apply fol_def_list_ex; auto.
  Qed.

End extra.


(**
フィボナッチ数の最大公約数 (GCD of Fibonacci Numbers) その2
============================

@suharahiromichi

2022/01/29

2022/02/27 fibn_ind と gcdn_ind を証明して、functional inducntion を使わずに証明する。
*)

(**
# はじめに

フィボナッチ数の最大公約数は、その最大公約数番目のフィボナッチ数に等しい、

```math

gcd(F_m, F_n) = F_{gcd(m, n)}
```

という定理があります。エドゥアール・リュカ（François Édouard Anatole Lucas) が発見して、
クヌーツ先生の本 ([1] (式 6.111) など) で有名になったのだそうです。

フィボナッチ数の加法定理をつかうと簡単に証明できるので、トライしてみましょう。

この記事は [2] の続編です。

先の記事では、Coqのfunctional inducntionを使用しましたが、
この記事ではそれを使わないで証明してみます。
具体的には、フィボナッチ数とユーグリッドの互除法についての帰納原理
（fibn_ind と gcdn_ind）を自分で証明して、使用します。
こちらのほうが、よりMathComp風の証明だといえるでしょう。

なお、gcdn_ind の証明は、Coq Tokyo [3]でおしえてもらいました。

このソースは、以下にあります。

https://github.com/suharahiromichi/coq/blob/master/math/ssr_fib_3_2.v
*)

From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Set Print All. *)

Section Fib3_2.

(**
# フィボナッチ数の定義と定理
*)
  Fixpoint fibn (n : nat) : nat :=
    match n with
    | 0 => 0
    | 1 => 1
    | (m.+1 as pn).+1 => fibn m + fibn pn (* fibn n.-2 + fibn n.-1 *)
    end.

(**
## 簡単な補題
*)

(**
1個分のフィボナッチ数の計算
 *)
  Lemma fibn_n n : fibn n.+2 = fibn n + fibn n.+1.
  Proof.
    done.
  Qed.

(**
隣り合ったフィボナッチ数は互いに素である。
*)
  Lemma fibn_coprime (n : nat) : coprime (fibn n) (fibn n.+1).
  Proof.
    rewrite /coprime.
    elim: n => [//= | n IHn].
    rewrite fibn_n.
    by rewrite gcdnDr gcdnC.
  Qed.

(**
## フィボナッチ数列の帰納法
*)
  Lemma fibn_ind (P : nat -> nat -> Prop) :
    P 0 0 ->
    P 1 1 ->
    (forall m : nat, P m (fibn m) ->
                     P m.+1 (fibn m.+1) ->
                     P m.+2 (fibn m + fibn m.+1))
    ->
      forall m : nat, P m (fibn m).
  Proof.
    move=> H1 H2 IH.
    (* m について2回場合分して、m.+2 を取り出す。 *)
    elim/ltn_ind => [[_ | [_ | m]]].
    - by rewrite /fibn.
    - by rewrite /fibn.
    - move: (IH m).
      rewrite -fibn_n => {IH} IH H.
      by apply: IH; apply: H.
  Qed.

  Definition Pfibn m0 n0 :=
    forall n, fibn (n + m0.+1) = fibn m0.+1 * fibn n.+1 + n0 * fibn n.

  Check @fibn_ind Pfibn
    : Pfibn 0 0 ->
      Pfibn 1 1 ->
      (forall m : nat, Pfibn m (fibn m) ->
                       Pfibn m.+1 (fibn m.+1) ->
                       Pfibn m.+2 (fibn m + fibn m.+1))
      ->
        forall m : nat, Pfibn m (fibn m).

(**
## フィボナッチ数列の加法定理

fibn_ind を使って、functional induction を使わずに証明します。
*)
  Lemma fibn_addition' m n :
    fibn (m + n.+1) = fibn n.+1 * fibn m.+1 + fibn n * fibn m.
  Proof.
    apply: (@fibn_ind Pfibn); rewrite /Pfibn.
    - clear m n => n.
      rewrite addn1.
      rewrite [fibn 1]/= mul1n mul0n addn0.
      done.

    - clear m n => n.
      rewrite addn2.
      rewrite [fibn 2]/= add0n 2!mul1n.
      rewrite addnC -fibn_n.
      done.

    - clear m n => m IHn0 IHn1 n.
      rewrite fibn_n 2!mulnDl.

      (* F(n + m.+1) の項をまとめて置き換える *)
      rewrite ?addnA [_ + fibn m * fibn n]addnC. (* この項を先頭に。 *)
      rewrite ?addnA [_ + fibn m.+1 * fibn n.+1]addnC ?addnA. (* この項を先頭に。 *)
      rewrite -IHn0.

      (* F(n + m.+2) の項をまとめて置き換える *)
      rewrite ?addnA [_ + fibn m.+1 * fibn n]addnC. (* この項を先頭に。 *)
      rewrite ?addnA [_ + fibn m.+2 * fibn n.+1]addnC ?addnA. (* この項を先頭に。 *)
      rewrite -IHn1.

      rewrite -addn3 addnA addn3.
      rewrite -[m.+2]addn2 addnA addn2.
      rewrite -[m.+1]addn1 addnA addn1.
      rewrite fibn_n addnC.
      done.
  Qed.

  Lemma fibn_addition m n :
    1 <= n -> fibn (m + n) = fibn n * fibn m.+1 + fibn n.-1 * fibn m.
  Proof.
    move=> H.
    have H' := fibn_addition' m n.-1.
    by rewrite prednK in H'.
  Qed.

(**
# ユーグリッドの互除法の帰納法の証明
*)
  Lemma gcdn_ind (P : nat -> nat -> nat -> Prop) :
    (forall n, P 0 n n) ->
    (forall m n, P (n %% m) m (gcdn (n %% m) m) ->
                 P m n (gcdn m n))
    ->
      forall m n, P m n (gcdn m n).
  Proof.
    move => H0 Hmod.
    elim/ltn_ind => [[| m]] // H n.
    - have -> : gcdn 0 n = n by elim: n.
      done.
    - apply: Hmod.
      exact: H (ltn_mod _ _) _.
  Qed.

  Definition Pgcdn m0 n0 n1 := gcdn (fibn m0) (fibn n0) = fibn n1.

  Check @gcdn_ind Pgcdn
    : (forall n : nat, Pgcdn 0 n n) ->
      (forall m n : nat, Pgcdn (n %% m) m (gcdn (n %% m) m) -> Pgcdn m n (gcdn m n)) ->
      forall m n : nat, Pgcdn m n (gcdn m n).

(**
# フィボナッチ数のGCD
*)

(**
GKPの解答にある、``m > n`` ならば ``gcd (fibn m) (fibn n) = gcd (fibn (m - n)) (fibn n)``
と同じものを証明するが、そのために ``m`` を ``0`` と非0で振り分ける。
 *)
  Lemma fibn_lemma_gkp' m n :
    1 <= m -> gcdn (fibn (n + m)) (fibn n) = gcdn (fibn m) (fibn n).
  Proof.
    move=> H.
    rewrite fibn_addition //.
    rewrite gcdnC addnC gcdnMDl.
    rewrite Gauss_gcdl.
    - by rewrite gcdnC.
    - by apply: fibn_coprime.
  Qed.

  Lemma fibn_lemma_gkp m n :
    gcdn (fibn (n + m)) (fibn n) = gcdn (fibn m) (fibn n).
  Proof.
    case: m => [| m].
    - rewrite addn0 /=.
      by rewrite gcd0n gcdnn.
    - by rewrite fibn_lemma_gkp'.
  Qed.

(**
gcdnMDl のフィボナッチ数版
*)
  Check gcdnMDl : forall k m n : nat, gcdn m (k * m + n) = gcdn m n.
  Lemma fibn_gcdMDl n q r :
    gcdn (fibn (q * n + r)) (fibn n) = gcdn (fibn n) (fibn r).
  Proof.
    elim: q => [| q IHq].
    - rewrite mul0n add0n.
      rewrite gcdnC.
      done.
    - Search _ (_.+1 * _).
      rewrite mulSn -addnA.
      rewrite [LHS]fibn_lemma_gkp.
      done.
  Qed.

(**
gcdn_modr のフィボナッチ数版
*)
  Check gcdn_modr : forall m n : nat, gcdn m (n %% m) = gcdn m n.
  Lemma fibn_gcdn_modr m n :
    gcdn (fibn m) (fibn n) = gcdn (fibn n) (fibn (m %% n)).
  Proof.
    move: (fibn_gcdMDl n (m %/ n) (m %% n)).
    rewrite -divn_eq.
    done.
  Qed.

(**
gcdn_ind を使って、functional induction を使わずに証明します。
*)
  Theorem gcdn_fibn__fibn_gcdn (m n : nat) : gcdn (fibn m) (fibn n) = fibn (gcdn m n).
  Proof.
    apply: (@gcdn_ind Pgcdn); rewrite /Pgcdn.
    - move=> n'.
      by rewrite /= gcd0n.
    - move=> m' n' /= IHm.
      rewrite gcdnC -fibn_gcdn_modr gcdn_modl gcdnC in IHm.
      by rewrite IHm gcdnC.
  Qed.

End Fib3_2.

(**
# 文献

[1] Graham, Knuth, Patashnik "Concrete Mathematics", Second Edition

[2] 「フィボナッチ数の最大公約数」
[https://qiita.com/suharahiromichi/items/d0861c1ef82d67d823c0]

[3] Coq Tokyo [https://readcoqart.connpass.com/]
 *)

(* END *)


Require Import Coq.Unicode.Utf8_core.

Theorem plus_rewrited : ∀ n m: nat,
  n = m → n + n = m + m.
(* Assuming n=m then n+n eq m+m *)

Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.

(* What coq think abuot ht above code?

1 subgoal

n, m : nat
H : n = m
——————————————————
m + m = m + m
 *)


Add LoadPath "." as OmegaCategories.
Require Export Unicode.Utf8_core.
Require Import BinInt Even List Heap Le Plus Minus.
Require Import Omega.

(** * Globular sets, basic definitions  *)

(** First, a notation for [existT], the quantifier over [Type]s *)

Set Implicit Arguments.

(** Inductive type for globular sets *)
(** This corresponds to Definition 1 of the TLCA paper *)

CoInductive GType : Type := mkGType : ∀ (Obj : Type), (Obj -> Obj -> GType) -> GType.

Definition objects (G : GType) : Type.
destruct G as [Obj G]. exact Obj.
Defined.

Notation " | A |" := (objects A) (at level 80).

Definition hom (G : GType) : ∀ (a b : |G|), GType.
destruct G as [Obj G]. exact G.
Defined.

Reserved Notation " A ==> B " (at level 90).
Notation " G [ A , B ]" := (hom G A B) (at level 80).

(** Definition of morphism of globular types *)

CoInductive GHom : ∀ (G H : GType), Type :=
  mkGHom : ∀ (G H : GType) (f0 : |G| -> |H|)
             (f1 : ∀ (x x' : |G|), G [x,x'] ==> H [f0 x, f0 x']),
             G ==> H
where " A ==> B " := (GHom A B).

Definition app G H (f : G ==> H) : |G| -> |H|.
intro x. destruct f. exact (f0 x).
Defined.

Notation "f @@ x" := (app f x) (at level 20) : type_scope.

Definition map G H (f : G ==> H) (x x' : |G|) : G [x,x'] ==> H [f @@ x, f @@ x'].
destruct f. exact (f1 x x').
Defined.

Notation "f << x , x' >>" := (map f x x') (at level 80).

(** Definition of product of globular types (Definition 2 in TLCA paper)*)

Reserved Notation "A ** B" (at level 90).

CoFixpoint product (G H : GType) : GType :=
  @mkGType (prod (objects G) (objects H))
         (fun xy xy' => G [fst xy, fst xy'] ** H [snd xy, snd xy'])
where "A ** B"  := (product A B).

(* composition of morphisms of GTypes *)

CoFixpoint GComp  (X Y Z:GType) : X ==> Y -> Y ==> Z -> X ==> Z :=
  fun f g => mkGHom _ _ (fun x => g @@ (f @@ x))
                    (fun x x' => GComp (f << x , x' >>) (g << f @@ x, f @@ x'>>)).

(* identity on GTypes *)

CoFixpoint GId (G:GType) : G ==> G := mkGHom G G id (fun x y => GId (G [x, y])).

(* Definition of the terminal globular type *)

CoFixpoint Delta (X0 : Type) : GType := @mkGType X0 (fun _ _ => Delta X0).

Definition terminal : GType := Delta unit.


(* Exercise 4 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_004 : (forall x y : D, R x y) -> forall x : D, R x x.
Proof.
imp_i a1.
all_i a.
all_e (forall y:D, R a y) a.
all_e (forall x:D, forall y:D, R x y) a.
hyp a1.
Qed.


Require Export Arith.

Fixpoint bdiv_aux (b m n:nat) {struct b} : nat * nat :=
  match b with
  | O => (0, 0)
  | S b' =>
      match le_gt_dec n m with
      | left H => match bdiv_aux b' (m - n) n with
                  | (q, r) => (S q, r)
                  end
      | right H => (0, m)
      end
  end.

(* Here is the real solution to the exercise.  One of the keys is
  to detect that we are going to prove properties of inequalities
  that can be decided using lia. *)

Require Export Lia.

Theorem bdiv_aux_correct2 :
 forall b m n:nat, m <= b -> 0 < n -> snd (bdiv_aux b m n) < n.
Proof.
 intros b; induction b as [ | b Hrec]; auto with arith.
 { cbn in |- *;   intros m n Hle Hlt; case (le_gt_dec n m).
   -  generalize (Hrec (m - n) n).
      case (bdiv_aux b (m - n) n); simpl in |- *; intros; lia.
   - simpl in |- *; intros; lia.
  }
Qed.


(** Pierre Castéran, University of Bordeaux and LaBRI *)

From Coq Require Import Arith Peano_dec Lia Relations Relation_Operators.
From hydras Require Import  Hydra_Lemmas Simple_LexProd ON_Omega2.
Import ON_Generic.

(** There is no measure into omega^2  for proving termination
of all hydra battles *)

(* begin snippet Impossibility *)

Section Impossibility_Proof.
(* end snippet Impossibility *)

  (** Let us assume there is a variant from [Hydra] into [omega^2]
  for proving the termination of all hydra battles *)

  (* begin snippet Impossibilitya *)

  Variable m : Hydra -> ON_Omega2.t.
  Context
    (Hvar: @Hvariant _ _ (ON_Generic.ON_wf (ON:=Omega2)) free m).

  (* end snippet Impossibilitya *)

  (* begin snippet Impossibilityb *)

  Let big_h := hyd1 (hyd2 head head).

  (* end snippet Impossibilityb *)

  (** To every pair $(i,j)$ of natural numbers we associate an hydra
        with $i$ branches of length 2 and $j$ branches of length 1 *)

  (* begin snippet Impossibilityc *)

  Let iota (p: ON_Omega2.t) :=
    node (hcons_mult (hyd1 head) (fst p)
                     (hcons_mult head (snd p) hnil)).

  (* end snippet Impossibilityc *)

  (* begin snippet Impossibilityd *)

  Let small_h := iota (m big_h).
  (* end snippet Impossibilityd *)

  (** *** Proof of the inequality [m small_h o< m big_h]
   *)

  #[local] Hint Constructors R1 S1 S2 : hydra.

  Lemma m_big_h_not_null : m big_h <> zero.
  Proof.
    intro H; pose (h1 := hyd1 (hyd1 head)).
    assert (first_round : big_h -+-> h1).
    {
      left; exists 0; right; left; constructor 1 with (n:=0).
      split; left.
    }
    specialize (m_strict_mono m Hvar first_round).
    rewrite H; inversion_clear 1; lia.
  Qed.

  (* begin snippet bigToSmall *)

  Lemma big_to_small : big_h -+-> small_h. (* .no-out *)

  (* end snippet bigToSmall *)

  Proof.
    unfold small_h; case_eq  (m big_h); intros i j Hj;  destruct i.

    (*  i = 0 *)
    - unfold big_h; right with (hyd1 (hyd1 head)).
      exists 0; right; left.
      left with (n:=0);  split; left.
      destruct j.
      + now destruct m_big_h_not_null.
      + unfold iota;cbn;left.
        exists j;right; left; constructor 1;  split;  left.

    (* i > 0 *)
    - unfold iota; cbn;  destruct j.
      +   left; unfold iota, big_h; cbn.
          exists i; right; left; left;   split; left.
      +  right with (iota (S (S i), 0)).
         unfold iota;  simpl fst ; simpl snd;   cbn; exists (S i); right.
         left; left;  split; left.
         left;  exists j; right; left;   right.
         rewrite <- hcons_mult_comm;  apply hcons_mult_S1.
         left; split; left.
  Qed.

  (* begin snippet mLt *)

  (*|
.. coq:: no-out
|*)

  Corollary m_lt : m small_h o< m big_h.
  Proof. apply m_strict_mono with (1:=Hvar) (2:=big_to_small). Qed.
  (*||*)

  (* end snippet mLt *)

  (** *** Proof of the inequality [m big_h o<= m small_h]  *)

  (** *** Let us decompose any inequality p o< q into elementary steps *)

  (* begin snippet stepDef *)

  Inductive step : t -> t -> Prop :=
  | succ_step : forall i j,  step (i, S j) (i, j)
  | limit_step : forall i j, step (S i, 0) (i, j).

  (* end snippet stepDef *)

  Lemma succ_rounds : forall i j,  iota (i,S j) -+-> iota (i, j).
  Proof.
    unfold iota;  left; exists 0;  left;   split;
      apply hcons_mult_S0;  constructor.
  Qed.

  Lemma limit_rounds_0 :
    forall i j, round_n j (iota (S i, 0)) (iota (i, S j)).
  Proof.
    intros i j;  destruct i.
    - unfold iota;   right;  left;
        change  (hcons head (hcons_mult head j hnil))
          with (hcons_mult head (S j) hnil).
      left; split;  left.
    -   right; left; cbn;  rewrite <- hcons_mult_comm; right.
        apply hcons_mult_S1; left; split; constructor.
  Qed.

  Lemma limit_rounds : forall i j, iota (S i, 0) -+-> iota (i, j).
  Proof.
    intros i j;  apply round_plus_trans with (iota (i, S j)).
    - left; exists j; apply limit_rounds_0.
    - apply succ_rounds.
  Qed.

  #[local] Hint Constructors step clos_trans_1n : hydra.
  #[local] Hint Resolve lex_1 lex_2: hydra.
  #[local] Hint Unfold lt : hydra.

  (* begin snippet stepToBattle *)

  Lemma step_to_battle : forall p q, step p q -> iota p -+-> iota q. (* .no-out *)

  (* end snippet stepToBattle *)

  Proof.
    destruct 1; [ apply succ_rounds |  apply limit_rounds].
  Qed.

  #[local] Hint Resolve step_to_battle : hydra.

  (* begin snippet mGe *)

  Lemma m_ge : m big_h o<= m small_h. (* .no-out *)
  Proof. (* .no-out *)
    unfold small_h;
    pattern (m big_h);
      apply  well_founded_induction with (R := ON_lt) (1:= ON_wf);
      intros (i,j) IHij.

    (* end snippet mGe *)

    (* begin snippet mGeb *)
       (*|
.. coq:: none
|*)
    destruct j as [|k].
    - destruct i as [| l].
      +  apply le_0.
      +  assert (is_true (limitb (S l, 0))) by  reflexivity.
        specialize (limit_is_lub (S l, 0) H (m (iota (S l, 0)))).
        intros <- k; eapply Comparable.le_lt_trans.
        apply IHij;left; auto.
        red; apply (m_strict_mono m Hvar); auto with hydra.
        simpl canon.
        apply step_to_battle.  apply limit_step.
    - change (i, S k) with (succ (i,k)) at 1.
      rewrite <- (lt_succ_le (i,k) (m (iota (i, S k)))).
      eapply (Comparable.le_lt_trans).
      instantiate (1:= (m (iota (i, k)))).
      apply IHij; right; auto.
      apply (m_strict_mono m Hvar); auto with hydra.
      (*||*)
      (* ... *)
  Qed.

    (* end snippet mGeb *)

  (* begin snippet Impossible *)

  (*|
.. coq:: no-out
|*)

  Theorem Impossible : False.
  Proof.
    destruct (StrictOrder_Irreflexive (R:=ON_lt) (m big_h));
      eapply le_lt_trans; [apply m_ge | apply m_lt].
  Qed.

End Impossibility_Proof.

(*||*)

  (* end snippet Impossible *)


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

(* Trying an abstract compiler with labels instead of nats as source code addressing *)

Require Import List Arith Omega.

Require Import utils subcode sss bsm_defs compiler.

(** ** Semantic Correctness of Compiled Code *)

Set Implicit Arguments.

Section comp.

  (** This is an abstract proof of compiler soundness & completeness

      The principle of this compiler is to map every source individual
      instruction into a list of target instructions that simulate the
      source instruction. We describe our assumptions later on ...

    *)

  Variable (X Y : Set)                                  (* X is a small type of source instructions and
                                                           Y of destination instructions *)
           (icomp : (nat -> nat) -> nat -> X -> list Y) (* instruction compiler w.r.t. a given linker & a position
                                                           icomp lnk i x compiles instruction x at position i
                                                           using linker lnk into a list of target instructions
                                                         *)
           (ilen  : X -> nat)                           (* compiled code length does not depend on linker or position,
                                                           it only depends on the original instruction
                                                           whether this assumption is strong or not is debatable
                                                           but we only encountered cases which satisfy this assuption
                                                         *)
           (Hilen : forall lnk n x, length (icomp lnk n x) = ilen x)
           (*Hilen2  : forall x, 1 <= ilen x*).           (* compiled code should not be empty, even if the source
                                                           instruction is something like NO-OP, to ensure progress
                                                           in the simulation as source code executes
                                                           also not a strong requirement

                                                           This can be removed because it can be deduced (where it
                                                           is used) from Hilen1 & step_X_tot & Hicomp
                                                         *)

  (* Semantics for X and Y instructions *)

  Variables (state_X state_Y : Type)
            (step_X : X -> (nat*state_X) -> (nat*state_X) -> Prop)
            (step_Y : Y -> (nat*state_Y) -> (nat*state_Y) -> Prop).

  Notation "i '/X/' s -1> t" := (step_X i s t) (at level 70, no associativity).
  Notation "P '/X/' s '-[' k ']->' t" := (sss_steps step_X P k s t) (at level 70, no associativity).
  Notation "P '/X/' s '-+>' t" := (sss_progress step_X P s t) (at level 70, no associativity).
  Notation "P '/X/' s ->> t" := (sss_compute step_X P s t) (at level 70, no associativity).
  Notation "P '/X/' s '~~>' t" := (sss_output step_X P s t) (at level 70, no associativity).
  Notation "P '/X/' s ↓" := (sss_terminates step_X P s)(at level 70, no associativity).

  Notation "i '/Y/' s -1> t" := (step_Y i s t) (at level 70, no associativity).
  Notation "P '/Y/' s '-[' k ']->' t" := (sss_steps step_Y P k s t) (at level 70, no associativity).
  Notation "P '/Y/' s '-+>' t" := (sss_progress step_Y P s t) (at level 70, no associativity).
  Notation "P '/Y/' s ->> t" := (sss_compute step_Y P s t) (at level 70, no associativity).
  Notation "P '/Y/' s '~~>' t" := (sss_output step_Y P s t) (at level 70, no associativity).
  Notation "P '/Y/' s ↓" := (sss_terminates step_Y P s)(at level 70, no associativity).

  (** We assume totality of X semantics, i.e. no instruction can block the computation
      and functionality of Y semantics

      Totality is not necessary achieved ... think of a HALT instruction
      what should we do in that case ? It should not be too difficult to
      embed a partial model of computation into a total one by transforming
      blocking cases into jumps at a PC value outside of the code.
    *)

  Hypothesis (step_X_tot : forall I st1, exists st2, I /X/ st1 -1> st2)
             (step_Y_fun : forall I st st1 st2, I /Y/ st -1> st1 -> I /Y/ st -1> st2 -> st1 = st2).

 (** simul is an invariant: simul st_X st_Y means that st_X is simulated by st_Y *)

  Variable (simul : state_X -> state_Y -> Prop).

  Infix "⋈" := simul (at level 70, no associativity).

  (** Simulation is preserved by compiled instructions
      this of course ensures the *semantic correctness of
      the compilation of individual instructions*

      Notice the important hypothesis of preservation of the +1
      relative address by the linker otherwise it might not be
      possible to establish the below predicate.

      If the source language involves other relative addresses like
      +2 or +d or -d, the present compiler might have to be substantially
      updated.

      +1 is very likely to be used even implicitly because every instruction
      that does not branch (like INC or PUSH) implicitly jumps at +1 ...
    *)

  Definition instruction_compiler_sound := forall lnk I i1 v1 i2 v2 w1,
                     I /X/ (i1,v1) -1> (i2,v2)
                  -> lnk (1+i1) = length (icomp lnk i1 I) + lnk i1
                  -> v1 ⋈ w1
       -> exists w2, (lnk i1,icomp lnk i1 I) /Y/ (lnk i1,w1) -+> (lnk i2,w2)
                  /\ v2 ⋈ w2.

  Hypothesis Hicomp : instruction_compiler_sound.

  Section correctness.

    (** We assume each instruction in P is compiled in Q according to the individual
        instruction compiler combined with what the linker says for branching.
        This is a *syntactic correctness criterion* for the whole compiled program Q
      *)

    Variables (linker : nat -> nat) (P : nat * list X) (Q : nat * list Y)
              (HPQ : forall i I, (i,I::nil) <sc P -> (linker i, icomp linker i I) <sc Q
                                                   /\ linker (1+i) = ilen I + linker i).

    (** From semantic correctness of individually compiled instructions and
        syntactic correctness of the whole compiled program, we derive
        soundness and completeness of the compiled program Q wrt the
        source program P *)

    Theorem compiler_sound i1 v1 i2 v2 w1 :
                      v1 ⋈ w1 /\ P /X/ (i1,v1) ->> (i2,v2)
        -> exists w2, v2 ⋈ w2 /\ Q /Y/ (linker i1,w1) ->> (linker i2,w2).
    Proof.
      change i1 with (fst (i1,v1)) at 2; change v1 with (snd (i1,v1)) at 1.
      change i2 with (fst (i2,v2)) at 2; change v2 with (snd (i2,v2)) at 2.
      generalize (i1,v1) (i2,v2); clear i1 v1 i2 v2.
      intros st1 st2 (H1 & q & H2); revert H2 w1 H1.
      induction 1 as [ (i1,v1) | q (i1,v1) (i2,v2) st3 H1 H2 IH2]; simpl; intros w1 H0.
      + exists w1; split; auto; exists 0; constructor.
      + destruct H1 as (k & l & I & r & v' & G1 & G2 & G3).
        inversion G2; subst v' i1; clear G2.
        destruct (Hicomp linker) with (1 := G3) (3 := H0)
          as (w2 & G4 & G5).
        * rewrite Hilen; apply HPQ; subst; exists l, r; auto.
        * destruct (IH2 _ G5) as (w3 & G6 & G7).
          exists w3; split; auto.
          apply sss_compute_trans with (2 := G7); simpl.
          apply sss_progress_compute.
          revert G4; apply subcode_sss_progress.
          apply HPQ; subst; exists l, r; auto.
    Qed.

    (* When still inside of P, the computation in Q simulates
       a computation in P *)

    Local Lemma compiler_complete_step p st1 w1 w3 :
           snd st1 ⋈ snd w1
        -> linker (fst st1) = fst w1
        -> in_code (fst st1) P
        -> out_code (fst w3) Q
        -> Q /Y/ w1 -[p]-> w3
        -> exists q st2 w2, snd st2 ⋈ snd w2
                        /\ linker (fst st2) = fst w2
                        /\ P /X/ st1 ->> st2
                        /\ Q /Y/ w2 -[q]-> w3
                        /\ q < p.
    Proof.
      revert st1 w1 w3; intros (i1,v1) (j1,w1) (j3,w3); simpl fst; simpl snd.
      intros H1 H2 H3 H4 H5.
      destruct (in_code_subcode H3) as (I & HI).
      destruct HPQ with (1 := HI) as (H6 & H7).
      assert (out_code j3 (linker i1, icomp linker i1 I)) as G2.
      { revert H4; apply subcode_out_code; auto. }
      assert (H8 : ilen I <> 0).
      { intros H.
        destruct (step_X_tot I (i1,v1)) as ((i2,v2) & Hst).
        apply (Hicomp linker) with (3 := H1) in Hst; auto.
        2: rewrite Hilen; auto.
        destruct Hst as (w2 & (q & Hq1 & Hq2) & _).
        rewrite <- (Hilen linker i1) in H.
        destruct (icomp linker i1 I); try discriminate.
        apply sss_steps_stall, proj1 in Hq2; simpl; omega. }
      assert (in_code (linker i1) (linker i1, icomp linker i1 I)) as G3.
      { simpl; rewrite (Hilen linker i1 I); omega. }
      rewrite <- H2 in H5.
      destruct (step_X_tot I (i1,v1)) as ((i2,v2) & G4).
      destruct (Hicomp linker) with (1 := G4) (3 := H1) as (w2 & G5 & G6).
      * rewrite H7, Hilen; auto.
      * apply subcode_sss_progress_inv with (3 := H6) (4 := G5) in H5; auto.
        destruct H5 as (q & H5 & G7).
        exists q, (i2,v2), (linker i2, w2); simpl; repeat (split; auto).
        apply subcode_sss_compute with (1 := HI).
        exists 1; apply sss_steps_1.
        exists i1, nil, I, nil, v1; repeat (split; auto).
        f_equal; simpl; omega.
    Qed.

    (* Termination in Q simulates termination in P *)

    Theorem compiler_complete i1 v1 w1 :
          v1 ⋈ w1 -> Q /Y/ (linker i1,w1) ↓ -> P /X/ (i1,v1) ↓.
    Proof.
      intros H1 (st & (q & H2) & H3).
      revert i1 v1 w1 H1 H2 H3.
      induction q as [ q IHq ] using (well_founded_induction lt_wf).
      intros i1 v1 w1 H1 H2 H3.
      destruct (in_out_code_dec i1 P) as [ H4 | H4 ].
      + destruct compiler_complete_step with (5 := H2) (st1 := (i1,v1))
          as (p & (i2,v2) & (j2,w2) & G1 & G2 & G3 & G4 & G5); auto; simpl in *; subst j2.
        destruct IHq with (1 := G5) (2 := G1) (3 := G4)
          as ((i3 & v3) & F3 & F4); auto.
        exists (i3,v3); repeat (split; auto).
        apply sss_compute_trans with (1 := G3); auto.
      + exists (i1,v1); repeat (split; auto).
        exists 0; constructor.
    Qed.

    Corollary compiler_complete' i1 v1 w1 st :
                            v1 ⋈ w1 /\ Q /Y/ (linker i1,w1) ~~> st
        -> exists i2 v2 w2, v2 ⋈ w2 /\ P /X/ (i1,v1) ~~> (i2,v2)
                                    /\ Q /Y/ (linker i2,w2) ~~> st.
    Proof.
      intros (H1 & H2).
      destruct compiler_complete with (1 := H1) (2 := ex_intro (fun x => Q /Y/ (linker i1, w1) ~~> x) _ H2)
        as ((i2,v2) & H3 & H4).
      exists i2, v2.
      destruct (compiler_sound (conj H1 H3)) as (w2 & H5 & H6).
      exists w2; do 2 (split; auto).
      split; auto.
      destruct H2 as (H2 & H0); split; auto.
      apply sss_compute_inv with (3 := H6); auto.
    Qed.

  End correctness.

  (** ** A Syntactically Correct Compiler *)

  (** Now we build a correct linker & compiled program pair *)

  Variable (P : nat * list X) (iQ : nat).

  Let iP := fst P.
  Let cP := snd P.

  Let err := iQ+length_compiler ilen cP.

  Definition gen_linker := linker ilen (iP,cP) iQ err.
  Definition gen_compiler := compiler icomp ilen (iP,cP) iQ err.

  Notation cQ := gen_compiler.
  Notation lnk := gen_linker.

  Let P_eq : P = (iP,cP).
  Proof. unfold iP, cP; destruct P; auto. Qed.

  Fact gen_linker_out i : out_code i (iP,cP) -> lnk i = iQ+length cQ.
  Proof.
    intros H.
    unfold lnk.
    rewrite linker_out_err; unfold err; simpl; auto.
    * unfold cQ; rewrite compiler_length; auto.
    * omega.
  Qed.

  Theorem gen_compiler_sound i1 v1 i2 v2 w1 :
                    v1 ⋈ w1 /\ (iP,cP) /X/ (i1,v1) ~~> (i2,v2)
      -> exists w2, v2 ⋈ w2 /\ (iQ,cQ) /Y/ (lnk i1,w1) ~~> (lnk i2,w2).
  Proof.
    intros (H1 & H2 & H3).
    destruct compiler_sound with (2 := conj H1 H2) (linker := gen_linker) (Q := (iQ,cQ))
      as (w2 & G1 & G2).
    + apply compiler_subcode; auto.
    + simpl fst in H3.
      exists w2; split; auto.
      split; auto; simpl.
      rewrite <- gen_linker_out with i2; auto.
  Qed.

  Theorem gen_compiler_complete i1 v1 w1 :
            v1 ⋈ w1 -> (iQ,gen_compiler) /Y/ (gen_linker i1,w1) ↓ -> (iP,cP) /X/ (i1,v1) ↓.
  Proof.
    apply compiler_complete, compiler_subcode; auto.
  Qed.

  Corollary gen_compiler_output v w i' v' :
        v ⋈ w -> (iP,cP) /X/ (iP,v) ~~> (i',v') -> exists w', (iQ,gen_compiler) /Y/ (iQ,w) ~~> (code_end (iQ,cQ),w') /\ v' ⋈ w'.
  Proof.
    intros H H1.
    destruct gen_compiler_sound with (1 := conj H H1) as (w1 & H2 & H3).
    exists w1.
    simpl; rewrite <- gen_linker_out with i'.
    + rewrite <- (linker_code_start ilen (iP,cP) iQ err) at 2; auto.
    + apply H1.
  Qed.

  Corollary gen_compiler_terminates v w :
          v ⋈ w -> (iQ,gen_compiler) /Y/ (iQ,w) ↓ -> (iP,cP) /X/ (iP,v) ↓.
  Proof.
    intros H (w' & H').
    apply gen_compiler_complete with (1 := H).
    unfold gen_linker; rewrite linker_code_start; auto; firstorder.
  Qed.

  Theorem gen_compiler_correction :
           { lnk : nat -> nat
           & { Q | fst Q = iQ
                /\ lnk iP = iQ
                /\ (forall i, out_code i P -> lnk i = code_end Q)
                /\ (forall i1 v1 w1 i2 v2, v1 ⋈ w1 /\ P /X/ (i1,v1) ~~> (i2,v2)     -> exists w2,    v2 ⋈ w2 /\ Q /Y/ (lnk i1,w1) ~~> (lnk i2,w2))
                /\ (forall i1 v1 w1 j2 w2, v1 ⋈ w1 /\ Q /Y/ (lnk i1,w1) ~~> (j2,w2) -> exists i2 v2, v2 ⋈ w2 /\ P /X/ (i1,v1) ~~> (i2,v2) /\ j2 = lnk i2)
           } }.
  Proof.
    exists lnk, (iQ,cQ); split; auto; split; [ | split ].
    + rewrite <- (linker_code_start ilen (iP,cP) iQ err); auto.
    + rewrite P_eq; apply gen_linker_out.
    + rewrite P_eq.
      split.
      * intros i1 v1 w1 i2 v2 H.
        destruct gen_compiler_sound with (1 := H) as (w2 & H3 & H4).
        exists w2; split; auto.
      * intros i1 v1 w1 j2 w2 (H1 & H2).
        destruct gen_compiler_complete with (1 := H1) (i1 := i1)
          as ((i3,v3) & H3).
        - exists (j2,w2); auto.
        - destruct gen_compiler_sound with (1 := conj H1 H3) as (w3 & H4 & H5).
          generalize (sss_output_fun step_Y_fun H2 H5); inversion 1.
          exists i3, v3; auto.
  Qed.

End comp.


Require Import kernel_graph.
Require Import graph_examples.
Require Import Omega.

(* A walk in G from x to y. *)
Record walk (G : Graph) (x y : nat) := {
  walk_intermediate : nat ; (* stevilo vmesnih vozlisc *)
  walk_length := S (S walk_intermediate) ; (* stevilo vozlisc *)
  walk_func :> nat -> nat ;
  walk_in_graph : forall i, i < walk_length -> walk_func i < V G ;
  walk_connected : forall i, i < S walk_intermediate -> G (walk_func i) (walk_func (S i)) ;
  walk_start : walk_func 0 = x ;
  walk_end : walk_func (S walk_intermediate) = y
}.

Arguments walk_intermediate {_ _ _} _.
Arguments walk_length {_ _ _} _.

Definition connected (G : Graph) :=
  forall x y, x < G -> y < G -> x < y -> walk G x y.

Lemma prove_for_one (P : nat -> Prop) (i : nat) :
  i < 1 -> P 0 -> P i.
Proof.
  intros H G.
  induction i.
  - assumption.
  - omega.
Qed.

Lemma prove_for_two (P : nat -> Prop) (i : nat) :
  i < 2 -> P 0 -> P 1 -> P i.
Proof.
  intros ilt2 H0 H1.
  induction i.
  - auto.
  - induction i.
    + auto.
    + omega.
Qed.

Lemma complete_connected (n : nat) : connected (K n).
Proof.
  intros x y xG yG x_lt_y.
  simple refine {| walk_intermediate := 0 ;
                   walk_func := (fun i => match i with
                                       | 0 => x
                                       | _ => y
                                       end) |}.
  - intros i H.
    pattern i.
    now apply prove_for_two.
  - intros i H.
    simpl ; pattern i.
    apply prove_for_one.
    + assumption.
    + omega.
  - reflexivity.
  - reflexivity.
Qed.

Lemma walk_transitive (G : Graph) (x y z : nat) :
  x < G -> y < G -> z < G ->
  walk G x y -> walk G y z -> walk G x z.
Proof.
  intros ? ? ? s t.
  assert (E : s (S (walk_intermediate s)) = t 0).
  { rewrite walk_start. apply walk_end. }
  simple refine {|
           walk_intermediate := S (walk_intermediate s + walk_intermediate t) ;
           walk_func := (fun i => if lt_dec i (walk_length s) then s i else t (S (i - walk_length s)))
         |}.
  - intros i ?.
    simpl.
    destruct (lt_dec i (walk_length s)).
    + now apply walk_in_graph.
    + apply walk_in_graph.
      unfold walk_length.
      omega.
  - intros i ? ; simpl.
    destruct (lt_dec i (walk_length s)) ; destruct (lt_dec (S i) (walk_length s)).
    + apply walk_connected.
      unfold walk_length in * ; omega.
    + replace i with (walk_length s - 1) in *.
      * { simpl.
          rewrite Nat.sub_diag.
          rewrite E.
          apply walk_connected.
          omega.
        }
      * omega.
    + omega.
    + unfold walk_length; simpl.
      replace (S (i - S (walk_intermediate s))) with (S (S (i - S (S (walk_intermediate s))))).
      * apply walk_connected.
        unfold walk_length in *.
        omega.
      * unfold walk_length in *.
        omega.
  - now apply walk_start.
  - simpl.
    unfold walk_length in *.
    destruct (lt_dec (S (S (walk_intermediate s + walk_intermediate t))) (S (S (walk_intermediate s)))).
    + omega.
    + rewrite minus_plus.
      apply walk_end.
Defined.

Definition idecomposable (G : Graph) :=
  forall col : nat -> bool, all x : G, all y : G,
  (col x = true -> col y = false ->
   some a : G, some b : G, (col a = true /\ col b = false /\ G a b)).

Theorem connected_then_idecomposable (G : Graph) : connected G -> idecomposable G.
Admitted.

Theorem idecomposable_then_connected (G : Graph) : idecomposable G -> connected G.
Admitted.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From LCAC Require Import seq_ext_base ssrnat_ext.

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

(* insert *)

Definition insert A xs ys d n : seq A :=
  take n ys ++ nseq (n - size ys) d ++ xs ++ drop n ys.

Section Insert.

Variable (A B : Type).

Lemma size_insert (xs ys : seq A) d n :
  size (insert xs ys d n) = size xs + maxn n (size ys).
Proof. rewrite /insert !size_cat size_nseq size_take size_drop; ssromega. Qed.

Lemma map_insert (f : A -> B) xs ys d n :
  map f (insert xs ys d n) = insert (map f xs) (map f ys) (f d) n.
Proof. by rewrite /insert !map_cat map_take map_nseq size_map map_drop. Qed.

Lemma nth_insert (xs ys : seq A) d d' n m :
  nth d (insert xs ys d' n) m =
  if m < n then nth d' ys m else
  if m < n + size xs then nth d' xs (m - n) else nth d ys (m - size xs).
Proof.
rewrite /insert !nth_cat size_take size_nseq -subnDA nth_drop nth_take'.
have ->: minn n (size ys) + (n - size ys) = n by ssromega.
elimif_omega; rewrite nth_nseq H0 nth_default //; ssromega.
Qed.

Lemma cons_insert n y (xs ys : seq A) d :
  y :: (insert xs ys d n) = insert xs (y :: ys) d n.+1.
Proof. by rewrite /insert /= subSS. Qed.

Lemma take_insert n (xs ys : seq A) d :
  take n (insert xs ys d n) = take n ys ++ nseq (n - size ys) d.
Proof.
by rewrite /insert take_cat size_take ltnNge geq_minl /= minnE subKn
           ?leq_subr // take_cat size_nseq ltnn subnn take0 cats0.
Qed.

Lemma drop_insert n (xs ys : seq A) d :
  drop (n + size xs) (insert xs ys d n) = drop n ys.
Proof.
rewrite /insert !catA drop_cat !size_cat size_take size_nseq drop_addn.
elimif_omega.
Qed.

End Insert.

(* context *)

Definition context A := (seq (option A)).

Notation ctxnth := (nth None).
Notation ctxindex xs n x := (Some x == ctxnth xs n).
Notation ctxmap f xs := (map (omap f) xs).
Notation ctxinsert xs ys n := (insert xs ys None n).

Section Context.

Variable (A : eqType).

Fixpoint ctxleq_rec (xs ys : context A) : bool :=
  match xs, ys with
    | [::], _ => true
    | (None :: xs), [::] => ctxleq_rec xs [::]
    | (None :: xs), (_ :: ys) => ctxleq_rec xs ys
    | (Some _ :: _), [::] => false
    | (Some x :: xs), (Some y :: ys) => (x == y) && ctxleq_rec xs ys
    | (Some _ :: _), (None :: _) => false
  end.

Definition ctxleq := nosimpl ctxleq_rec.

Infix "<=c" := ctxleq (at level 70, no associativity).

Lemma ctxleqE xs ys :
  (xs <=c ys) =
  ((head None xs == head None ys) || (head None xs == None)) &&
    (behead xs <=c behead ys).
Proof.
move: xs ys => [| [x |] xs] [| [y |] ys] //=.
by case/boolP: (Some x == None) => // _; rewrite orbF.
Qed.

Lemma ctxleqP (xs ys : context A) :
  reflect (forall n a, ctxindex xs n a -> ctxindex ys n a) (xs <=c ys).
Proof.
apply: (iffP idP); elim: xs ys => [| x xs IH].
- by move => ys _ n a; rewrite nth_nil.
- by case => [| y ys]; rewrite ctxleqE /= =>
    /andP [] /orP [] /eqP -> H [] //= n a /(IH _ H) //; rewrite nth_nil.
- by move => ys; rewrite ctxleqE eqxx orbT.
- by case => [| y ys]; rewrite ctxleqE /= => H; apply/andP;
    (split;
     [ case: x H; rewrite ?eqxx ?orbT // => x H; rewrite (H 0 x) |
       apply IH => n a /(H n.+1 a) ]).
Qed.

Lemma ctxleqxx (xs : context A) : xs <=c xs.
Proof. by apply/ctxleqP. Qed.

Lemma ctxleq_trans (xs ys zs : context A) :
  xs <=c ys -> ys <=c zs -> xs <=c zs.
Proof. do 2 move/ctxleqP => ?; apply/ctxleqP; auto. Qed.

Lemma ctxleq_app (xs xs' ys ys' : context A) :
  size xs = size xs' ->
  (xs ++ ys) <=c (xs' ++ ys') = (xs <=c xs') && (ys <=c ys').
Proof.
elim: xs xs' => [| x xs IH] [] //= x' xs' [].
by rewrite ctxleqE /=; move/IH => ->; apply esym; rewrite ctxleqE /= andbA.
Qed.

Lemma ctxleq_appl (xs ys zs : context A) :
  (xs ++ ys <=c xs ++ zs) = (ys <=c zs).
Proof. by rewrite ctxleq_app // ctxleqxx. Qed.

Lemma ctxleq_appr (xs ys : context A) : xs <=c (xs ++ ys).
Proof. by rewrite -{1}(cats0 xs) ctxleq_appl. Qed.

Lemma ctxindex_last ctx (x : A) : ctxindex (ctx ++ [:: Some x]) (size ctx) x.
Proof. by rewrite nth_cat ltnn subnn. Qed.

Lemma ctxinsert_leq n (xs ys zs : context A) :
  ctxinsert xs ys n <=c zs ->
  exists xs' ys', [&& zs <=c ctxinsert xs' ys' n, ctxinsert xs' ys' n <=c zs,
                      xs <=c xs' & ys <=c ys'].
Proof.
Abort.

End Context.

Infix "<=c" := ctxleq (at level 70, no associativity).

Lemma ctxnth_map A B (f : A -> B) xs n :
  ctxnth (ctxmap f xs) n = omap f (ctxnth xs n).
Proof. by elim: xs n => [| x xs IH] []. Defined.

Lemma ctxindex_map (A B : eqType) (f : A -> B) xs n x :
  ctxindex xs n x -> ctxindex (ctxmap f xs) n (f x).
Proof. by rewrite ctxnth_map => /eqP <-. Qed.

Lemma ctxleq_map (A B : eqType) (f : A -> B) xs ys :
  xs <=c ys -> ctxmap f xs <=c ctxmap f ys.
Proof.
move/ctxleqP => H; apply/ctxleqP => n a.
move: (H n); rewrite -!(nth_map' (omap f) None).
by case: (ctxnth xs n) => //= a' /(_ a' (eqxx _)) /eqP => <-.
Qed.

Hint Resolve ctxindex_map ctxleqxx ctxleq_trans ctxleq_app
             ctxleq_appl ctxleq_appr ctxleq_map.

(* Forall *)

Fixpoint Forall A (P : A -> Prop) xs :=
  if xs is x :: xs then P x /\ Forall P xs else True.

Lemma Forall_impl :
  forall (A : Type) (P Q : A -> Prop) xs,
  (forall a, P a -> Q a) -> Forall P xs -> Forall Q xs.
Proof. move => A P Q xs H; elim: xs; firstorder. Qed.

Lemma Forall_map (A B : Type) (f : A -> B) P xs :
  Forall P (map f xs) <-> Forall (P \o f) xs.
Proof. by elim: xs => //= x xs ->. Qed.

Lemma Forall_nth (A : Type) (P : A -> Prop) xs :
  Forall P xs <-> (forall x m, m < size xs -> P (nth x xs m)).
Proof.
elim: xs => //= x' xs [] IH IH'; split.
- by case => H H0 x [] //= n; rewrite ltnS; apply IH.
- move => H; split.
  + by apply (H x' 0).
  + by apply IH' => x m; apply (H x m.+1).
Qed.

Lemma allP' (A : eqType) (P : pred A) xs :
  reflect (Forall P xs) (all P xs).
Proof.
apply (iffP idP); elim: xs => //= x xs IH.
- by case/andP => -> /IH.
- by case => ->.
Qed.

(* zip *)

Fixpoint zipwith (A B C : Type) (f : A -> B -> C) xd yd
         (xs : seq A) (ys : seq B) : seq C :=
  match xs, ys with
    | [::], ys => map (f xd) ys
    | xs, [::] => map (f^~ yd) xs
    | x :: xs', y :: ys' => f x y :: zipwith f xd yd xs' ys'
  end.


From Hammer Require Import Hammer.

Require Import ClassicalFacts.

Hint Unfold not: core.

Axiom classic : forall P:Prop, P \/ ~ P.

Lemma NNPP : forall p:Prop, ~ ~ p -> p.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.NNPP".
unfold not; intros; elim (classic p); auto.
intro NP; elim (H NP).
Qed.

Lemma Peirce : forall P:Prop, ((P -> False) -> P) -> P.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.Peirce".
intros P H; destruct (classic P); auto.
Qed.

Lemma not_imply_elim : forall P Q:Prop, ~ (P -> Q) -> P.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.not_imply_elim".
intros; apply NNPP; red.
intro; apply H; intro; absurd P; trivial.
Qed.

Lemma not_imply_elim2 : forall P Q:Prop, ~ (P -> Q) -> ~ Q.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.not_imply_elim2".
tauto.
Qed.

Lemma imply_to_or : forall P Q:Prop, (P -> Q) -> ~ P \/ Q.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.imply_to_or".
intros; elim (classic P); auto.
Qed.

Lemma imply_to_and : forall P Q:Prop, ~ (P -> Q) -> P /\ ~ Q.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.imply_to_and".
intros; split.
apply not_imply_elim with Q; trivial.
apply not_imply_elim2 with P; trivial.
Qed.

Lemma or_to_imply : forall P Q:Prop, ~ P \/ Q -> P -> Q.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.or_to_imply".
tauto.
Qed.

Lemma not_and_or : forall P Q:Prop, ~ (P /\ Q) -> ~ P \/ ~ Q.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.not_and_or".
intros; elim (classic P); auto.
Qed.

Lemma or_not_and : forall P Q:Prop, ~ P \/ ~ Q -> ~ (P /\ Q).
Proof. hammer_hook "Classical_Prop" "Classical_Prop.or_not_and".
simple induction 1; red; simple induction 2; auto.
Qed.

Lemma not_or_and : forall P Q:Prop, ~ (P \/ Q) -> ~ P /\ ~ Q.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.not_or_and".
tauto.
Qed.

Lemma and_not_or : forall P Q:Prop, ~ P /\ ~ Q -> ~ (P \/ Q).
Proof. hammer_hook "Classical_Prop" "Classical_Prop.and_not_or".
tauto.
Qed.

Lemma imply_and_or : forall P Q:Prop, (P -> Q) -> P \/ Q -> Q.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.imply_and_or".
tauto.
Qed.

Lemma imply_and_or2 : forall P Q R:Prop, (P -> Q) -> P \/ R -> Q \/ R.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.imply_and_or2".
tauto.
Qed.

Lemma proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.proof_irrelevance".  exact (proof_irrelevance_cci classic). Qed.

Ltac classical_right := match goal with
|- ?X \/ _ => (elim (classic X);intro;[left;trivial|right])
end.

Ltac classical_left := match goal with
|- _ \/ ?X => (elim (classic X);intro;[right;trivial|left])
end.

Require Export EqdepFacts.

Module Eq_rect_eq.

Lemma eq_rect_eq :
forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
Proof. hammer_hook "Classical_Prop" "Classical_Prop.Eq_rect_eq.eq_rect_eq".
intros; rewrite proof_irrelevance with (p1:=h) (p2:=eq_refl p); reflexivity.
Qed.

End Eq_rect_eq.

Module EqdepTheory := EqdepTheory(Eq_rect_eq).
Export EqdepTheory.


(************************************************************************)
(*         *   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)         *)
(************************************************************************)

(** * A typeclass to ease the handling of decidable properties. *)

(** A proposition is decidable whenever it is reflected by a boolean. *)

Class Decidable (P : Prop) := {
  Decidable_witness : bool;
  Decidable_spec : Decidable_witness = true <-> P
}.

(** Alternative ways of specifying the reflection property. *)

Lemma Decidable_sound : forall P (H : Decidable P),
  Decidable_witness = true -> P.
Proof.
intros P H Hp; apply -> Decidable_spec; assumption.
Qed.

Lemma Decidable_complete : forall P (H : Decidable P),
  P -> Decidable_witness = true.
Proof.
intros P H Hp; apply <- Decidable_spec; assumption.
Qed.

Lemma Decidable_sound_alt : forall P (H : Decidable P),
   ~ P -> Decidable_witness = false.
Proof.
intros P [wit spec] Hd; simpl; destruct wit; tauto.
Qed.

Lemma Decidable_complete_alt : forall P (H : Decidable P),
  Decidable_witness = false -> ~ P.
Proof.
intros P [wit spec] Hd Hc; simpl in *; intuition congruence.
Qed.

(** The generic function that should be used to program, together with some
  useful tactics. *)

Definition decide P {H : Decidable P} := Decidable_witness (Decidable:=H).

Ltac _decide_ P H :=
  let b := fresh "b" in
  set (b := decide P) in *;
  assert (H : decide P = b) by reflexivity;
  clearbody b;
  destruct b; [apply Decidable_sound in H|apply Decidable_complete_alt in H].

Tactic Notation "decide" constr(P) "as" ident(H) :=
  _decide_ P H.

Tactic Notation "decide" constr(P) :=
  let H := fresh "H" in _decide_ P H.

(** Some usual instances. *)

Require Import Bool Arith ZArith.

Program Instance Decidable_eq_bool : forall (x y : bool), Decidable (eq x y) := {
  Decidable_witness := Bool.eqb x y
}.
Next Obligation.
 apply eqb_true_iff.
Qed.

Program Instance Decidable_eq_nat : forall (x y : nat), Decidable (eq x y) := {
  Decidable_witness := Nat.eqb x y
}.
Next Obligation.
 apply Nat.eqb_eq.
Qed.

Program Instance Decidable_le_nat : forall (x y : nat), Decidable (x <= y) := {
  Decidable_witness := Nat.leb x y
}.
Next Obligation.
 apply Nat.leb_le.
Qed.

Program Instance Decidable_eq_Z : forall (x y : Z), Decidable (eq x y) := {
  Decidable_witness := Z.eqb x y
}.
Next Obligation.
 apply Z.eqb_eq.
Qed.