From Undecidability.L Require Export Datatypes.LBool Datatypes.LNat Datatypes.LTerm.
Require Import Nat.
From Undecidability.L Require Import Tactics.LTactics Functions.EqBool.
Import EqBool.
(* * Extracted Functions *)

(* ** Extracted equality of encoded terms *)

Fixpoint term_eqb s t :=
  match s,t with
  | var n, var m => eqb n m
  | L.app s1 t1, L.app s2 t2 => andb (term_eqb s1 s2) (term_eqb t1 t2)
  | lam s',lam t' => term_eqb s' t'
  | _,_ => false
  end.

Lemma term_eqb_spec : forall x y1 : term, reflect (x = y1) (term_eqb x y1).
Proof with try (constructor;congruence).
  induction x;cbn; destruct y1...
  - destruct (eqb_spec n n0)...
  -destruct (IHx1 y1_1)...
   destruct (IHx2 y1_2)...
  -destruct (IHx y1)...
Qed.

#[global]
Instance eqbTerm : eqbClass term_eqb.
Proof.
  exact term_eqb_spec.
Qed.

Global
Instance eqbComp_nat : eqbCompT term.
Proof.
  evar (c:nat). exists c. unfold term_eqb.
  unfold enc;cbn. unfold term_enc.
  extract. unfold eqb,eqbTime.
  [c]:exact (5 + c__eqbComp nat).
  all:unfold c. set (c__eqbComp nat). change (LNat.nat_enc) with (enc (X:=nat)).
  solverec. all:try nia.
Qed.


Require Import Coq.Classes.RelationClasses.
Notation iffT A B := (((A -> B) * (B -> A)))%type.
Notation iffTp := (fun A B => inhabited (iffT A B)).

Global Instance iffTp_Reflexive : Reflexive iffTp | 1.
Proof. repeat constructor; intro; assumption. Defined.
Global Instance iffTp_Symmetric : Symmetric iffTp | 1.
Proof. repeat (intros [?] || intro); constructor; tauto. Defined.
Global Instance iffTp_Transitive : Transitive iffTp | 1.
Proof. repeat (intros [?] || intro); constructor; tauto. Defined.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.job prosa.classic.model.priority prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.model.schedule.global.basic.schedule prosa.classic.model.schedule.global.basic.interference
               prosa.classic.model.schedule.global.basic.platform.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module ConstrainedDeadlines.

  Import Job SporadicTaskset ScheduleOfSporadicTask SporadicTaskset
         TaskArrival Interference Priority Platform.

  Section Lemmas.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Assume any job arrival sequence ... *)
    Variable arr_seq: arrival_sequence Job.

    (* ... and any schedule of this arrival sequence. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.
    Hypothesis H_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched arr_seq.

    (* Assume all jobs have valid parameters, ...*)
    Hypothesis H_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* In this section we prove the absence of multiple jobs of the same
       task when constrained deadlines are assumed.  *)
    Section NoMultipleJobs.

      (* Assume any work-conserving priority-based scheduler. *)
      Variable higher_eq_priority: JLDP_policy Job.
      Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.
      Hypothesis H_respects_JLDP_policy:
        respects_JLDP_policy job_arrival job_cost arr_seq sched higher_eq_priority.

      (* Consider task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that all jobs come from the taskset. *)
      Hypothesis H_all_jobs_from_taskset:
        forall j,
          arrives_in arr_seq j -> job_task j \in ts.

      (* Suppose that jobs are sequential, ...*)
      Hypothesis H_sequential_jobs: sequential_jobs sched.
      (* ... jobs must arrive to execute, ... *)
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.
      (* ... and jobs do not execute after completion. *)
      Hypothesis H_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute job_arrival sched.

      (* Assume that the schedule satisfies the sporadic task model ...*)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Consider a valid task tsk, ...*)
      Variable tsk: sporadic_task.
      Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

      (*... whose job j ... *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Variable H_job_of_tsk: job_task j = tsk.

      (*... is backlogged at time t. *)
      Variable t: time.
      Hypothesis H_j_backlogged: backlogged job_arrival job_cost sched j t.

      (* Assume that any previous jobs of tsk have completed by the period. *)
      Hypothesis H_all_previous_jobs_completed :
        forall j_other tsk_other,
          arrives_in arr_seq j_other ->
          job_task j_other = tsk_other ->
          job_arrival j_other + task_period tsk_other <= t ->
          completed job_cost sched j_other (job_arrival j_other + task_period (job_task j_other)).

      Let scheduled_task_other_than (tsk tsk_other: sporadic_task) :=
        task_is_scheduled job_task sched tsk_other t && (tsk_other != tsk).

      (* Then, there can be at most one pending job of each task at time t. *)
      Lemma platform_at_most_one_pending_job_of_each_task :
        forall j1 j2,
          arrives_in arr_seq j1 ->
          arrives_in arr_seq j2 ->
          pending job_arrival job_cost sched j1 t ->
          pending job_arrival job_cost sched j2 t ->
          job_task j1 = job_task j2 ->
          j1 = j2.
      Proof.
        rename H_sporadic_tasks into SPO, H_all_previous_jobs_completed into PREV.
        intros j1 j2 ARR1 ARR2 PENDING1 PENDING2 SAMEtsk.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
        destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
        {
          specialize (SPO j1 j2 DIFF ARR1 ARR2 SAMEtsk BEFORE1).
          exploit (PREV j1 (job_task j1) ARR1);
            [by done | by apply leq_trans with (n := job_arrival j2) | intros COMP1].
          apply NOTCOMP1.
          apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1));
            try (by done).
          by apply leq_trans with (n := job_arrival j2).
        }
        {
          apply ltnW in BEFORE2.
          exploit (SPO j2 j1); try (by done); [by red; ins; subst | intro SPO'].
          exploit (PREV j2 (job_task j2) ARR2);
            [by done | by apply leq_trans with (n := job_arrival j1) | intros COMP2].
          apply NOTCOMP2.
          apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2));
            try (by done).
          by apply leq_trans with (n := job_arrival j1).
        }
      Qed.

      (* Therefore, all processors are busy with tasks other than tsk. *)
      Lemma platform_cpus_busy_with_interfering_tasks :
        count (scheduled_task_other_than tsk) ts = num_cpus.
      Proof.
        have UNIQ := platform_at_most_one_pending_job_of_each_task.
        rename H_all_jobs_from_taskset into FROMTS,
               H_sequential_jobs into SEQUENTIAL, H_work_conserving into WORK,
               H_respects_JLDP_policy into PRIO,
               H_j_backlogged into BACK, H_jobs_come_from_arrival_sequence into FROMarr,
               H_job_of_tsk into JOBtsk, H_valid_job_parameters into JOBPARAMS,
               H_valid_task into TASKPARAMS,
               H_all_previous_jobs_completed into PREV, H_completed_jobs_dont_execute into COMP,
               H_jobs_must_arrive_to_execute into ARRIVE.
        apply work_conserving_eq_work_conserving_count in WORK.
        unfold valid_sporadic_job, valid_realtime_job,
               respects_JLDP_policy, completed_jobs_dont_execute,
               sporadic_task_model, is_valid_sporadic_task,
               jobs_of_same_task_dont_execute_in_parallel,
               sequential_jobs in *.
        apply/eqP; rewrite eqn_leq; apply/andP; split.
        {
          apply leq_trans with (n := count (fun x => task_is_scheduled job_task sched x t) ts);
            first by apply sub_count; first by red; move => x /andP [SCHED _].
          unfold task_is_scheduled.
          apply count_exists; first by destruct ts.
          {
            intros cpu x1 x2 SCHED1 SCHED2.
            unfold task_scheduled_on in *.
            destruct (sched cpu t); last by done.
            move: SCHED1 SCHED2 => /eqP SCHED1 /eqP SCHED2.
            by rewrite -SCHED1 -SCHED2.
          }
        }
        {
          rewrite -(WORK j t) // -count_predT.
          apply leq_trans with (n := count (fun j => scheduled_task_other_than tsk (job_task j)) (jobs_scheduled_at sched t));
            last first.
          {
            rewrite -count_map.
            apply count_sub_uniqr; last first.
            {
              move => tsk' /mapP [j' INj' JOBtsk']; subst; apply FROMTS.
              by rewrite mem_scheduled_jobs_eq_scheduled in INj'; eauto 2.
            }
            rewrite map_inj_in_uniq; first by apply scheduled_jobs_uniq.
            red; intros j1 j2 SCHED1 SCHED2 SAMEtsk.
            rewrite 2!mem_scheduled_jobs_eq_scheduled in SCHED1 SCHED2.
            have ARRin1: arrives_in arr_seq j1 by apply (FROMarr j1 t).
              have ARRin2: arrives_in arr_seq j2 by apply (FROMarr j2 t).
              by apply UNIQ; try (by done); apply scheduled_implies_pending.
          }
          {
            apply sub_in_count; intros j' SCHED' _.
            rewrite mem_scheduled_jobs_eq_scheduled in SCHED'.
            unfold scheduled_task_other_than; apply/andP; split.
            {
              move: SCHED' => /existsP [cpu /eqP SCHED'].
              by apply/existsP; exists cpu; rewrite /task_scheduled_on SCHED' eq_refl.
            }
            {
              apply/eqP; red; intro SAMEtsk; symmetry in SAMEtsk.
              move: BACK => /andP [PENDING NOTSCHED].
              have ARRin': arrives_in arr_seq j' by apply (FROMarr j' t).
              exploit (UNIQ j j'); try (by done);
                [by apply scheduled_implies_pending | by rewrite -SAMEtsk |].
              by intro EQjob; subst; rewrite SCHED' in NOTSCHED.
            }
          }
        }
      Qed.

    End NoMultipleJobs.

    (* In this section we also prove the absence of multiple jobs of the same
       task when constrained deadlines are assumed, but in the specific case
       of fixed-priority scheduling.  *)
    Section NoMultipleJobsFP.

      (* Assume any work-conserving priority-based scheduler. *)
      Variable higher_eq_priority: FP_policy sporadic_task.
      Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.
      Hypothesis H_respects_JLDP_policy:
        respects_FP_policy job_arrival job_cost job_task arr_seq sched higher_eq_priority.

      (* Consider any task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that all jobs come from the taskset. *)
      Hypothesis H_all_jobs_from_taskset:
        forall j,
          arrives_in arr_seq j -> job_task j \in ts.

      (* Suppose that jobs are sequential, ...*)
      Hypothesis H_sequential_jobs: sequential_jobs sched.
      (* ... jobs must arrive to execute, ... *)
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.
      (* ... and jobs do not execute after completion. *)
      Hypothesis H_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute job_arrival sched.

      (* Assume that jobs arrive sporadically. *)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Consider a valid task tsk, ...*)
      Variable tsk: sporadic_task.
      Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

      (*... whose job j ... *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Variable H_job_of_tsk: job_task j = tsk.

      (*... is backlogged at time t <= job_arrival j + task_period tsk. *)
      Variable t: time.
      Hypothesis H_j_backlogged: backlogged job_arrival job_cost sched j t.
      Hypothesis H_t_before_period: t < job_arrival j + task_period tsk.

      (* Recall the definition of a higher-priority task (with respect to tsk). *)
      Let is_hp_task := higher_priority_task higher_eq_priority tsk.

      (* Assume that any jobs of higher-priority tasks complete by their period. *)
      Hypothesis H_all_previous_jobs_completed :
        forall j_other tsk_other,
          arrives_in arr_seq j_other ->
          job_task j_other = tsk_other ->
          is_hp_task tsk_other ->
          completed job_cost sched j_other (job_arrival j_other + task_period tsk_other).

      (* Assume that any jobs of tsk prior to j complete by their period. *)
      Hypothesis H_all_previous_jobs_of_tsk_completed :
        forall j0,
          arrives_in arr_seq j0 ->
          job_task j0 = tsk ->
          job_arrival j0 < job_arrival j ->
          completed job_cost sched j0 (job_arrival j0 + task_period tsk).

      Definition scheduled_task_with_higher_eq_priority (tsk tsk_other: sporadic_task) :=
        task_is_scheduled job_task sched tsk_other t &&
        is_hp_task tsk_other.

      (* Then, there can be at most one pending job of higher-priority tasks at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_interfering_tasks :
        forall j1 j2,
          arrives_in arr_seq j1 ->
          arrives_in arr_seq j2 ->
          pending job_arrival job_cost sched j1 t ->
          pending job_arrival job_cost sched j2 t ->
          job_task j1 = job_task j2 ->
          is_hp_task (job_task j1) ->
          j1 = j2.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO, H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV.
        intros j1 j2 ARR1 ARR2 PENDING1 PENDING2 SAMEtsk INTERF.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
        destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
        {
          specialize (SPO j1 j2 DIFF ARR1 ARR2 SAMEtsk BEFORE1).
          exploit (PREV j1 (job_task j1) ARR1); [by done | by apply INTERF | intros COMP1].
          apply NOTCOMP1.
          apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1));
            try (by done).
          by apply leq_trans with (n := job_arrival j2).
        }
        {
          apply ltnW in BEFORE2.
          exploit (SPO j2 j1); try (by done); [by red; ins; subst j2 | intro SPO'].
          exploit (PREV j2 (job_task j2) ARR2);
            [by done | by rewrite -SAMEtsk | intro COMP2 ].
          apply NOTCOMP2.
          apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2));
            try (by done).
          by apply leq_trans with (n := job_arrival j1).
        }
      Qed.

      (* Also, there can be at most one pending job of tsk at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_tsk :
        forall j',
          arrives_in arr_seq j' ->
          pending job_arrival job_cost sched j' t ->
          job_task j' = tsk ->
          j' = j.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO,
               H_valid_task into PARAMS,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV,
               H_j_backlogged into BACK, H_job_of_tsk into JOBtsk.
        intros j' ARR' PENDING' SAMEtsk.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: BACK PENDING' => /andP [/andP [ARRIVED /negP NOTCOMP] NOTSCHED]
                               /andP [ARRIVED' /negP NOTCOMP'].
        destruct (leqP (job_arrival j') (job_arrival j)) as [BEFORE | BEFORE'].
        {
          exploit (SPO j' j DIFF ARR' H_j_arrives); [by rewrite JOBtsk | by done | intro SPO'].
          apply NOTCOMP'.
          apply completion_monotonic with (t0 := job_arrival j' + task_period tsk); try (by done);
            first by apply leq_trans with (n := job_arrival j); [by rewrite -SAMEtsk | by done].
          {
            apply PREVtsk; try (by done).
            apply leq_trans with (n := job_arrival j' + task_period tsk); last by rewrite -SAMEtsk.
            rewrite -addn1; apply leq_add; first by done.
            by unfold is_valid_sporadic_task in *; des.
          }
        }
        {
          unfold has_arrived in *.
          rewrite leqNgt in ARRIVED'; move: ARRIVED' => /negP BUG; apply BUG.
          apply leq_trans with (n := job_arrival j + task_period tsk); first by done.
          by rewrite -JOBtsk; apply SPO; try (by done);
            [by red; ins; subst j' | by rewrite SAMEtsk | by apply ltnW].
        }
      Qed.

      (* Therefore, all processors are busy with tasks other than tsk. *)
      Lemma platform_fp_cpus_busy_with_interfering_tasks :
        count (scheduled_task_with_higher_eq_priority tsk) ts = num_cpus.
      Proof.
        have UNIQ := platform_fp_no_multiple_jobs_of_interfering_tasks.
        have UNIQ' := platform_fp_no_multiple_jobs_of_tsk.
        rename H_all_jobs_from_taskset into FROMTS, H_sequential_jobs into SEQUENTIAL,
               H_work_conserving into WORK, H_respects_JLDP_policy into PRIO,
               H_j_backlogged into BACK, H_job_of_tsk into JOBtsk,
               H_sporadic_tasks into SPO, H_valid_job_parameters into JOBPARAMS,
               H_valid_task into TASKPARAMS, H_all_previous_jobs_completed into PREV,
               H_completed_jobs_dont_execute into COMP, H_jobs_come_from_arrival_sequence into FROMarr,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_jobs_must_arrive_to_execute into ARRIVE.
        apply work_conserving_eq_work_conserving_count in WORK.
        unfold valid_sporadic_job, valid_realtime_job,
               respects_FP_policy, respects_JLDP_policy, FP_to_JLDP,
               completed_jobs_dont_execute, sequential_jobs,
               sporadic_task_model, is_valid_sporadic_task,
               jobs_of_same_task_dont_execute_in_parallel,
               is_hp_task in *.
        apply/eqP; rewrite eqn_leq; apply/andP; split.
        {
          apply leq_trans with (n := count (fun x => task_is_scheduled job_task sched x t) ts);
            first by apply sub_count; red; move => x /andP [SCHED _].
          unfold task_is_scheduled.
          apply count_exists; first by destruct ts.
          {
            intros cpu x1 x2 SCHED1 SCHED2.
            unfold task_scheduled_on in *.
            destruct (sched cpu t); last by done.
            move: SCHED1 SCHED2 => /eqP SCHED1 /eqP SCHED2.
            by rewrite -SCHED1 -SCHED2.
          }
        }
        {
          rewrite -(WORK j t) // -count_predT.
          apply leq_trans with (n := count (fun j =>
            scheduled_task_with_higher_eq_priority tsk (job_task j)) (jobs_scheduled_at sched t));
            last first.
          {
            rewrite -count_map.
            apply leq_trans with (n := count predT [seq x <- (map (fun j => job_task j) (jobs_scheduled_at sched t)) | scheduled_task_with_higher_eq_priority tsk x]);
              first  by rewrite count_filter; apply sub_count; red; ins.
            apply leq_trans with (n := count predT [seq x <- ts | scheduled_task_with_higher_eq_priority tsk x]);
              last by rewrite count_predT size_filter.
            apply count_sub_uniqr; last first.
            {
              red; intros tsk' IN'.
              rewrite mem_filter in IN'; move: IN' => /andP [SCHED IN'].
              rewrite mem_filter; apply/andP; split; first by done.
              move: IN' => /mapP [j' IN'] ->; apply FROMTS.
              by rewrite mem_scheduled_jobs_eq_scheduled in IN'; eauto 2.
            }
            {
              rewrite filter_map.
              rewrite map_inj_in_uniq; first by apply filter_uniq, scheduled_jobs_uniq.
              red; intros j1 j2 SCHED1 SCHED2 SAMEtsk.
              rewrite 2!mem_filter in SCHED1 SCHED2.
              move: SCHED1 SCHED2 => /andP [/andP [_ HP1] SCHED1] /andP [/andP [_ HP2] SCHED2].
              rewrite 2!mem_scheduled_jobs_eq_scheduled in SCHED1 SCHED2.
              have ARRin1: arrives_in arr_seq j1 by apply (FROMarr j1 t).
              have ARRIn2: arrives_in arr_seq j2 by apply (FROMarr j2 t).
              by apply UNIQ; try (by done); apply scheduled_implies_pending.
            }
          }
          {
            apply sub_in_count; intros j' SCHED' _.
            rewrite mem_scheduled_jobs_eq_scheduled in SCHED'.
            apply/andP; split.
            {
              move: SCHED' => /existsP [cpu /eqP SCHED'].
              by apply/existsP; exists cpu; rewrite /task_scheduled_on SCHED' eq_refl.
            }
            apply/andP; split; first by rewrite -JOBtsk; apply PRIO with (t := t).
            {
              apply/eqP; red; intro SAMEtsk.
              generalize SCHED'; intro PENDING'.
              have ARRin': arrives_in arr_seq j' by apply (FROMarr j' t).
              apply scheduled_implies_pending with (job_arrival0 := job_arrival)
                (job_cost0 := job_cost) in PENDING'; try (by done).
              specialize (UNIQ' j' ARRin' PENDING' SAMEtsk); subst j'.
              by move: BACK => /andP [_ NOTSCHED]; rewrite SCHED' in NOTSCHED.
            }
          }
        }
      Qed.

    End NoMultipleJobsFP.

  End Lemmas.

End ConstrainedDeadlines.


Definition inj{X Y}(f : X -> Y) := forall x x', f x = f x' -> x = x'.

Definition surj{X Y}(f : X -> Y) := forall y, {x : X & f x = y}.

Definition ded_fin(X : Set) := forall f : X -> X, inj f -> surj f.

Section df_inh_cancel_sgroups.

Variable X : Set.
Variable x0 : X.
Variable m : X -> X -> X.

Infix "*" := m.

Hypothesis X_df : ded_fin X.
Hypothesis assoc : forall x y z, x * (y * z) = (x * y) * z.
Hypothesis l_cancel : forall x y z, x * y = x * z -> y = z.
Hypothesis r_cancel : forall x y z, y * x = z * x -> y = z.

Lemma l_mult_inj : forall x, inj (m x).
Proof.
  intros x y z H.
  exact (l_cancel _ _ _ H).
Qed.

Lemma r_mult_inj : forall x, inj (fun y => m y x).
Proof.
  intros x y z H.
  exact (r_cancel _ _ _ H).
Qed.

Lemma r_eq_solve : forall a b, {x : X & a * x = b}.
Proof.
  intros.
  destruct (X_df (m a) (l_mult_inj a) b).
  exists x; exact e.
Qed.

Lemma l_eq_solve : forall a b, {x : X & x * a = b}.
Proof.
  intros.
  destruct (X_df (fun y => m y a) (r_mult_inj a) b).
  exists x; exact e.
Qed.

(* the identity *)
Definition e : X := projT1 (l_eq_solve x0 x0).

Lemma l_x0_id : e * x0 = x0.
Proof.
  unfold e.
  destruct (l_eq_solve x0 x0).
  simpl.
  exact e0.
Qed.

Theorem l_id : forall x, e * x = x.
Proof.
  intro.
  destruct (r_eq_solve x0 x) as [y Hy].
  rewrite <- Hy.
  rewrite assoc.
  rewrite l_x0_id.
  reflexivity.
Qed.

Theorem r_id : forall x, x * e = x.
Proof.
  intro.
  apply (r_cancel e).
  rewrite <- assoc.
  rewrite l_id.
  reflexivity.
Qed.

(* the inverse operations *)
Definition inv : X -> X := fun x => projT1 (l_eq_solve x e).

Theorem l_inv : forall x, (inv x) * x = e.
Proof.
  intro.
  unfold inv.
  destruct (l_eq_solve x e).
  simpl.
  exact e0.
Qed.

Theorem r_inv : forall x, x * (inv x) = e.
Proof.
  intro.
  apply (r_cancel x).
  rewrite <- assoc.
  rewrite l_inv.
  rewrite l_id, r_id.
  reflexivity.
Qed.

End df_inh_cancel_sgroups.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.naturals MathClasses.theory.categories
  MathClasses.categories.varieties.
Require
  MathClasses.varieties.rings.

Section initial_maps.
  Variable A : Type.

  Class IntegersToRing :=
    integers_to_ring: ∀ R `{Mult R} `{Plus R} `{One R} `{Zero R} `{Negate R}, A → R.

  Context `{IntegersToRing} `{Ring A} `{∀ `{Ring B}, SemiRing_Morphism (integers_to_ring B)}.

  Global Instance integer_initial_arrow: InitialArrow (rings.object A).
   intro y.
   exists (λ u, match u return A → y u with tt => integers_to_ring (y tt) end).
   abstract (apply rings.encode_morphism_only; apply _).
  Defined. (* for some reason [Program] isn't cooperating here. look into it *)

  Lemma integer_initial (same_morphism : ∀ `{Ring B} {h :  A → B} `{!SemiRing_Morphism h}, integers_to_ring B = h) :
    Initial (rings.object A).
  Proof.
    intros y [x h] [] ?. simpl in *.
    apply same_morphism.
      apply rings.decode_variety_and_ops.
     apply (@rings.decode_morphism_and_ops _ _ _ _ _ _ _ _ _ h).
    reflexivity.
  Qed.
End initial_maps.

Instance: Params (@integers_to_ring) 8.

Class Integers A {e plus mult zero one negate} `{U : IntegersToRing A} :=
  { integers_ring:> @Ring A e plus mult zero one negate
  ; integers_to_ring_mor:> ∀ `{Ring B}, SemiRing_Morphism (integers_to_ring A B)
  ; integers_initial:> Initial (rings.object A) }.

Section specializable.
  Context (Z N : Type) `{Integers Z} `{Naturals N}.

  Class IntAbs := int_abs_sig : ∀ x,
    { n : N | naturals_to_semiring N Z n = x } + { n : N | naturals_to_semiring N Z n = -x }.

  Definition int_abs `{ia : IntAbs} (x : Z) : N :=
    match int_abs_sig x with
    | inl (n↾_) => n
    | inr (n↾_) => n
    end.

  Definition int_to_nat `{Zero N} `{ia : IntAbs} (x : Z) : N :=
    match int_abs_sig x with
    | inl (n↾_) => n
    | inr (n↾_) => 0
    end.
End specializable.

Instance: Params (@int_abs) 10.
Instance: Params (@int_abs_sig) 10.
Instance: Params (@int_to_nat) 11.


(** * Classification of the [×] Type *)
(** In this file, we classify the basic structure of [×] types ([prod]
    in Coq).  In particular, we classify equalities of non-dependent
    pairs (inhabitants of [×] types), so that when we have an equality
    between two such pairs, or when we want such an equality, we have
    a systematic way of reducing such equalities to equalities at
    simpler types. *)
Require Import Crypto.Util.Equality.
Require Export Crypto.Util.GlobalSettings.
Require Export Crypto.Util.FixCoqMistakes.

Local Arguments fst {_ _} _.
Local Arguments snd {_ _} _.
Local Arguments f_equal {_ _} _ {_ _} _.

(*Scheme Equality for Datatypes.prod.*)

Definition prod_beq (A B : Type) (eq_A : A -> A -> bool) (eq_B : B -> B -> bool) (X Y : A * B) : bool
  := (eq_A (fst X) (fst Y) && eq_B (snd X) (snd Y))%bool.

Lemma internal_prod_dec_bl
      (A B : Type) (eq_A : A -> A -> bool) (eq_B : B -> B -> bool) (A_bl : forall x y : A, eq_A x y = true -> x = y)
      (B_bl : forall x y : B, eq_B x y = true -> x = y) (x y : A * B)
  : prod_beq A B eq_A eq_B x y = true -> x = y.
Proof.
  unfold prod_beq.
  specialize (A_bl (fst x) (fst y)).
  specialize (B_bl (snd x) (snd y)).
  edestruct eq_A, eq_B; simpl; try reflexivity; try discriminate.
  destruct x, y; simpl in *; destruct A_bl, B_bl; reflexivity.
Defined.

Lemma internal_prod_dec_lb
      (A B : Type) (eq_A : A -> A -> bool) (eq_B : B -> B -> bool) (A_lb : forall x y : A, x = y -> eq_A x y = true)
      (B_lb : forall x y : B, x = y -> eq_B x y = true) (x y : A * B)
  : x = y -> prod_beq A B eq_A eq_B x y = true.
Proof.
  unfold prod_beq.
  intro; subst y.
  rewrite A_lb, B_lb by reflexivity; reflexivity.
Defined.

Definition prod_eq_dec
           (A B : Type) (eq_A : A -> A -> bool) (eq_B : B -> B -> bool) (A_bl : forall x y : A, eq_A x y = true -> x = y)
           (B_bl : forall x y : B, eq_B x y = true -> x = y) (A_lb : forall x y : A, x = y -> eq_A x y = true)
           (B_lb : forall x y : B, x = y -> eq_B x y = true) (x y : A * B)
  : { x = y } + { x <> y }.
Proof.
  destruct (prod_beq A B eq_A eq_B x y) eqn:H; [ left | right ].
  { eauto using internal_prod_dec_bl. }
  { intro; subst y.
    rewrite internal_prod_dec_lb in H by auto.
    discriminate. }
Defined.

Definition surjective_pairing : forall {A B : Type} (p : A * B), p = (fst p, snd p)
  := fun _ _ _ => eq_refl.

(** ** Equality for [prod] *)
Section prod.
  (** *** Projecting an equality of a pair to equality of the first components *)
  Definition fst_path {A B} {u v : prod A B} (p : u = v)
  : fst u = fst v
    := f_equal fst p.

  (** *** Projecting an equality of a pair to equality of the second components *)
  Definition snd_path {A B} {u v : prod A B} (p : u = v)
  : snd u = snd v
    := f_equal snd p.

  (** *** Equality of [prod] is itself a [prod] *)
  Definition path_prod_uncurried {A B : Type} (u v : prod A B)
             (pq : prod (fst u = fst v) (snd u = snd v))
    : u = v.
  Proof.
    destruct u as [u1 u2], v as [v1 v2]; simpl in *.
    destruct pq as [p q].
    destruct p, q; simpl in *.
    reflexivity.
  Defined.

  (** *** Curried version of proving equality of sigma types *)
  Definition path_prod {A B : Type} (u v : prod A B)
             (p : fst u = fst v) (q : snd u = snd v)
    : u = v
    := path_prod_uncurried u v (pair p q).

  (** *** Equivalence of equality of [prod] with a [prod] of equality *)
  (** We could actually use [IsIso] here, but for simplicity, we
      don't.  If we wanted to deal with proofs of equality of × types
      in dependent positions, we'd need it. *)
  Definition path_prod_uncurried_iff {A B}
             (u v : @prod A B)
    : u = v <-> (prod (fst u = fst v) (snd u = snd v)).
  Proof.
    split; [ intro; subst; split; reflexivity | apply path_prod_uncurried ].
  Defined.

  (** *** Eta-expansion of [@eq (prod _ _)] *)
  Definition path_prod_eta {A B} {u v : @prod A B} (p : u = v)
    : p = path_prod_uncurried u v (fst_path p, snd_path p).
  Proof. destruct u, p; reflexivity. Defined.

  (** *** Induction principle for [@eq (prod _ _)] *)
  Definition path_prod_rect {A B} {u v : @prod A B} (P : u = v -> Type)
             (f : forall p q, P (path_prod_uncurried u v (p, q)))
    : forall p, P p.
  Proof. intro p; specialize (f (fst_path p) (snd_path p)); destruct u, p; exact f. Defined.
  Definition path_prod_rec {A B u v} (P : u = v :> @prod A B -> Set) := path_prod_rect P.
  Definition path_prod_ind {A B u v} (P : u = v :> @prod A B -> Prop) := path_prod_rec P.
End prod.

(** ** Useful Tactics *)
(** *** [inversion_prod] *)
Ltac simpl_proj_pair_in H :=
  repeat match type of H with
         | context G[fst (pair ?x ?p)]
           => let G' := context G[x] in change G' in H
         | context G[snd (pair ?x ?p)]
           => let G' := context G[p] in change G' in H
         end.
Ltac induction_path_prod H :=
  let H0 := fresh H in
  let H1 := fresh H in
  induction H as [H0 H1] using path_prod_rect;
  simpl_proj_pair_in H0;
  simpl_proj_pair_in H1.
Ltac inversion_prod_step :=
  match goal with
  | [ H : _ = pair _ _ |- _ ]
    => induction_path_prod H
  | [ H : pair _ _ = _ |- _ ]
    => induction_path_prod H
  end.
Ltac inversion_prod := repeat inversion_prod_step.

(** This turns a goal like [x = let v := p in let '(x, y) := f v in x
    + y)] into a goal like [x = fst (f p) + snd (f p)].  Note that it
    inlines [let ... in ...] as well as destructuring lets. *)
Ltac only_eta_expand_and_contract :=
  repeat match goal with
         | [ |- context[let '(x, y) := ?e in _] ]
           => rewrite (surjective_pairing e)
         | _ => rewrite <- !surjective_pairing
         end.
Ltac eta_expand :=
  repeat match goal with
         | _ => progress cbv beta iota zeta
         | [ |- context[let '(x, y) := ?e in _] ]
           => rewrite (surjective_pairing e)
         | _ => rewrite <- !surjective_pairing
         end.


Require Import Arith.
Require Import fol.
Require Import primRec.
Require Import Coq.Lists.List.

(* begin snippet LNTDef1 *)
Inductive LNTFunction : Set :=
  | Plus_ : LNTFunction
  | Times_ : LNTFunction
  | Succ_ : LNTFunction
  | Zero_ : LNTFunction.

Inductive LNNRelation : Set :=
    LT_ : LNNRelation.

Inductive LNTRelation : Set :=.

Definition LNTFunctionArity (x : LNTFunction) : nat :=
  match x with
  | Plus_ => 2
  | Times_ => 2
  | Succ_ => 1
  | Zero_ => 0
  end.
(* end snippet LNTDef1 *)

(* begin snippet LNTDef2 *)
Definition LNTRelationR (x :  LNTRelation) : nat :=
  match x with bot => LNTRelation_rec (fun _ => nat) bot end.

Definition LNNArityR (x : LNNRelation) : nat :=
 match x with LT_ => 2 end.

Definition LNNArityF (f : LNTFunction) :=
     LNTFunctionArity f.

Definition LNT : Language := language LNTRelation  LNTFunction LNTRelationR LNTFunctionArity.

Definition LNN : Language := language LNNRelation LNTFunction
                               LNNArityR LNNArityF.
(* end snippet LNTDef2 *)

Definition codeLNTFunction (f : LNTFunction) : nat :=
  match f with
  | Plus_ => 0
  | Times_ => 1
  | Succ_ => 2
  | Zero => 3
  end.

Definition codeLNTRelation (R : LNTRelation) : nat :=
  match R return nat with
  end.

Definition codeLNNRelation (R : LNNRelation) : nat := 0.

Lemma codeLNTFunctionInj :
 forall f g : LNTFunction, codeLNTFunction f = codeLNTFunction g -> f = g.
Proof.
  intros f g H; destruct f; destruct g; reflexivity || discriminate H.
Qed.

Lemma codeLNTRelationInj :
 forall R S : LNTRelation, codeLNTRelation R = codeLNTRelation S -> R = S.
Proof.
  intros R S H;
    destruct R; destruct S; reflexivity || discriminate H.
Qed.

Lemma codeLNNRelationInj :
 forall R S : LNNRelation, codeLNNRelation R = codeLNNRelation S -> R = S.
Proof.
  intros R S H;
    destruct R; destruct S; reflexivity || discriminate H.
Qed.

Definition codeArityLNNR (r : nat) := switchPR r 0 3.

Lemma codeArityLNNRIsPR : isPR 1 codeArityLNNR.
Proof.
  unfold codeArityLNNR in |- *;
    apply compose1_3IsPR with
    (f1 := fun r : nat => r)
    (f2 := fun r : nat => 0)
    (f3 := fun r : nat => 3).
  - apply idIsPR.
  - apply const1_NIsPR.
  - apply const1_NIsPR.
  - apply switchIsPR.
Qed.

Lemma codeArityLNNRIsCorrect1 :
  forall r : Relations LNN,
    codeArityLNNR (codeLNNRelation r) = S (arityR LNN r).
Proof. destruct r; reflexivity. Qed.

Lemma codeArityLNNRIsCorrect2 :
 forall n : nat,
 codeArityLNNR n <> 0 -> exists r : Relations LNN, codeLNNRelation r = n.
Proof.
  intros n H; destruct n.
  - exists LT_; reflexivity.
  - now destruct H.
Qed.

Definition codeArityLNTR (r : nat) := 0.

Lemma codeArityLNTRIsPR : isPR 1 codeArityLNTR.
Proof.
  unfold codeArityLNTR; apply const1_NIsPR.
Qed.

Lemma codeArityLNTRIsCorrect1 :
 forall r : Relations LNT,
 codeArityLNTR (codeLNTRelation r) = S (arityR LNT r).
Proof. simple induction r. Qed.

Lemma codeArityLNTRIsCorrect2 :
 forall n : nat,
 codeArityLNTR n <> 0 -> exists r : Relations LNT, codeLNTRelation r = n.
Proof.  destruct 1; easy. Qed.

Definition codeArityLNTF (f : nat) :=
  switchPR f
    (switchPR (pred f)
       (switchPR (pred (pred f)) (switchPR (pred (pred (pred f))) 0 1) 2) 3)
    3.

Lemma codeArityLNTFIsPR : isPR 1 codeArityLNTF.
Proof.
  set
    (f :=
       list_rec (fun _ => nat -> nat -> nat) (fun _ _ : nat => 0)
         (fun (a : nat) (l : list nat) (rec : nat -> nat -> nat) (n f : nat) =>
            switchPR (iterate pred n f) (rec (S n) f) a))
    in *.
  assert (H: forall (l : list nat) (n : nat), isPR 1 (f l n)).
  { induction l as [| a l Hrecl]; intros.
    - simpl; apply const1_NIsPR.
    - simpl; apply
               compose1_3IsPR
        with
        (f1 := fun f0 : nat => iterate pred n f0)
        (f2 := fun f0 : nat => f l (S n) f0)
        (f3 := fun f0 : nat => a).
      + apply iterateIsPR with (g := pred) (n := n).
        apply predIsPR.
      + apply Hrecl with (n := S n).
      + apply const1_NIsPR.
      + apply switchIsPR.
  } apply (H (3 :: 3 :: 2 :: 1 :: nil) 0).
Qed.

Lemma codeArityLNTFIsCorrect1 :
 forall f : Functions LNT,
 codeArityLNTF (codeLNTFunction f) = S (arityF LNT f).
Proof. induction f; reflexivity. Qed.

Lemma codeArityLNNFIsCorrect1 :
 forall f : Functions LNN,
 codeArityLNTF (codeLNTFunction f) = S (arityF LNN  f).
Proof. apply codeArityLNTFIsCorrect1. Qed.

Lemma codeArityLNTFIsCorrect2 :
 forall n : nat,
 codeArityLNTF n <> 0 ->
 exists f : Functions LNT, codeLNTFunction f = n.
Proof.
  intros n H; destruct n as [| n].
  - exists Plus_; easy.
  - destruct n as [| n].
    + exists Times_; easy.
    + destruct n as [| n].
      * exists Succ_; easy.
      * destruct n as [| n].
        -- exists Zero_; easy.
        -- destruct H; reflexivity.
Qed.

Lemma codeArityLNNFIsCorrect2 :
  forall n : nat,
    codeArityLNTF n <> 0 -> exists f : Functions LNN, codeLNTFunction f = n.
Proof.
  apply codeArityLNTFIsCorrect2.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sebastien Hinderer, 2004-04-02
- Adam Koprowski, 2007-03-29, Added [mult_gt_0] and [mult_lt_compat_lr]

useful definitions and lemmas on natural numbers
*)

Set Implicit Arguments.

Require Import CoLoRLogicUtil.
Require Export Arith.
Require Export Omega.

(***********************************************************************)
(** implicit arguments *)

Implicit Arguments lt_S_n [n m].
Implicit Arguments lt_n_S [n m].
Implicit Arguments le_S [n m].
Implicit Arguments gt_le_S [n m].
Implicit Arguments le_lt_n_Sm [n m].
Implicit Arguments lt_le_weak [n m].
Implicit Arguments le_plus_minus [n m].
Implicit Arguments le_plus_minus_r [n m].

(***********************************************************************)
(** tactics *)

Ltac absurd_arith := elimtype False; omega.

(***********************************************************************)
(** decidability of equality *)

Fixpoint beq_nat (x y : nat) {struct x} :=
  match x, y with
    | 0, 0 => true
    | S x', S y' => beq_nat x' y'
    | _, _ => false
  end.

Lemma beq_nat_ok : forall x y, beq_nat x y = true <-> x = y.

Proof.
induction x; destruct y; simpl; split; intro; try (refl || discriminate).
apply (f_equal S). exact (proj1 (IHx _) H).
apply (proj2 (IHx y)). inversion H. refl.
Defined.

Require Import CoLoREqUtil.

Ltac case_nat_eq x y := case_beq beq_nat_ok (beq_nat x y).

(*FIXME Definition eq_nat_dec := dec_beq beq_nat_ok. *)

Lemma eq_nat_dec_refl : forall n, eq_nat_dec n n = left (n<>n) (refl_equal n).

Proof.
intro. generalize (eq_nat_dec n n). destruct s.
rewrite (UIP_refl eq_nat_dec e). refl. irrefl.
Qed.

(*old version with Coq's eq_nat_dec:
Lemma eq_nat_dec_refl : forall n, eq_nat_dec n n = left (n<>n) (refl_equal n).

Proof.
induction n; simpl. reflexivity. rewrite IHn. reflexivity.
Qed.*)

(***********************************************************************)
(** unicity of le and lt proofs *)

Scheme le_ind_dep := Induction for le Sort Prop.

Lemma le_unique : forall n m (h1 h2 : le n m), h1 = h2.

Proof.
intro n.
assert (forall m : nat, forall h1 : le n m, forall p : nat, forall h2 : le n p,
  m=p -> eq_dep nat (le n) m h1 p h2).
 intros m h1; elim h1 using le_ind_dep.
  intros p h2; case h2; intros.
   auto.
   subst n. absurd (S m0 <= m0); auto with arith.
 intros m0 l Hrec p h2.
  case h2; intros.
   subst n; absurd (S m0 <= m0); auto with arith.
   assert (m0=m1); auto ; subst m0.
   replace l0 with l; auto.
   apply (@eq_dep_eq _ eq_nat_dec (le n) m1); auto.
 intros; apply (@eq_dep_eq _ eq_nat_dec (le n) m); auto.
Qed.

Lemma lt_unique : forall n m (h1 h2 : lt n m), h1 = h2.

Proof.
intros n m. unfold lt. intros. apply le_unique.
Qed.

Lemma lt_Sn_nS : forall m n (H : m < n), lt_S_n (lt_n_S H) = H.

Proof.
  intros. apply lt_unique.
Qed.

Lemma lt_nS_Sn : forall m n (H : S m < S n), lt_n_S (lt_S_n H) = H.

Proof.
  intros. apply lt_unique.
Qed.

(***********************************************************************)
(** max *)

Require Import Max.

Implicit Arguments max_r [n m].
Implicit Arguments max_l [n m].
Implicit Arguments le_trans [n m p].

Require Import Compare.

Lemma max_assoc : forall a b c, max a (max b c) = max (max a b) c.

Proof.
intros.
case (le_dec b c); intro H.
 rewrite (max_r H).
 case (le_dec a b); intro H'.
  rewrite (max_r (le_trans H' H)).
  rewrite (max_r H'). rewrite (max_r H). reflexivity.
  case (le_dec a c); intro H''; rewrite (max_l H'); reflexivity.
  rewrite (max_l H).
  case (le_dec a b); intro H'.
   rewrite (max_r H').
   apply (sym_equal (max_l H)).
   assert (H'' : c <= max a b). eapply le_trans. apply H. apply le_max_r.
   apply (sym_equal (max_l H'')).
Qed.

Lemma le_max_intro_l : forall x y z, x <= y -> x <= max y z.

Proof.
intros. eapply le_trans. apply H. apply le_max_l.
Qed.

Lemma lt_max_intro_l : forall x y z, x < y -> x < max y z.

Proof.
intros. eapply lt_le_trans. eexact H. apply le_max_l.
Qed.

Lemma le_max_intro_r : forall x y z, x <= z -> x <= max y z.

Proof.
intros. eapply le_trans. apply H. apply le_max_r.
Qed.

Lemma lt_max_intro_r : forall x y z, x < z -> x < max y z.

Proof.
intros. rewrite max_comm. apply lt_max_intro_l. assumption.
Qed.

Lemma le_max_elim_l : forall x y z, max x y <= z -> x <= z.

Proof.
intros. eapply le_trans. 2: apply H. apply le_max_l.
Qed.

Lemma le_max_elim_r : forall x y z, max x y <= z -> y <= z.

Proof.
intros. eapply le_trans. 2: apply H. apply le_max_r.
Qed.

Lemma max_ge_compat : forall x y x' y',
  x >= x' -> y >= y' -> max x y >= max x' y'.

Proof.
intros. destruct (max_dec x' y'); rewrite e; unfold ge.
rewrite max_comm. apply le_max_intro_r. assumption.
apply le_max_intro_r. assumption.
Qed.

Lemma max_gt_compat : forall x y x' y',
  x > x' -> y > y' -> max x y > max x' y'.

Proof.
intros. destruct (le_ge_dec x y); destruct (le_ge_dec x' y');
  do 2 first
    [ rewrite max_r; [idtac | assumption]
    | rewrite max_l; [idtac | assumption]
    ]; omega.
Qed.

Lemma max_lt : forall x y z, max y z < x <-> y < x /\ z < x.

Proof.
intuition. eapply le_lt_trans. apply le_max_l. apply H.
eapply le_lt_trans. apply le_max_r. apply H. apply max_case; hyp.
Qed.

Lemma gt_max : forall x y z, x > max y z <-> x > y /\ x > z.

Proof.
exact max_lt.
Qed.

(***********************************************************************)
(** min *)

Require Import Min.

Lemma elim_min_l : forall x y z, x <= z -> min x y <= z.

Proof.
intros. eapply le_trans. apply le_min_l. exact H.
Qed.

Lemma elim_min_r : forall x y z, y <= z -> min x y <= z.

Proof.
intros. eapply le_trans. apply le_min_r. exact H.
Qed.

(***********************************************************************)
(** decidability results *)

Require Import CoLoRRelMidex.

Lemma nat_ge_dec : rel_dec ge.

Proof.
intros i j. destruct (le_lt_dec j i); intuition.
Defined.

Lemma nat_gt_dec : rel_dec gt.

Proof.
intros i j. destruct (le_gt_dec i j); auto with arith.
Defined.

Lemma lt_ge_dec : forall x y, {x < y} + {x >= y}.

Proof.
intros. destruct (lt_eq_lt_dec x y); auto; try destruct s; auto with *.
Defined.

Lemma eq_opt_nat_dec : forall x y : option nat, {x=y} + {~x=y}.

Proof.
decide equality. apply eq_nat_dec.
Defined.

(***********************************************************************)
(** results on orders on nat *)

Lemma le_lt_S : forall i k, i <= k -> i < S k.

Proof.
auto with arith.
Qed.

Lemma i_lt_n : forall n i j : nat, n = i + S j -> lt i n.

Proof.
intros. omega.
Qed.

Implicit Arguments i_lt_n [n i j].

(***********************************************************************)
(** various arithmetical lemmas *)

Lemma S_neq_O : forall n, S n = O -> False.

Proof.
intros. discriminate.
Qed.

Lemma plus_reg_l_inv : forall n1 n2 p2, n2=p2 -> n1+n2=n1+p2.

Proof.
intros. omega.
Qed.

Lemma plus_reg_r_inv : forall n1 p1 n2, n1=p1 -> n1+n2=p1+n2.

Proof.
intros. omega.
Qed.

Lemma plus_minus_eq : forall v p, v+p-p=v.

Proof.
intros. omega.
Qed.

Lemma le_minus_plus : forall v p, p<=v -> v-p+p=v.

Proof.
intros. omega.
Qed.

Implicit Arguments le_minus_plus [v p].

Lemma plus_1_S : forall n, n+1 = S n.

Proof.
intro. omega.
Qed.

Lemma lt_from_le : forall x y, 0 < y -> x <= y-1 -> x < y.

Proof.
intros. omega.
Qed.

Lemma le_from_lt : forall x y, x < y+1 -> x <= y.

Proof.
intros. omega.
Qed.

Lemma lt_pm : forall n k x, n < x -> x <= n+k -> x-n-1 < k.

Proof.
intros. omega.
Qed.

Implicit Arguments lt_pm [n k x].

Lemma le_plus : forall k l, k <= k+l.

Proof.
intros. omega.
Qed.

Lemma misc1 : forall x k, S k = x+2+k-x-1.

Proof.
intros. omega.
Qed.

Lemma misc2 : forall x k, k = x+2+k-(x+1)-1.

Proof.
intros. omega.
Qed.

Lemma mult_gt_0 : forall i j, i > 0 -> j > 0 -> i * j > 0.

Proof.
  destruct i; destruct j; intros; solve [absurd_arith | simpl; auto with arith].
Qed.

Lemma mult_lt_compat_lr : forall i j k l,
  i <= j -> j > 0 -> k < l -> i * k < j * l.

Proof.
  destruct i; intros.
  rewrite mult_0_l. apply mult_gt_0. assumption.
  destruct l. absurd_arith. auto with arith.
  simpl. destruct j. absurd_arith.
  simpl. apply plus_lt_le_compat. assumption.
  apply mult_le_compat; omega.
Qed.

Lemma S_add_S : forall n1 n2 n, n1 + S n2 = n -> S n1 + S n2 = S n.

Proof.
intros. subst n. reflexivity.
Qed.

Implicit Arguments S_add_S [n1 n2 n].

Lemma gt_plus : forall l k, l > k -> exists m, l = (m + 1) + k.

Proof.
induction 1. exists 0. omega. destruct IHle. exists (S x). omega.
Qed.

Implicit Arguments gt_plus [l k].


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal19.

Set Printing Depth 1000.
Definition lfind_eval  y x:=
append x y.

Compute lfind_eval  (Nil) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)) (Nil).

Compute lfind_eval  (Nil) (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) Nil)))) (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Nil) (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) Nil)) (Nil).

Compute lfind_eval  (Nil) (Cons (Succ (Succ (Succ (Succ Zero)))) Nil).

Compute lfind_eval  (Cons Zero Nil) (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil))) (Cons Zero (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Cons Zero Nil) (Nil).

Compute lfind_eval  (Nil) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))) (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons (Succ Zero) Nil)))) (Nil).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Nil).

Compute lfind_eval  (Nil) (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero (Cons Zero Nil)))).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))) (Cons Zero Nil).

Compute lfind_eval  (Cons Zero Nil) (Cons Zero (Cons (Succ Zero) (Cons Zero (Cons Zero Nil)))).

Compute lfind_eval  (Nil) (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))) (Nil).

Compute lfind_eval  (Nil) (Nil).


(* * Kripke Semantics *)

Require Import FO_Bi_Int_Syntax.
Local Set Implicit Arguments.
Local Unset Strict Implicit.

Require Import Coq.Vectors.Vector.
Local Notation vec := Vector.t.
Require Import Ensembles.
Require Import Classical.

Section Semantics.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

    Variable domain : Type.

    Class interp := B_I
      {
        i_func : forall f : syms, vec domain (ar_syms f) -> domain ;
        i_atom : forall P : preds, vec domain (ar_preds P) -> Prop ;
      }.

    Definition env := nat -> domain.

    Context {I : interp}.

    Fixpoint eval (rho : env) (t : term) : domain :=
      match t with
      | var s => rho s
      | func f v => i_func (Vector.map (eval rho) v)
      end.

 (*  Inductive falsity_flag := falsity_off | falsity_on. *)

Lemma eval_ext rho xi t :
      (forall x, rho x = xi x) -> eval rho t = eval xi t.
    Proof.
      intros H. induction t; cbn.
      - now apply H.
      - f_equal. apply map_ext_in. now apply IH.
    Qed.

Lemma eval_comp rho xi t :
      eval rho (subst_term xi t) = eval (xi >> eval rho) t.
    Proof.
      induction t; cbn.
      - reflexivity.
      - f_equal. rewrite map_map. apply map_ext_in, IH.
    Qed.

  End Semantics.

Section Kripke.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Section Model.

    Variable domain : Type.

    Class kmodel :=
      {
        nodes : Type ;

        reachable : nodes -> nodes -> Prop ;
        reach_refl u : reachable u u ;
        reach_tran u v w : reachable u v -> reachable v w -> reachable u w ;

        k_interp : interp domain ;
        k_P : nodes -> forall P : preds, Vector.t domain (ar_preds P) -> Prop ;

        mon_P : forall u v, reachable u v -> forall P (t : Vector.t domain (ar_preds P)), k_P u t -> k_P v t;
      }.

    Variable M : kmodel.

Fixpoint ksat u (rho : nat -> domain) (phi : form) : Prop :=
      match phi with
      | atom P v => k_P u (Vector.map (@eval _ _ domain k_interp rho) v)
      | bot => False
      | top => True
      | bin Conj psi chi => (ksat u rho psi) /\ (ksat u rho chi)
      | bin Disj psi chi => (ksat u rho psi) \/ (ksat u rho chi)
      | bin Impl psi chi => forall v, reachable u v -> ksat v rho psi -> ksat v rho chi
      | bin Excl psi chi => exists v, (ksat v rho psi) /\ (reachable v u) /\ ((ksat v rho chi) -> False)
      | quant All phi => forall j : domain, ksat u (j .: rho) phi
      | quant Ex phi => exists j : domain, ksat u (j .: rho) phi
      end.

    Lemma ksat_mon (u : nodes) (rho : nat -> domain) (phi : form) :
      forall v (H : reachable u v), ksat u rho phi -> ksat v rho phi.
    Proof.
      revert rho.
      induction phi; intros rho v' H; cbn; try destruct b; try destruct q; intuition; eauto using mon_P, reach_tran.
      destruct H0. destruct H0. destruct H1. exists x. repeat split ; auto. eauto using mon_P, reach_tran.
      destruct H0. exists x. eauto using mon_P, reach_tran.
    Qed.

    Lemma ksat_iff u rho phi :
      ksat u rho phi <-> forall v (H : reachable u v), ksat v rho phi.
    Proof.
      split.
      - intros H1 v H2. eapply ksat_mon; eauto.
      - intros H. apply H. eapply reach_refl.
    Qed.

    Lemma ksat_dec u rho phi :
      (ksat u rho phi) \/ ((ksat u rho phi) -> False).
    Proof.
    apply classic.
    Qed.

  End Model.

  Notation "rho  '⊩(' u ')'  phi" := (ksat u rho phi) (at level 20).
  Notation "rho '⊩(' u , M ')' phi" := (@ksat _ M u rho phi) (at level 20).
  (* Arguments ksat {_ _ _} _ _, _ _ _ _ _. *)

  Hint Resolve reach_refl : core.

  Section Substs.

    Variable D : Type.
    Context {M : kmodel D}.

Ltac comp := repeat (progress (cbn in *; autounfold in *)).

    Lemma ksat_ext u rho xi phi :
      (forall x, rho x = xi x) -> rho ⊩(u,M) phi <-> xi ⊩(u,M) phi.
    Proof.
      induction phi as [ | |  | | ] in rho, xi, u |-* ; intros Hext ; comp ; try tauto.
      - erewrite Vector.map_ext. reflexivity. intros a. now apply eval_ext.
      - destruct b; split.
        * intro ; destruct H ; split ; [apply (IHphi1 u rho xi Hext) ; auto  |  apply (IHphi2 u rho xi Hext) ; auto].
        * intro ; symmetry in Hext ; destruct H ; split ; [apply (IHphi1 u xi rho Hext) ; auto  |  apply (IHphi2 u xi rho Hext) ; auto].
        * intro ; destruct H ; [left ; apply (IHphi1 u rho xi Hext) ; auto | right ; apply (IHphi2 u rho xi Hext) ; auto].
        * intro ; symmetry in Hext ; destruct H ; [left ; apply (IHphi1 u xi rho Hext) ; auto | right ; apply (IHphi2 u xi rho Hext) ; auto].
        * intros H v Hv Hv' ; now apply (IHphi2 v rho xi Hext), (H _ Hv), (IHphi1 v rho xi Hext).
        * intros H v Hv Hv' ; now apply (IHphi2 v rho xi Hext), (H _ Hv), (IHphi1 v rho xi Hext).
        * intro H. destruct H. exists x. destruct H. destruct H0. repeat split ; auto. apply (IHphi1 x rho xi Hext) ; auto.
          intro. apply H1. apply (IHphi2 x rho xi Hext) ; auto.
        * intro H. destruct H. exists x. symmetry in Hext. destruct H. destruct H0. repeat split ; auto. apply (IHphi1 x xi rho Hext) ; auto.
          intro. apply H1. apply (IHphi2 x xi rho Hext) ; auto.
      - destruct q ; split. 1-2: intros H d; apply (IHphi _ (d .: rho) (d .: xi)). all: ((intros []; cbn; congruence) + auto).
        1-2: intro H ; destruct H ; exists x ; apply (IHphi _ (x .: rho) (x .: xi)). all: ((intros []; cbn; congruence) + auto).
    Qed.

    Lemma ksat_comp u rho xi phi :
      rho ⊩(u,M) phi[xi] <-> (xi >> eval rho (I := @k_interp _ M)) ⊩(u,M) phi.
    Proof.
      induction phi as [ | | b P | | ] in rho, xi, u |-*; comp ; try tauto.
      - erewrite Vector.map_map. erewrite Vector.map_ext. reflexivity. apply eval_comp.
      - destruct b. 1-4: setoid_rewrite IHphi1 ; now setoid_rewrite IHphi2.
      - destruct q ; setoid_rewrite IHphi. split; intros H d; eapply ksat_ext. 2, 4: apply (H d).
        1-2: intros []; cbn; trivial; unfold funcomp; now erewrite eval_comp.
        split ; intros ; destruct H ; exists x ; eapply ksat_ext. 2,4: apply H.
        1-2:intros []; cbn; trivial; unfold funcomp; now erewrite eval_comp.
    Qed.

  End Substs.

Section Conseq_Rel.

Definition loc_conseq Γ Δ :=
  forall D (M : kmodel D) u rho,
     (forall A, In _ Γ A -> (@ksat D M u rho A)) ->
     (exists B, (In _ Δ B) /\ (@ksat D M u rho B)).

(* Where do I want to put the quantification over the assignment? *)
Definition glob_conseq Γ Δ :=
    forall D (M : kmodel D) rho,
    (forall A, (In _ Γ A) -> (forall u,(@ksat D M u rho A))) ->
    (forall u, (exists B, (In _ Δ B) /\ (@ksat D M u rho B))).

   Definition kvalid_ctx A phi :=
    forall D (M : kmodel D) u rho, (forall psi, In _ A psi -> ksat u rho psi) -> ksat u rho phi.

  Definition kvalid phi :=
    forall D (M : kmodel D) u rho, ksat u rho phi.

  Definition ksatis phi :=
    exists D (M : kmodel D) u rho, ksat u rho phi.

End Conseq_Rel.

End Kripke.

Notation "rho  '⊩(' u ')'  phi" := (ksat u rho phi) (at level 20).
Notation "rho '⊩(' u , M ')' phi" := (@ksat _ _ _ M _ u rho phi) (at level 20).

(* Arguments ksat {_ _ _ _ _} _ _ _, {_ _ _} _ {_} _ _ _. *)


(**Basic record example "a man owns a donkey" from Cooper 2014"**)
Definition Ind:=Set.
Parameter man: Ind->Prop.
Parameter donkey: Ind->Prop.
Parameter own: Ind->Ind->Prop.
Record amanownsadonkey : Type := mkamanownsadonkey{ x : Ind;  c1 : man x;  y : Ind;  c2 : donkey y; c3 : own x y }.

Theorem RECORD:amanownsadonkey-> exists x, man x/\exists y, donkey y. intro. decompose record X. exists x0. split. assumption. exists y0. assumption.                                              Qed.

(**Defining IND as a record with one Ind field**)
Record IND: Type := mkIND{ x1 :> Ind;}.
Parameter run:Ind->Prop.
(**Defining Run as a record which takes a record IND as argument**)
CoInductive  Run(X:IND):={ e: run X.(x1) ;}.
Check Run.
(**Defining John and Mary as being of type IND**)
Parameter John Mary:IND.
Check Run John.
Theorem RUN: Run John -> exists x: Ind, run x.  cbv. intro.
                                                decompose record John. decompose record H. exists x2. Undo.   exists (x1 John). apply e0. Qed.

Record Run1 (X:IND):Type:= mkRun1{e2: run X.(x1);}.

Theorem RUN1: Run1 John -> exists x: Ind, run x.  cbv. intro.
                                                 decompose record John. decompose record H. exists x2. Undo.   exists (x1 John). apply e3. Qed.


Parameters p1 p2 t1 t2 : Prop.

Definition aff1 := p1 /\ p2.
Definition aff2 := p1.

Definition k := ((p1 /\ aff1) \/ (t1 /\ ~aff1)) /\ ((p2 /\ ~aff2) \/ (t2 /\ aff2)).

Definition h1 := ~(p1 /\ t1) /\ ~(p2 /\ t2).
Definition h2 := (p1 \/ t1) /\ (p2 \/ t2).

Lemma epreuve_6 : h1 /\ h2 /\ k -> t1 /\ p2.
Proof.
unfold k, h1, h2.
unfold aff1, aff2.
intros.
destruct H.
destruct H.
destruct H0.
destruct H0.
destruct H2.
destruct H2.
destruct H2.
destruct H5.
destruct H4.
destruct H4.
elimtype False.
auto.
destruct H4.
elimtype False.
apply H1.
split; assumption.
destruct H2.
destruct H4.
destruct H4.
split; assumption.
destruct H4.
elimtype False.
apply H.
split; assumption.
Qed.


Require Import ZArith.
Require Import Arith.
Require Import Coq.Program.Wf.
Require Import Bool.
Check shift.
Print shift.

Print Zmod.
Print Zdiv_eucl.
Print Zdiv_eucl_POS.

Eval compute in (Zdiv_eucl_POS 22%positive (7%Z)).
Print Z_of_nat.

Print P_of_succ_nat.
Print Psucc.
Print Zpos.

Print prod.

Definition natmod_inc(x y:nat):nat:=
if beq_nat (S x) y then 0 else S x.

Fixpoint  natmod_1(x y:nat):=match x with
|0=>0
|S x'=>natmod_inc(natmod_1 x' y)y
end.
Definition natmod(x y:nat):nat:=
match y with
|O=>x
|S _=>natmod_1 x y
end.

Theorem natmod_lt_denom:
forall a b:nat,
natmod a (S b)<S b.
intros.
elim a.
compute.
Check le_n_S.
Check le_0_n.
apply le_n_S.
exact (le_0_n b).

intros.
simpl.
unfold lt.
unfold lt in H.
apply le_S_n in H.
apply le_n_S.
assert (forall m b:nat,m<=b->natmod_inc m (S b)<=b).
intros.
unfold natmod_inc.
simpl.
assert (m<b0\/ m=b0).
Check le_lt_or_eq.
exact (le_lt_or_eq m b0 H0).
elim H1.
intro.
SearchAbout(beq_nat _ _=true).
Lemma lt_neq: (forall x y:nat,x<y->x<>y).
intros.
unfold lt in H.
intro.
rewrite H0 in H.
exact (le_Sn_n y H).
Defined.
generalize H2;intro.
apply lt_neq in H2.

Check not_true_is_false.
Check beq_nat_true_iff.
rewrite <-beq_nat_true_iff in H2.
apply not_true_is_false in H2.
rewrite H2.
apply H3.
intro.
apply beq_nat_true_iff in H2.
rewrite H2.
exact (le_0_n b0).

apply H0.
apply H.
Defined.

Infix "mod":=natmod (at level 40).

Fixpoint  natdiv_1(x y:nat):=match x with
|0=>0
|S x'=>
(if (beq_nat (natmod_1 x y) 0) then 1 else 0)
+natdiv_1 x' y
end.

Definition natdiv(x y:nat):nat:=
match y with
|0=>0
|S _=>
natdiv_1 x y end.

Eval compute in natdiv 9 3.

Infix "div":=natdiv (at level 40).

Lemma lt_natmod_1_fixed:
forall x m:nat,
x<S m->natmod_1 x (S m)=x.
induction x.
intros.
reflexivity.
intros.
generalize H;intro.
apply lt_neq in H.
unfold natmod in *.
unfold natmod_1.
rewrite IHx.
unfold natmod_inc.
rewrite <-beq_nat_true_iff in H.
apply not_true_is_false in H.
rewrite H.
reflexivity.
apply lt_S.
apply lt_S_n.
exact H0.
Defined.
Theorem lt_natmod_fixed:
forall x m:nat,
x<S m->natmod x (S m)=x.
intros.
apply lt_natmod_1_fixed.
exact H.
Defined.

Lemma natmod_double:
forall x y:nat,
(x mod y)=((x mod y)mod y).
intros.
case y.
assert (forall x:nat,natmod x 0=x).
intros.
reflexivity.
unfold natmod.
reflexivity.
intros.
symmetry.
apply lt_natmod_fixed.
apply natmod_lt_denom.
Defined.

Theorem natmod_div:
forall x m:nat,
x=(x mod m)+(x div m)*m.
intros.
case m.
simpl.
rewrite plus_comm.
reflexivity.
intros.
elim x.
simpl;reflexivity.
simpl.
intros.
simpl.
Lemma natmod_div_1:
forall x y:nat,
((if beq_nat x 0 then 1 else 0)*y+x)=
(if beq_nat x 0 then x+y else x).
intros.
generalize (beq_nat x 0).
induction b.
simpl.
rewrite plus_comm.
rewrite (plus_comm y 0).
simpl;reflexivity.
simpl;reflexivity.
Defined.
rewrite mult_plus_distr_r.
rewrite plus_assoc.
rewrite (plus_comm (natmod_inc(natmod_1 n0(S n))(S n)) _ ).
rewrite natmod_div_1.

Lemma natmod_div2:
forall x y:nat,
let r :=(natmod_inc x (S y)) in
(if beq_nat r 0 then r+(S y) else r)=S x.
intros.
unfold natmod_inc in r.
simpl in r.
generalize (refl_equal (beq_nat x y)).
intro.
case (beq_nat x y) in r, H at 2.
simpl.
symmetry.
apply eq_S.
apply beq_nat_true.
exact H.
info reflexivity.
Defined.
rewrite (natmod_div2 (natmod_1 n0 (S n)) n).
simpl.
rewrite <-H.
reflexivity.
Defined.

Lemma natmod_period_1:
forall x y:nat,
(x+(S y))mod (S y)=x mod (S y).
intros.
elim x.
simpl.
rewrite lt_natmod_1_fixed.
unfold natmod_inc.
simpl.
generalize (refl_equal y);intro.
rewrite <-beq_nat_true_iff in H.
rewrite H.
reflexivity.
apply le_n.
intros.
simpl in *.
rewrite H.
reflexivity.
Defined.

Theorem natmod_period:
forall x y z,(x+z*y)mod y=x mod y.
intros.
case y.
simpl.
rewrite mult_comm.
rewrite plus_comm.
reflexivity.
intro.
elim z.
simpl.
rewrite plus_comm.
reflexivity.
intros.
cut (x+S n0*S n=x+n0*S n+S n).
intros.
rewrite H0.
rewrite (natmod_period_1 (x+n0*S n) n).
exact H.
simpl.
rewrite<-plus_assoc.
rewrite (plus_comm (n0*S n)).
reflexivity.
Defined.

Theorem natmod_additive:
forall x y m:nat,
(x+y)mod m=((x mod m)+(y mod m))mod m.
intros.
rewrite (natmod_div x m).
rewrite (natmod_div y m).
rewrite plus_assoc.
rewrite natmod_period.
rewrite <-plus_assoc.
rewrite (plus_comm _ (y mod m)).
rewrite plus_assoc.
repeat rewrite natmod_period.
repeat rewrite <-natmod_double.
reflexivity.
Defined.

Require Import Recdef.

Function euclid(x:nat)(y:nat){measure (fun x=>x)x}:nat:=
match x with
|0=>y
|S x'=>(euclid (natmod y x) x)
end.
intros.
apply natmod_lt_denom.
Defined.

Lemma euclid_calc:
forall x y:nat,
(euclid (S x) y =euclid (y mod (S x))(S x)).
intros.
simpl.
Admitted.
Print euclid_calc.

Lemma euclid_calc_0:
forall y:nat,
euclid 0 y=y.
intro.
unfold euclid.
unfold euclid_terminate.
simpl.
reflexivity.
Qed.

Lemma natmod_0_n:
forall n:nat,
0 mod n=0.
intro n;case n.
reflexivity.
reflexivity.
Defined.

Definition divisible(d x:nat):Prop:=
exists b:nat,b*d=x.

Infix "|":=divisible (at level 20).

Definition divisible_b(d x:nat):bool:=
beq_nat (natmod x d)0.
Theorem divisible_pb:
forall d x:nat,
divisible d x<->divisible_b d x=true.
unfold divisible,divisible_b.
intros.

split.
intro.
destruct H.
rewrite <-H.
cut (x0*d=0+x0*d).
intro.
rewrite H0.
rewrite (natmod_period 0 d x0).
rewrite natmod_0_n.
reflexivity.
reflexivity.
rewrite (natmod_div x d).
rewrite natmod_period.
intro.
rewrite beq_nat_true_iff in H.
rewrite <-natmod_double in H.
rewrite H.
simpl.
exists (x div d).
reflexivity.
Defined.

Definition comm_div(g x y:nat):Prop:=
divisible g x/\divisible g y.
Definition is_gcd(g x y:nat):Prop:=
forall d:nat, comm_div d x y<->divisible d g.
Eval lazy in divisible_b 2 4.

Check le_ind.
Lemma gcd_is_comm_div:
forall g x y:nat,
is_gcd g x y->comm_div g x y.
intros.
rewrite (H g).
exists 1.
simpl.
apply plus_comm.
Defined.

Lemma divisible_antisym:
forall a b:nat,
divisible a b->divisible b a->a=b.
intro a.
case a.
intros.
destruct H.
rewrite mult_comm in H.
simpl in *.
exact H.
intros.
destruct H.
destruct H0.
Check mult_is_one.
rewrite <-H in H0.
rewrite mult_assoc in H0.

Print mult.
SearchAbout mult.
assert (forall x n:nat,x*S n=S n->x=1).
intro.
elim x1.
intros.
discriminate.
induction n0.
intros.
reflexivity.
intros.
simpl in H2.
injection H2;intros.
replace (n1 + S (n1 + n0 * S n1)=n1) with (n1 + S (n1 + n0 * S n1)=n1+0)  in H3 .

apply (plus_reg_l (S (n1+n0*S n1)) 0 n1) in H3.
symmetry in H3.
apply O_S in H3.
elim H3.
rewrite (plus_comm n1 0).
reflexivity.
apply H1 in H0.
apply mult_is_one in H0.
destruct H0.
rewrite H2 in H.
simpl in *.
rewrite <-H.
rewrite plus_comm.
reflexivity.
Defined.

Lemma divisible_n_n:
forall n:nat,
n|n.
intros.
exists 1.
apply plus_comm.
Qed.
Lemma divisible_n_0:
forall n:nat,
n|0.
intro;exists 0;auto.
Qed.
Lemma divisible_trans:
forall x y z:nat,
x|y->y|z->x|z.
intros.
destruct H,H0.
exists (x1*x0).
rewrite <-mult_assoc.
rewrite H.
exact H0.
Qed.

Theorem gcd_eucl:
forall x y h:nat,
(is_gcd h x y<->euclid x y=h).
intro x;case x.
Lemma gcd_eucl_1:
forall y h : nat, is_gcd h 0 y <-> euclid 0 y = h.
intros.
split.
intro.
compute.
unfold is_gcd in *.
unfold comm_div in *.
apply divisible_antisym.
destruct (H y).
apply H0.
split.
exists 0;auto.
exists 1;simpl;rewrite plus_comm;reflexivity.
destruct (H h).
apply H1.
exists 1;simpl;rewrite plus_comm;reflexivity.
intros.
rewrite euclid_calc_0 in H.
rewrite H.
unfold is_gcd.
unfold comm_div.
intros.
split.
tauto.
intros.
split.
apply divisible_n_0.
auto.
Qed.
intros.
apply gcd_eucl_1.

intro n.
apply (lt_wf_ind n).
intros.
rewrite euclid_calc.
case_eq (y mod S n0).
intros.
rewrite <-beq_nat_true_iff in H0.
rewrite <-(divisible_pb (S n0) y) in H0.
rewrite euclid_calc_0.
unfold is_gcd.
unfold comm_div.
split.
intros.
apply divisible_antisym.
destruct (H1 (S n0)).
apply H2.
split.
apply divisible_n_n.
auto.
destruct (H1 h).
apply H3.
exact (divisible_n_n h).

intro.
intros.
split.
intros.
rewrite <-H1;apply H2.
intros.
rewrite <-H1 in H2.
split.
auto.
exact (divisible_trans d (S n0) y H2 H0).
intros.
rewrite <-H.
generalize (refl_equal y).
rewrite (natmod_div _ (S n0))at 2.
intro.
rewrite H0 in H1.
rewrite H1.
unfold is_gcd.
unfold comm_div.
split.
intros.
rewrite <-(H2 d).
split.
intro.
split.
apply H3.
destruct H3.
destruct H3,H4.
exists (x0+(y div S n0)*x1).
rewrite mult_plus_distr_r.
rewrite H3.
rewrite <-mult_assoc.
rewrite H4.
reflexivity.
split.
destruct H3.
destruct H3,H4.
exists (x1-(y div S n0)*x0).
rewrite mult_minus_distr_r.
rewrite H4.
rewrite <-mult_assoc.
rewrite  H3.
rewrite plus_comm.
rewrite minus_plus.
reflexivity.
exact (proj1 H3).
intros.
split.
intros.
apply H2.
destruct H3.
split.
destruct H3,H4.
exists (x1-(y div S n0)*x0).
rewrite mult_minus_distr_r.
rewrite H4.
rewrite <-mult_assoc.
rewrite  H3.
rewrite plus_comm.
rewrite minus_plus.
reflexivity.
exact H3.
intro.
rewrite <-H2 in H3.
split.
exact (proj2 H3).
destruct H3.
destruct H3,H4.
exists (x0+(y div S n0)*x1).
rewrite mult_plus_distr_r.
rewrite H3.
rewrite <-mult_assoc.
rewrite H4.
reflexivity.
apply lt_S_n.
rewrite <-H0.
apply natmod_lt_denom.
Qed.


(*********************************************)
(*********************************************)
(****                                     ****)
(****   Ordinary functional programming   ****)
(****                                     ****)
(*********************************************)
(*********************************************)

(***************************)
(* Variables and functions *)
(***************************)

(*
  Sometimes it's useful to ask Coq for the type of an expression. We can use
  the `Check` command for that. For example, the type of the expression below
  is `nat`, which stands for "natural number". Natural numbers are unsigned
  integers, and they're the most common type of number in Coq.

  To use these commands interactively, be sure you're using an IDE that
  supports Coq, such as CoqIDE or Visual Studio Code with the VsCoq plugin.
*)

Check 3 + 4. (* `nat` *)

(* If we want Coq to actually evaluate an expression, we can use `Compute`. *)

Compute 3 + 4. (* `7` *)

(*
  We can define variables with the `Definition` keyword. Coq is able to infer
  that the type of this variable is `nat`.
*)

Definition myVariable := 42.

Check myVariable. (* `nat` *)

(*
  Functions are data too, so we can also use `Definition` to introduce
  functions. Coq is able to infer that the type of this function is
  `nat -> nat` based on how `+` is used in the body.
*)

Definition double := fun x => x + x.

Check double. (* `nat -> nat` *)

(* Here's a more convenient syntax that does the same thing. *)

Definition betterDouble x := x + x.

Check betterDouble. (* `nat -> nat` *)

(*
  To call a function `f` on some input `x`, we simply write `f x`. Note that
  we don't need parentheses, unlike in other languages.
*)

Compute double myVariable. (* `84` *)

(*
  In Coq, every function takes exactly one argument. However, we can use
  "currying" to represent functions of multiple arguments as nested functions.
  Suppose we want to define a function of two arguments. We can write it as a
  function which takes only the first argument and returns another function
  which takes the second argument to the final result.
*)

Definition multiply := fun x => fun y => x * y.

Check multiply. (* `nat -> nat -> nat` *)

(*
  Note that `nat -> nat -> nat` should be understood as `nat -> (nat -> nat)`,
  not `(nat -> nat) -> nat`.

  Coq has a more convenient syntax for defining curried functions like this:
*)

Definition betterMultiply x y := x * y.

Check betterMultiply. (* `nat -> nat -> nat` *)

(*
  To call a curried function `f` with two arguments `x` and `y`, write `f x y`.
  This should be understood as `(f x) y`, not `f (x y)`.
*)

Compute multiply 3 4. (* `12` *)

(* Currying works with any positive integer number of arguments. *)

Definition addAndMultiply x y z := x + y * z.

Check addAndMultiply. (* `nat -> nat -> nat -> nat` *)

Compute addAndMultiply 3 4 5. (* `23` *)

(*
  Sometimes, the type of a function's argument can't be inferred automatically.
  For example, the following ambiguous definition is rejected:
*)

Fail Definition id x := x.

(*
  ```
  The command has indeed failed with message:
  The following term contains unresolved implicit arguments:
    (fun x : ?T => x)
  More precisely:
  - ?T: Cannot infer the type of x.
  ```

  To resolve this ambiguity, we need to provide a type annotation for `x`:
*)

Definition idNat (x : nat) := x.

Check idNat. (* `nat -> nat` *)

Definition idBool (x : bool) := x.

Check idBool. (* `bool -> bool` *)

(*
  Those identity functions are almost exactly the same, except they're defined
  on different types. Wouldn't it be nice to define a universal identity
  function that works on all types? It turns out that types are data, just like
  numbers and functions. So all we need to do is take the type as an extra
  argument. The type of that argument will be `Set`, which is the type of types
  like `nat`, `bool`, `nat -> bool`, and so on. A type which has types as
  members is called a *universe*. Lesson 5 discusses universes in depth.

  The idea of parameterizing a definition by a type is known as "generics" in
  many languages, e.g., Java and Rust.
*)

Definition id (T : Set) (x : T) := x.

Compute id nat (3 + 4). (* `7` *)

(*
  What's the type of `id`? `id` is a curried function of two arguments, but the
  type of the second argument isn't fixed; it *depends* on the first argument,
  which isn't known here since it's provided by the caller. Thus, in the type
  of `id`, we need to give a name to the first argument so we can refer to it
  in the type of the second argument. The `forall` keyword does exactly that.
*)

Check id. (* `forall T : Set, T -> T` *)

(*
  `A -> B` is actually just shorthand for `forall x : A, B`, as long as `B`
  doesn't refer to `x`. We can write the type of `id` in any of the following
  equivalent ways:

  - `forall T : Set, T -> T`
  - `forall T : Set, forall x : T, T`
  - `forall (T : Set) (x : T), T`

  The first way is best, since it makes it clear that the return type doesn't
  depend on the value of the second argument.

  It's awkward to have to explicitly provide the type argument whenever we call
  the `id` function. We can declare the argument *implicit* by using curly
  braces instead of parentheses. Then Coq will try to figure it out
  automatically whenever we use the function.
*)

Definition betterId {T : Set} (x : T) := x.

Check betterId. (* `?T -> ?T where ?T : [|- Set]` *)

Compute betterId (3 + 4). (* `7` *)

(*
  If Coq is unable to infer the implicit arguments, we can pass them explicitly
  by prefixing the function with `@`.
*)

Compute @betterId nat (3 + 4). (* `7` *)

(*******************************)
(* Simple inductive data types *)
(*******************************)

(*
  An *inductive data type* is defined by cases, called *constructors*. For
  example, we can define a type called `bool` with two constructors: `true` and
  `false`. The standard library already defines this type, but we'll redefine
  it here to demonstrate how inductive data types work.
*)

Inductive bool :=
| true
| false.

Check true. (* `bool` *)

Check false. (* `bool` *)

Check bool. (* `Set` *)

(*
  To use a `bool`, we can do case analysis on it. This is called *pattern
  matching*. For example, we can use pattern matching to define a function that
  inverts a `bool`.
*)

Definition negb b :=
  match b with
  | true => false
  | false => true
  end.

Compute negb true. (* `false` *)

Compute negb false. (* `true` *)

(*
  Each case of an inductive data type may store some data. In order to use that
  feature, we can provide a type annotation for each constructor describing
  what data that constructor accepts. For example, we can define a type such
  that its elements *might* hold a `nat` as follows:
*)

Inductive optionNat :=
| noNat : optionNat
| someNat : nat -> optionNat.

Check noNat. (* `optionNat` *)

Check someNat. (* `nat -> optionNat` *)

Check someNat 3. (* `optionNat` *)

Check optionNat. (* `Set` *)

(*
  When pattern matching on an `optionNat`, we get access to the `nat` in the
  `some` case. Here is a function which will transform the `nat`, if it exists,
  by a user-provided function.
*)

Definition mapOptionNat f o :=
  match o with
  | noNat => noNat
  | someNat n => someNat (f n)
  end.

Check mapOptionNat. (* `(nat -> nat) -> optionNat -> optionNat` *)

Compute mapOptionNat double (someNat 3). (* `someNat 6` *)

Compute mapOptionNat double noNat. (* `noNat` *)

(*
  `optionNat` only works with `nat`s. We can add a type *parameter* to make it
  work for any type. This results in a family of inductive data types, one for
  every choice of `T`. Note that each constructor returns an `option T`, rather
  than just an `option`.
*)

Inductive option (T : Set) :=
| none : option T
| some : T -> option T.

(*
  Each constructor automatically takes the parameter as an extra argument.
  Thus, if we check the type of each constructor, we find it doesn't exactly
  match the type we provided in the definition.
*)

Check none. (* `forall T : Set, option T` *)

Check none bool. (* `option bool` *)

Check some. (* `forall T : Set, T -> option T` *)

Check some bool true. (* `option bool` *)

Check option. (* `Set -> Set` *)

(*
  When pattern matching on an `option T`, add a `_` to each pattern to account
  for the parameter argument.
*)

Definition mapOption {T U} f (o : option T) :=
  match o with
  | none _ => none U
  | some _ x => some U (f x)
  end.

Check mapOption. (* `(?T -> ?U) -> option ?T -> option ?U` *)

Compute mapOption (fun n => n + 1) (none nat). (* `none nat` *)

Compute mapOption (fun n => n + 1) (some nat 3). (* `some nat 4` *)

Compute mapOption negb (some bool false). (* `some bool true` *)

Compute mapOption (fun n => true) (some nat 3). (* `some bool true` *)

(*
  The type argument for `some` can be deduced automatically from its other
  argument, so we can make it implicit as shown below. We couldn't do this with
  curly braces in the definition, since this type argument was automatically
  added by Coq as a consequence of it being a parameter. We could have made the
  parameter implicit, but that would have affected `none` and `option` too.
*)

Arguments some {_} _.

Check some. (* `?T -> option ?T where ?T : [|- Set]` *)

Compute mapOption (fun n => n + 1) (some 3). (* `some 4` *)

Compute mapOption negb (some false). (* `some true` *)

(*
  Inductive data types can be recursive. For example, below is how natural
  numbers are defined in the standard library. Note that the name of the first
  constructor is the letter "O", which was chosen due to its resemblance to the
  numeral "0".
*)

Inductive nat :=
| O : nat (* Zero *)
| S : nat -> nat. (* Successor of another `nat` *)

Check nat. (* `Set` *)
Check O. (* `nat` *)
Check S. (* `nat -> nat` *)
Check S O. (* `nat` *)
Check S (S O). (* `nat` *)
Check S (S (S O)). (* `nat` *)

(*
  Addition can be defined recursively. Note that recursive definitions use the
  `Fixpoint` keyword instead of `Definition`.
*)

Fixpoint add n m :=
  match n with
  | O => m
  | S p => S (add p m)
  end.

(* Let's compute 1 + 1. *)

Compute add (S O) (S O). (* `S (S O)` *)

(*
  By default, the parser is configured to parse numeric literals into natural
  numbers, but using the definition from the standard library rather than our
  identical definition above. So, when working with natural numbers from the
  standard library, we don't have to write all those `S`s. The standard library
  also defines the `+` operator as shorthand for `add`, so we can simply write:
*)

Compute 1 + 1. (* `2` *)

(*************)
(* Exercises *)
(*************)

(*
  1. Define the concept of lists as an inductive data type which is
     parameterized by the element type. Which arguments would you make
     implicit, if any?
  2. Define a function which computes the length of a list as defined in the
     previous question.
  3. Define a `map` function for lists as defined in the first question,
     analogous to the `mapOption` function defined in the lesson.
  4. Define a function which compares two natural numbers for equality.
  5. Define multiplication of natural numbers.
  6. Define subtraction of natural numbers. The function should return an
     `optionNat` (or `option nat`) to account for the fact that negative
     results can't be represented as natural numbers.
*)


Require Import Classical.
(* Used in the decidability of the forcing relation. *)

Require Import List.
Export ListNotations.

Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import Prop_Bi_Int_calcs.

Definition val_persist_R (W : Type) (val : W -> V -> Prop) R : Prop :=
  forall (w v : W), R w v -> (forall p, val w p -> val v p).

Definition R_refl {W : Type} (R : W -> W -> Prop) : Prop := forall (w : W), R w w.

Definition R_trans {W : Type} (R : W -> W -> Prop) : Prop := forall (u v w: W), R u v -> R v w -> R u w.

Fixpoint wforces W R (R_props : R_refl R * R_trans R) (val : W -> V -> Prop)
(pers : val_persist_R W val R) (w : W) (A : BPropF V) : Prop :=
  match A with
  | Var p => val w p
  | Bot _ => False
  | Top _ => True
  | And A B => (wforces W R R_props val pers w A) /\ (wforces W R R_props val  pers w B)
  | Or A B => (wforces W R R_props val  pers w A) \/ (wforces W R R_props val  pers w B)
  | Imp A B => forall v: W, R w v -> wforces W R R_props val  pers v A -> wforces W R R_props val  pers v B
  | Excl A B => exists v: W, (R v w) /\ wforces W R R_props val  pers v A /\ (wforces W R R_props val  pers v B -> False)
  end.

Definition mforces W R R_props val  pers (A : BPropF V) : Prop :=
  forall w : W, wforces W R R_props val  pers w A.

Definition valid_form A :=
  forall W R R_props (val : W -> V -> Prop)  pers, mforces W R R_props val  pers A.

Definition loc_conseq (Γ Δ : @Ensemble (BPropF V)) :=
  forall W R R_props (val : W -> V -> Prop)  pers (w : W),
    (forall A, (In _ Γ A) -> wforces W R R_props val pers w A) ->
    (exists B, (In _ Δ B) /\ (wforces W R R_props val pers w B)).

Definition glob_conseq (Γ Δ : @Ensemble (BPropF V)) :=
  forall W R R_props (val : W -> V -> Prop)  pers,
    (forall A, (In _ Γ A) -> mforces W R R_props val pers A) ->
    (forall (w :W), (exists B, (In _ Δ B) /\ (wforces W R R_props val  pers w B))).

Lemma Persistence : forall A W R R_props val  pers w, wforces W R R_props val pers w A ->
            (forall v, R w v -> wforces W R R_props val  pers v A).
Proof.
induction A ; intros ; try auto.
- simpl. unfold val_persist_R in pers. pose (pers w0 v).
  pose (v0 H0 w). apply v1. auto.
- simpl. split. inversion H. apply IHA1 with (w:=w) ; auto.
  inversion H. apply IHA2 with (w:=w) ; auto.
- simpl. inversion H. left. apply IHA1 with (w:=w) ; auto.
  right. apply IHA2 with (w:=w) ; auto.
- simpl. intros. simpl in H. apply H with (v:=v0) ; auto.
  destruct R_props. unfold R_trans in r0. apply r0 with (v:=v) ; auto.
- simpl. simpl in H. destruct H. destruct H. exists x. split. destruct R_props.
  unfold R_trans in r0. apply r0 with (v:=w) ; auto. assumption.
Qed.

(* Is this useful later on? Yes: in the proof of soundness and scompleteness. *)

Lemma wforces_dec : forall A W R R_props val  pers w,
    (wforces W R R_props val  pers w A) \/ ((wforces W R R_props val  pers w A) -> False).
Proof.
intros. apply classic.
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 Bool Lia Eqdep_dec.

Require Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.ReducibilityFacts.
Require Import Undecidability.Synthetic.InformativeDefinitions Undecidability.Synthetic.InformativeReducibilityFacts.

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

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

From Undecidability.Shared.Libs.DLW.Wf
  Require Import wf_finite.

From Undecidability.FOL.TRAKHTENBROT
  Require Import notations utils decidable bpcp
                 fo_sig fo_terms fo_logic fo_sat

                 red_utils

                 Sig_discrete

                 BPCP_SigBPCP              (* from BPCP to a finitary signature *)
                 Sig_rem_syms              (* convert symbols into rels *)
                 Sig_uniform               (* convert to same arity for every rels *)
                 Sig_one_rel               (* many rels of arity n into one (n+1) and constants *)
                 Sig_rem_cst               (* replace constants with free variables *)
                 Sign_Sig2                 (* From R_n to R_2 *)
                 Sig2_Sign                 (* Embed R_2 into R_n with n >= 2 *)
                 Sign_Sig                  (* Embed R_n into Σ where R_n occurs in Σ *)
                 Sig_Sig_fin               (* Alternate path: Σ -> Σfin -> Σ2 *)
                 Sig2_SigSSn1              (* Embed Σ2 = (ø,{R_2}) into ΣSSn1 = ({f_(2+n)},{P_1}) *)
                 Sign1_Sig                 (* Embed Σn1 = ({f_n},{R_1}) into Σ where
                                               f_n and R_1 occur into Σ *)
                 .

Set Implicit Arguments.

(* * Collection of high-level synthetic undecidability results *)

(* Summary of some of what is implement in here

    BPCP ⪯ SAT({f¹,g¹,a⁰,b⁰},{P²,≡²,≺²},𝔽,ℂ)

    SAT(Σ,𝔽,𝔻) ⪯  SAT(Σ,𝔽,ℂ,𝔻)  and   SAT(Σ,𝔽,ℂ,𝔻) ⪯ SAT(Σ,𝔽,𝔻)

    SAT(sy,re,𝔽,ℂ,𝔻) ⪯ SAT(∅,sy+{=²}+re,𝔽,ℂ,=) (with sy finite or discrete)

    SAT(sy,re,𝔽,ℂ,=) ⪯ SAT(sy,re,𝔽,ℂ) (with =² of arity 2 in re)

    SAT(Σ,𝔽,ℂ) ⪯ SAT(Σunif Σ n,𝔽,ℂ)  (with all arities of rels in Σ <= n)

    SAT(ø,re^n,𝔽,ℂ) ⪯ SAT(re⁰,{R^{n+1}},𝔽,ℂ)  (re is finite and uniform arity n)

    SAT(∅,{T^n},𝔽,ℂ,𝔻) ⪯ SAT(∅,{∈²},𝔽,ℂ)

    SAT(∅,{R²},𝔽,ℂ) ⪯ SAT(∅,{R^n},𝔽,ℂ)       (for 2 <= n)

    SAT(∅,{R^n},𝔽,ℂ) ⪯ SAT(Σ,𝔽,ℂ)             (when Σ contains a n-ary relation)

*)

(* The reduction from BPCP to SAT of a FO formula over a finitary & discrete signature
     - over signature Σbpcp (2 unary funs, 2 constants, 3 rels)
     - within interpreted finite and decidable models

       BPCP --> SAT({f¹,g¹,a⁰,b⁰},{P²,≡²,≺²},𝔽,ℂ)
  *)

Section BPCP_fo_fin_dec_SAT.

  Definition FIN_SAT_input := fol_form Σbpcp.

  Theorem BPCP_FIN_DEC_EQ_SAT : BPCP_problem ⪯ᵢ @fo_form_fin_dec_eq_SAT Σbpcp Σbpcp_eq eq_refl.
  Proof.
    apply ireduces_dependent; intros lc.
    exists (Σbpcp_encode lc); split.
    + intros (l & Hl); revert Hl; apply Sig_bpcp_encode_sound.
    + apply Sig_bpcp_encode_complete.
  Qed.

End BPCP_fo_fin_dec_SAT.

Corollary BPCP_FSAT_Σbpcp : BPCP_problem ⪯ᵢ FSAT Σbpcp.
Proof.
  apply ireduces_transitive with (1 := BPCP_FIN_DEC_EQ_SAT).
  apply FIN_DEC_EQ_SAT_FIN_DEC_SAT.
Qed.

(* With Σ  = (sy,re) a signature with finitely many term symbols (sy)
    and  Σ' = (ø,sy+{=²}+re) where =² is interpreted and the arity of symbols
              in sy is augmented by 1
    then there is a reduction
    - from finite and discrete and decidable SAT over Σ
    - to finite and decidable and interpreted equality SAT over Σ'

        SAT(sy,re,𝔽,ℂ,𝔻) ---> SAT(∅,sy+{=²}+re,𝔽,ℂ,=)

    Another possible hypothesis is discreteness with sy

*)

Section FIN_DISCR_DEC_SAT_FIN_DEC_EQ_NOSYMS_SAT.

  Variable (Σ : fo_signature) (HΣ : finite_t (syms Σ) + discrete (syms  Σ)).

  Theorem FIN_DISCR_DEC_SAT_FIN_DEC_EQ_NOSYMS_SAT :
          FSAT' Σ ⪯ᵢ @FSATEQ (Σnosyms Σ) (inl tt) eq_refl.
  Proof using HΣ.
    destruct HΣ as [ (l & Hl) | H ].
    - exists (fun A => Σsyms_Σnosyms l A).
      intros A; split; intros (X & HX); exists X; revert HX.
      + apply Σsyms_Σnosyms_sound.
      + apply Σsyms_Σnosyms_complete.
        * left; auto.
        * intros ? ?; auto.
    - exists (fun A => Σsyms_Σnosyms (fol_syms A) A).
      intros A; split; intros (X & HX); exists X; revert HX.
      + apply Σsyms_Σnosyms_sound.
      + apply Σsyms_Σnosyms_complete.
        * intros s; apply In_dec, H.
        * intro; auto.
  Qed.

End FIN_DISCR_DEC_SAT_FIN_DEC_EQ_NOSYMS_SAT.

Corollary FSAT_Σnosyms Σ : finite_t (syms Σ) -> FSAT Σ ⪯ᵢ FSAT (Σnosyms Σ).
Proof.
  intros H.
  apply ireduces_transitive with (1 := FIN_DEC_SAT_FIN_DISCR_DEC_SAT _).
  apply ireduces_transitive with (2 := @FIN_DEC_EQ_SAT_FIN_DEC_SAT (Σnosyms Σ) (inl tt) eq_refl).
  apply FIN_DISCR_DEC_SAT_FIN_DEC_EQ_NOSYMS_SAT; auto.
Qed.

(* If the relation symbols in Σ have all their
    arities upper bounded by n and
    Σunif n is the signature with the same functions
    symbols and relations symbols as Σ except
    that the arity of relations is uniformly equal
    to n, then there is a reduction

      SAT(Σ,𝔽,ℂ) ---> SAT(Σunif n,𝔽,ℂ)
*)

Theorem FSAT_UNIFORM Σ n :
             (forall r : rels Σ, ar_rels _ r <= n)
          -> FSAT Σ ⪯ᵢ FSAT (Σunif Σ n).
Proof.
  intros Hn.
  exists (fun A => @Σuniformize Σ n (fol_rels A) A); intros A.
  split; intros (X & HX); exists X; revert HX.
  + apply Σuniformize_sound; auto.
  + intros H; generalize H.
    intros (_ & _ & _ & phi & _).
    revert H; apply Σuniformize_complete; cbv; auto.
Qed.

(* With Σ=(sy,re) a signature with an empty type of term symbols
    and where all the finitely many relations in re have the same
    uniform arity n there is a reduction
    - from finite & decidable SAT over Σ
    - to finite & decodable SAT over Σ=(re,{R)}
    where re become constants symbols and R is a single
    relation of arity n+1
 *)

Theorem FSAT_ONE_REL Σ n :
             (syms Σ -> False)
          -> (forall r : rels Σ, ar_rels _ r = n)
          -> finite_t (rels Σ)
          -> FSAT Σ ⪯ᵢ FSAT (Σone_rel Σ n).
Proof.
  intros Hs Hn (lr & Hr).
  exists (Σunif_one_rel Hs Hn); intros A; split.
  + intros (X & M & H1 & H2 & phi & H3).
    exists (X + rels Σ)%type, (Σunif_one_rel_model Hn M (phi 0)).
    exists.
    { apply finite_t_sum; auto; exists lr; auto. }
    exists.
    { intros [] v; vec split v with x; destruct x; simpl; try tauto; apply H2. }
    exists (fun n => inl (phi n)).
    revert H3; apply Σunif_one_rel_sound.
  + intros (X & M' & H1 & H2 & phi & H3).
    exists X, (Σone_unif_rel_model Hs Hn M'), H1.
    exists.
    { intros ? ?; apply H2. }
    exists phi.
    revert H3; apply Σunif_one_rel_complete.
Qed.

(* With Σ=(sy,re) a signature with a discrete type sy of term symbols
    and among them, only constant symbols, there is a reduction
    - from finite & decidable SAT over Σ
    - to finite & decodable SAT over (ø,re)
 *)

Theorem FSAT_NOCST Σ :
             (forall s, ar_syms Σ s = 0)
          -> discrete (syms Σ)
          -> FSAT Σ ⪯ᵢ FSAT (Σrem_cst Σ).
Proof.
  intros; apply ireduces_dependent.
  apply Sig_rem_cst_dep_red; auto.
Qed.

Lemma FSAT_REL_BOUNDED_ONE_REL Σ n :
             (syms Σ -> False)
          -> (forall r : rels Σ, ar_rels _ r <= n)
          -> finite_t (rels Σ)
          -> discrete (rels Σ)
          -> FSAT Σ ⪯ᵢ FSAT (Σrel (S n)).
Proof.
  intros H1 H2 H3 H4.
  eapply ireduces_transitive; [ apply FSAT_UNIFORM, H2 | ].
  eapply ireduces_transitive; [ apply FSAT_ONE_REL; simpl; trivial | ].
  apply FSAT_NOCST; simpl; auto.
Qed.

Theorem FIN_DISCR_DEC_nSAT_FIN_DEC_2SAT n :
       FSAT' (Σrel n) ⪯ᵢ FSAT (Σrel 2).
Proof.
  exists (@Σn_Σ2_enc n); intros A; split.
  + apply SATn_SAT2.
  + intros H; apply fo_form_fin_dec_SAT_fin_discr_dec, SAT2_SATn, H.
Qed.

Corollary FSAT_REL_nto2 n : FSAT (Σrel n) ⪯ᵢ FSAT (Σrel 2).
Proof.
  apply ireduces_transitive with (1 := FIN_DEC_SAT_FIN_DISCR_DEC_SAT _).
  apply FIN_DISCR_DEC_nSAT_FIN_DEC_2SAT.
Qed.

Theorem FSAT_REL2_to_FUNnREL1 n : 2 <= n -> FSAT (Σrel 2) ⪯ᵢ FSAT (Σn1 n).
Proof.
  intros Hn; destruct n as [ | [ | n ] ]; try (exfalso; lia); clear Hn.
  exists (Σ2_ΣSSn1_enc n); intros A; split.
  + intros (X & M2 & H1 & H2 & phi & H3).
    apply Σ2_ΣSSn1_enc_sound with (1 := H3); auto.
  + intros (Y & M21 & H1 & H2 & psi & H3).
    apply Σ2_ΣSSn1_enc_complete with (2 := H3); auto.
Qed.

Theorem FSAT_FUNnREL1_ANY Σ n f r :
   ar_syms Σ f = n -> ar_rels Σ r = 1 -> FSAT (Σn1 n) ⪯ᵢ FSAT Σ.
Proof.
  intros H1 H2.
  apply ireduces_dependent.
  intros A.
  exists (Σn1_Σ _ _ _ H1 H2 A).
  apply Σn1_Σ_correct.
Qed.

(*      SAT(∅,{R²},𝔽,ℂ) ---> SAT(∅,{R^(2+n)},𝔽,ℂ)           *)

Theorem FSAT_REL_2ton n :
   2 <= n -> FSAT (Σrel 2) ⪯ᵢ FSAT (Σrel n).
Proof.
  revert n; intros [ | [ | n ] ] H; try (exfalso; lia).
  exists (Σ2_Σn n); intros A; split.
  + apply Σ2_Σn_soundness.
  + apply Σ2_Σn_completeness.
Qed.

(* If Σ contains an n-ary relational symbol then there is a
    reduction

               SAT(∅,{R^n},𝔽,ℂ) ---> SAT(Σ,𝔽,ℂ)  *)

Theorem FSAT_RELn_ANY Σ n r : ar_rels Σ r = n -> FSAT (Σrel n) ⪯ᵢ FSAT Σ.
Proof.
  intros Hr.
  destruct (SATn_SAT_reduction _ _ Hr) as (f & Hf).
  exists f; red; apply Hf.
Qed.

Section FINITARY_TO_BINARY.

  Variable (Σ : fo_signature)
           (HΣ1 : finite_t (syms Σ)) (HΣ2 : discrete (syms Σ))
           (HΣ3 : finite_t (rels Σ)) (HΣ4 : discrete (rels Σ)).

  Let max_syms : { n | forall s, ar_syms Σ s <= n }.
  Proof.
    destruct HΣ1 as (l & Hl).
    exists (lmax (map (ar_syms _) l)).
    intros s; apply lmax_prop, in_map_iff.
    exists s; auto.
  Qed.

  Let max_rels : { n | forall s, ar_rels Σ s <= n }.
  Proof.
    destruct HΣ3 as (l & Hl).
    exists (lmax (map (ar_rels _) l)).
    intros r; apply lmax_prop, in_map_iff.
    exists r; auto.
  Qed.

  Hint Resolve finite_t_sum finite_sum finite_t_finite finite_t_unit : core.

  Theorem FINITARY_TO_BINARY : FSAT Σ ⪯ᵢ FSAT (Σrel 2).
  Proof using max_syms max_rels HΣ4 HΣ3 HΣ2 HΣ1.
    destruct max_syms as (ns & Hns).
    destruct max_rels as (nr & Hnr).
    set (m := lmax (2::(S ns)::nr::nil)).
    eapply ireduces_transitive.
    { apply FSAT_Σnosyms; auto. }
    eapply ireduces_transitive.
    { apply FSAT_UNIFORM with (n := m).
      intros [ [] | [] ].
      + apply lmax_prop; simpl; auto.
      + apply Nat.le_trans with (S ns).
        * simpl; apply le_n_S, Hns.
        * apply lmax_prop; simpl; auto.
      + apply Nat.le_trans with nr.
        * simpl; auto.
        * apply lmax_prop; simpl; auto. }
    eapply ireduces_transitive.
    { apply FSAT_ONE_REL; simpl; auto; intros []. }
    eapply ireduces_transitive.
    { apply FSAT_NOCST; simpl; auto. }
    apply (FSAT_REL_nto2 (S m)).
  Qed.

End FINITARY_TO_BINARY.

Section DISCRETE_TO_BINARY.

  Variable (Σ : fo_signature)
           (HΣ1 : discrete (syms Σ))
           (HΣ2 : discrete (rels Σ)).

  Hint Resolve finite_t_pos : core.

  Theorem DISCRETE_TO_BINARY : FSAT Σ ⪯ᵢ FSAT (Σrel 2).
  Proof using HΣ2 HΣ1.
    apply ireduces_dependent.
    intros A.
    destruct (Sig_discrete_to_pos HΣ1 HΣ2 A) as (n & m & i & j & B & HB).
    destruct (@FINITARY_TO_BINARY (Σpos _ i j)) as (f & Hf); simpl; auto.
    exists (f B). red in Hf.
    rewrite <- Hf; apply HB.
  Qed.

End DISCRETE_TO_BINARY.

Section FULL_TRAKHTENBROT.

  Let finite_t_bpcp_syms : finite_t Σbpcp_syms.
  Proof.
    exists (Σbpcp_bool true::Σbpcp_bool false::Σbpcp_unit::Σbpcp_undef::nil).
    intros [ [] | | ]; simpl; auto.
  Qed.

  Let discrete_bpcp_syms : discrete Σbpcp_syms.
  Proof. unfold discrete, decidable; repeat decide equality. Qed.

  Let finite_t_bpcp_rels : finite_t Σbpcp_rels.
  Proof.
    exists (Σbpcp_hand::Σbpcp_ssfx::Σbpcp_eq::nil).
    intros []; simpl; auto.
  Qed.

  Let discrete_bpcp_rels : discrete Σbpcp_rels.
  Proof. unfold discrete, decidable; repeat decide equality. Qed.

  Let BPCP_Sig2 : BPCP_problem ⪯ᵢ FSAT (Σrel 2).
  Proof.
    apply ireduces_transitive with (1 := BPCP_FSAT_Σbpcp).
    apply FINITARY_TO_BINARY; auto.
  Qed.

  Theorem FULL_TRAKHTENBROT Σ :
            { r | 2 <= ar_rels Σ r }
          + { f : _ &
            { r | 2 <= ar_syms Σ f
               /\ ar_rels Σ r = 1 } }
         -> BPCP_problem ⪯ᵢ FSAT Σ.
  Proof.
    intros H.
    apply ireduces_transitive with (1 := BPCP_Sig2).
    revert H; intros [ (r & Hr) | (f & r & Hf & Hr) ].
    + apply ireduces_transitive with (1 := FSAT_REL_2ton Hr).
      apply FSAT_RELn_ANY with (1 := eq_refl).
    + apply ireduces_transitive with (1 := FSAT_REL2_to_FUNnREL1 Hf).
      apply FSAT_FUNnREL1_ANY with f r; auto.
  Qed.

  Corollary FULL_TRAKHTENBROT_non_informative Σ :
             (exists r, 2 <= ar_rels Σ r)
          \/ (exists f r, 2 <= ar_syms Σ f /\ ar_rels Σ r = 1)
          -> BPCP_problem ⪯ FSAT Σ.
  Proof.
    intros [ (?&?) | (?&?&?&?) ]; apply ireduces_reduces, FULL_TRAKHTENBROT; firstorder.
  Qed.

End FULL_TRAKHTENBROT.


From discprob.basic Require Import base order nify.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad Require Import monad monad_hoare bst.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From Coq Require Import Omega Program.Wf MSets.MSetInterface MSets.MSetGenTree Structures.OrdersEx.
Local Open Scope nat_scope.

(* This shows that the result of "add list random" is equivalent to adding the elements
   of the list according to some permutation *)

Lemma alr_correct (l: list nat) (t: tree):
  mspec (add_list_random l t) (λ t': tree, ∃ l', t' = add_list l' t ∧ perm_eq l l').
Proof.
 remember (size l) as k eqn: Heq.
 revert t l Heq.
 induction k as [k IH] using (well_founded_induction lt_wf) => t l Heq.
 destruct l as [| a l]; last destruct l as [| b l].
 - rewrite alr_unfold. apply mspec_mret. exists [::] => //=.
 - rewrite alr_unfold. apply mspec_mret. exists [::a] => //=.
 - rewrite alr_unfold.
   tbind (λ x, sval x \in a :: b :: l).
   { intros (?&?) => //. }
   intros (x&Hin) _.
   eapply (mspec_conseq).
   { rewrite /sval. eapply (IH (size (rem x [:: a, b & l]))).
     * subst. rewrite size_rem //=.
     * done.
   }
   intros t' (l'&Heq'&Hperm).
   exists (x :: l'); split; auto.
   eapply perm_eq_trans; first apply (perm_to_rem Hin); eauto.
   rewrite perm_cons. done.
Qed.


Require Export Classical.

(** Some basic logic properties **)

Module Property.

Lemma Lemma_xy : forall (x y: Prop), x -> y -> x /\ y.
Proof. intros; split; auto. Qed.

Lemma Lemma_x : forall x: Prop, x -> x /\ x.
Proof. intros; split; auto. Qed.

Ltac double H := apply Lemma_x in H; destruct H.

Ltac add y H:= apply (Lemma_xy _ y) in H; auto.

Lemma definition_not : forall (A B: Prop), (A<->B) -> (~ A) -> (~ B).
Proof. unfold not; intros; apply H in H1; apply H0 in H1; auto. Qed.

Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' 'λ' x .. y ']' , t").

Hint Resolve Lemma_xy Lemma_x definition_not : set.

End Property.

Export Property.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (x : lst) : lst := append (append Nil x) x.