From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Nat.
Require Import Arith.PeanoNat.
Require Import Relations.
Require Import Relation_Definitions.
Require Import Relation_Operators.
Require Import Coq.micromega.Lia.

Inductive LC :=
  | var: nat -> LC
  | app: LC -> LC -> LC
  | lam: LC -> LC
.

Module LCNotations.
  Declare Scope lc_scope.
  Delimit Scope lc_scope with lc.

  Notation "'#' n"  := (var n) (at level 55) : lc_scope.
  Coercion app : LC >-> Funclass.
  Notation "s '@' t"  := (app s t) (at level 60, no associativity) : lc_scope.
  Notation "'\' t" := (lam t) (at level 65).
End LCNotations.

Import LCNotations.
Local Open Scope lc_scope.

Check (\ \ #0 @ #1). (* \x. \y. x y *)

Definition LC_eq_dec: forall (s t: LC), { s = t } + { s <> t }.
  do 2 decide equality.
Defined.

(* A more general notion of closedness: a term is n-closed iff. it accesses at most variables with de Bruijn indices < n.

   The special case for closed terms emerges with n = 0.
*)
Inductive NClosed (n: nat) : LC -> Prop :=
  | varClosed: forall m, Nat.ltb m n -> NClosed n (#m)
  | appClosed: forall s t, NClosed n s -> NClosed n t -> NClosed n (s t)
  | lamClosed: forall s, NClosed (S n) s -> NClosed n (\ s)
.

Definition closed : LC -> Prop := NClosed 0.

Fixpoint isNClosed (n: nat) (term: LC): bool := match term with
| #m    => Nat.ltb m n
| s @ t => (isNClosed n s) && (isNClosed n t)
| \ t   => isNClosed (S n) t
end.

Lemma closedP: forall t n, reflect (NClosed n t) (isNClosed n t).
Proof.
  elim => [n m | l IH_l k IH_k n | l IH_l n]; simpl.
  - case E: (n <? m); do ! constructor => //.
    by move => H; inversion H; rewrite E in H1.
  - by case: (IH_l );
       case: (IH_k n) => ? ? //;
       try (by apply: ReflectT; do ! constructor);
       try (by apply: ReflectF => H; inversion H).
  - case: (IH_l (S n)) => H; do ! constructor => //.
    by move => wrongHip; inversion wrongHip.
Qed.

Hint Resolve closedP : lc_step_db.

Lemma andb_left: forall b b', b && b' -> b.
Proof.
  move => b b' H.
  Check Bool.andb_prop_elim.
  apply Bool.not_false_iff_true.
  move => Hfalse.
  rewrite Hfalse in H.
  by simpl in H.
Qed.

Lemma andb_right: forall b b', b && b' -> b'.
Admitted.

Lemma closedHierarchy: forall t n m, NClosed n t -> m >= n -> NClosed m t.
  elim
    => [t n m|t IHt t' IHt' n m|t IHt n m] Hclosed Hcmp;
    constructor;
    try move /closedP in Hclosed; simpl in Hclosed.

  - move /Nat.leb_le in Hclosed.
    apply Nat.leb_le.
    lia.
  - apply: IHt.
    * by apply /closedP; exact (andb_left Hclosed).
    * by exact Hcmp.
  - apply: IHt'. (* symmetric to last case *)
    * by apply /closedP; exact (andb_right Hclosed).
    * by exact Hcmp.
  - apply: IHt.
    + apply /closedP. exact Hclosed.
    + apply Nat.leb_le.
      apply Nat.leb_le in Hcmp.
      by simpl.
Qed.

Corollary closedEverywhere: forall n t, closed t -> NClosed n t.
Proof.
  move => n t Hclosed.
  apply: closedHierarchy.
  - apply: Hclosed.
  - by apply Nat.leb_le.
Qed.

Hint Resolve closedEverywhere : lc_step_db.

Lemma BiggerVariablesNotClosed: forall n m, n <=? m -> ~(NClosed n (#m)).
Proof.
  move => ? ? Hcmp.
  apply /closedP => //.
  by rewrite Nat.leb_antisym in Hcmp.
Qed.

Corollary VariablesNeverClosed: forall n, ~closed (#n).
Proof.
  by move => n; apply: (BiggerVariablesNotClosed).
Qed.

Hint Resolve VariablesNeverClosed : lc_step_db.

Inductive variablesUpdated (n delta: nat): LC -> LC -> Prop :=
  | deltaOnVarUntouched: forall m, Nat.ltb m n -> variablesUpdated n delta (#m) (#m)

  | deltaOnVar: forall m, Nat.leb n m -> variablesUpdated n delta (#m) (#(delta+m))

  | deltaOnApp: forall s s' t t',
        variablesUpdated n delta s s'
     -> variablesUpdated n delta t t'
     -> variablesUpdated n delta (s t) (s' t')

  | deltaOnLam: forall s s',
        variablesUpdated (S n) delta s s'
     -> variablesUpdated n delta (\ s) (\ s')
.

(* represents the levelling up of exactly 1 to variables *)
Definition variablesUpticked: LC -> LC -> Prop := variablesUpdated 0 0.

Fixpoint updateVariables (n delta: nat) (t: LC) : LC := match t with
| #m => if (Nat.ltb m n) then (#m) else (#(delta+m))
| s @ t => (updateVariables n delta s) @ (updateVariables n delta t)
| (\ s) => \ (updateVariables (S n) delta s)
end.

Definition uptickVariables := updateVariables 0 1.

Lemma UpdateVariablesReflection: forall n delta s t, variablesUpdated n delta s t <-> updateVariables n delta s = t.
Admitted.

Lemma UptickVariablesReflection: forall t, variablesUpticked t (uptickVariables t).
Proof.
Admitted.

Hint Resolve UptickVariablesReflection : lc_step_db.

Lemma ClosedTermsStableUnderDeltaOfVariables: forall t delta, closed t -> variablesUpdated 0 delta t t.
Proof.
  by move => ? ?; elim => //; do ! constructor.
Qed.

Corollary ClosedTermsStableUnderUpticking: forall t, closed t -> variablesUpticked t t.
Proof.
  by move => t; apply: ClosedTermsStableUnderDeltaOfVariables.
Qed.

Hint Resolve ClosedTermsStableUnderUpticking : lc_step_db.

Lemma CanonicalUpticking: forall s t, variablesUpticked s t -> t = uptickVariables s.
Proof. Admitted. (* we should prove this via a yet-to-be-created reflection view. *)

Hint Resolve CanonicalUpticking : lc_step_db.

(*

  `levelledSubstitution n s t s'` is supposed to state that `s` goes over to `s'` upon eliminating n-th variable occurrences (i.e. #n) by substitution with `t`.

  This substitution is performed non-naively, see examples below.

  Later, when stating the operational semantics of our lambda calculus, the beta redex `(\ s) t` will go over to `s'` where `s'` is precisely such that `levelledSubstitution 0 s t s'`.
  That is, it represents (as a special case) elimination of #0 occurrences.
*)
Inductive levelledSubstitution (n: nat): LC -> LC -> LC -> Prop :=
  (* when the current level matches precisely, substitute *)
  | matchingVarIdx: forall t, levelledSubstitution n (#n) t t

  (* variable indices < n are left untouched: they refer to more inner lambda abstractions *)

  | untouchedVarIdx: forall t m, Nat.ltb m n -> levelledSubstitution n (#m) t (#m)

  (* variable indices > n are decremented since the n-th level is eliminated *)
  | decrementedVarIdx: forall t m, Nat.ltb n (S m) -> levelledSubstitution n (#(S m)) t (#m)

  | appRepl: forall s1 s2 s1' s2' t,
       levelledSubstitution n s1 t s1'
    -> levelledSubstitution n s2 t s2'
    -> levelledSubstitution n (s1 s2) t (s1' s2')

  | lamRepl: forall s s' t t',
       variablesUpticked t t'
    -> levelledSubstitution (S n) s t' s'
    -> levelledSubstitution n (\ s) t (\ s')
.

Notation "s '//' t '-->' s'" := (levelledSubstitution 0 s t s') (at level 60, no associativity).

Fixpoint substituteLevelled (n: nat) (s t: LC): LC := match s with
| #m => match (Nat.compare m n) with
    | Eq => t
    | Lt => s (* unchanged, no substitution *)
    | Gt => #(pred m)
  end

| l @ k => (substituteLevelled n l t) @ (substituteLevelled n k t)
| (\ l) => \ (substituteLevelled (S n) l (uptickVariables t))
end.

Lemma substituteLevelledP: forall n s t s', reflect (levelledSubstitution n s t s') (is_left (LC_eq_dec (substituteLevelled n s t) s')).
Proof.
  move => n s.
  generalize dependent n.
  elim: s => //.
  - move => m n t s'.
    case Hcmp: (compare m n).
    * (* Nat.compare_eq: forall x y : nat, (x ?= y) = Eq -> x = y *)
      rewrite (Nat.compare_eq _ _ Hcmp).
      simpl; rewrite Nat.compare_refl.
      case Heq: (LC_eq_dec t s').
Admitted.

Lemma substituteLevelledComp: forall n s t s', (levelledSubstitution n s t s') <-> s' = substituteLevelled n s t.
Admitted.

Lemma ltbIrreflexive: forall n, ~(n <? n).
Proof.
  by elim => [|n IHn]; cbn.
Qed.

(* Main motivation: (0)-closed terms are stable under (0)substitution.
   However, we need the following stronger statement for induction to go through.
*)
Lemma NClosedTermsStableUnderNSubstitution: forall s t n, NClosed n s -> levelledSubstitution n s t s.
Proof.
  elim => // [m t n' Hs_closed | l IH_l k IH_k t Hcompound_closed | l IH t n  Hclosed_abstraction].
  - case Hcmp: (m ?= n').
    + have Heq: (m = n') by apply (Nat.compare_eq_iff _ _).
      contradict Hs_closed.
      rewrite Heq.
      move => H.
      inversion H.
      by contradict H1; apply: ltbIrreflexive.
    + have Hlt: (m < n') by apply (Nat.compare_lt_iff _ _).
      apply: untouchedVarIdx.
      by apply Nat.ltb_lt.
    + have Hgt: (m > n') by apply (Nat.compare_gt_iff _ _).
      contradict Hs_closed.
      apply: BiggerVariablesNotClosed.
      apply Nat.leb_le.
      lia.
  - by constructor; [apply: IH_l|apply: IH_k]; inversion H.
  - have Hclosed_body: (NClosed (S n) l) by inversion Hclosed_abstraction.
    apply: lamRepl.
    + apply: UptickVariablesReflection.
    + by apply: IH.
Qed.

Corollary ClosedTermsStableUnderSubstitution: forall s t, closed s -> s // t --> s.
Proof.
  by move => ? ? ?; apply: NClosedTermsStableUnderNSubstitution.
Qed.

Hint Resolve ClosedTermsStableUnderSubstitution : lc_step_db.

Lemma UptickingLevelsUpClosedness: forall n t t', variablesUpticked t t' -> NClosed n t -> NClosed (S n) t'.
Proof.
Admitted.

Hint Resolve UptickingLevelsUpClosedness : lc_step_db.

Lemma NUpdatedVariablesStableUnderSubstitution: forall n s t, levelledSubstitution n (updateVariables n 1 s) t s.
Proof.
  move => n s.
  generalize dependent n.
  elim: s => [m n t|l IH_l k IH_k n t|l IH_l n t].
  - case Hcmp: (n ?= m).
    + have Heq: (n = m) by apply (Nat.compare_eq_iff _ _).
      rewrite Heq.
      have U: (updateVariables m 1 (#m) = #(S m)). admit.
      rewrite U.
      constructor.
      by apply Nat.ltb_lt.
    + have Hlt: (n < m) by apply (Nat.compare_lt_iff _ _).
      have notHgt: ((m <? n) = false). admit.
      simpl; rewrite notHgt.

      constructor.
      by apply Nat.ltb_lt; lia.
    + have Hgt: (n > m) by apply (Nat.compare_gt_iff _ _).
      have notHgt: (m <? n = true). admit.
      simpl. rewrite notHgt.

      constructor.
      by apply Nat.ltb_lt; lia.

  - by simpl; constructor; [apply: IH_l|apply: IH_k].
  - econstructor.
    + apply: UptickVariablesReflection.
    + fold updateVariables.
      apply: IH_l.
Admitted.

Corollary UptickedVariablesStableUnderSubstitution: forall s t, uptickVariables s // t --> s.
Proof. by apply: NUpdatedVariablesStableUnderSubstitution. Qed.

Hint Resolve UptickedVariablesStableUnderSubstitution : lc_step_db.

Corollary UptickedVariablesStableUnderSubstitution': forall s t, substituteLevelled 0 (uptickVariables s) t = s.
Proof.
Admitted.

Hint Resolve UptickedVariablesStableUnderSubstitution' : lc_step_db.

Module VarReplExamples.
Example ex0: forall term, (#0) // term --> term.
Proof. by do ! constructor. Qed.

Example ex1: forall term, closed term -> (\ (#0) (#1)) // term --> (\ (#0) term).
Proof.
  move => term Hclosed.
  by do ! econstructor; apply: ClosedTermsStableUnderUpticking.
Qed.

Example ex2: forall term, closed term -> (\ (#0) (#1) (#2)) // term --> (\ (#0) term (#1)).
Proof.
  move => term Hclosed.
  by do ! econstructor; apply: ClosedTermsStableUnderUpticking.
Qed.

Example ex3: forall term, closed term -> (\ #1) // term --> (\ term).
Proof.
  move => term Hclosed.
  by do ! econstructor; apply: ClosedTermsStableUnderUpticking.
Qed.
End VarReplExamples.

Reserved Notation "s '-->' t" (at level 65).

(* One-step operational semantics for our lambda calculus *)
Inductive lcOpSem : LC -> LC -> Prop :=
  | betaRed: forall s s' t,
         levelledSubstitution 0 s t s'
      -> (\ s) t --> s'

  | appStepL: forall s s' t,
         s --> s'
      -> (s t) --> (s' t)

  | appStepR: forall s t t',
         t --> t'
      -> (s t) --> (s t')

  where "s '-->' t" := (lcOpSem s t).

Notation "s '-->*' t" := (clos_refl_trans LC lcOpSem s t) (at level 65).
Notation "s '<-->*' t" := (clos_refl_sym_trans LC lcOpSem s t) (at level 65).

Example identity: forall t, (\ #0) t --> t.
Proof. by do ! constructor. Qed.

Example first_projection: forall s t, (\ \ #1) s t -->* s.
Proof.
  move => s t.
  apply: rt_trans.
  - constructor.
    apply: appStepL.
    apply: betaRed.

    by do ! econstructor; apply: UptickVariablesReflection.
  - constructor.
    apply: betaRed.
    apply: UptickedVariablesStableUnderSubstitution.
Qed.

(* Church encoding of nat

   0 = \z \s. z
   1 = \z \s. s z
   2 = \z \s. s (s z)
   ...

   (n + 1) = \z \s. (n (s z) s)

 *)

Fixpoint internalizeNatInner (n: nat): LC := match n with
| 0 => #1
| S m => #0 @ (internalizeNatInner m)
end.

Definition internalizeNat (n: nat) := \ \ internalizeNatInner n.

Example ex0 : internalizeNat 0 = \ \ #1.
Proof. by simpl. Qed.
Example ex1 : internalizeNat 1 = \ \  #0 @ #1.
Proof. by simpl. Qed.
Example ex2 : internalizeNat 2 = \ \  #0 @ (#0 @ #1).
Proof. by simpl. Qed.

(* Church Encoding of LC: \var \app \lam. ---*)

Fixpoint internalizeLCInner (term: LC): LC := match term with
| # idx => #2 @ internalizeNat idx
| s @ t => (#1 @ internalizeLCInner s) @ (internalizeLCInner t)
| \ t   => #0 @ internalizeLCInner t
end.
Definition internalizeLC (term: LC): LC := \ \ \ internalizeLCInner term.

(* \x. x *)
Example exInt0 : internalizeLC (\ #0) = \ \ \ #0 @ (#2 @ internalizeNat 0).
Proof. by simpl. Qed.
Compute (internalizeLC (\ #0 @ #0)).

(* Church Encodings of tuples *)
Definition lc_pair: LC := \ \ \ (#0) (#2) (#1).
Definition lc_fst: LC := \ (#0) (\ \ (#1)).
Definition lc_snd: LC := \ (#0) (\ \ (#0)).

(* Church Encodings of lists *)
Definition lc_nil: LC := \ (*1:nilInterp*) \ (*0:consInterp*) #1.
Definition lc_cons: LC := \ (*3:x*) \ (*2:xs*) \ (*1:nilInterp*) \ (*0:consInterp*) (#0) (#3) ((#2) (#1) (#0)).

(* some default value required for def. of lc_head *)
Definition lc_dummy: LC := \ #0.
Definition lc_head: LC := \ (*list*) (#0) lc_dummy (\ (*x*) \ (*xs*) (#1)).
Definition lc_tail: LC := \ (*list*) lc_fst (
  (#0) (lc_pair lc_nil lc_nil) (\(*x*) \(*xs*) lc_pair (lc_snd (#0)) (lc_cons (#1) (lc_snd (#0))))
).

(* Define evaluation on internalized LC terms by folding on them.
   Concretely, we transform every internalized LC term to a function receiving
   a context and returning the evaluated thing.

   Construction by int-e from ##math on Freenode. Formalization in Coq by me.
*)

(* The variable interpretation returns a function receiving a context
   and returning the respective variable from that, i.e., the n-th entry. *)
Definition evalVarInterp: LC := \ \            (* \n. \ctx. *)
  lc_head ((#1) (#0) lc_tail).                 (* head ((n ctx) tail) *)

(* T *)
Definition evalAppInterp: LC := \ \ \          (* \s. \t. \ctx. *)
  (#2) (#0) ((#1) (#0)).                       (* s ctx (t ctx) *)

(* The lambda abstraction interpretation returns a function receiving a context --
   as before -- and receiving a term for application and returning the applied
   (i.e. beta reduced) lambda's function body.
 *)
Definition evalLamInterp: LC := \ \ \          (* \t. \ctx. \v. *)
  (#2) (lc_cons (#0) (#1)).                    (* t (cons v ctx) *)

(* Finally, the evaluator just folds on internalized LC terms by the above interpretations and starts with an empty (nil) context. *)
Definition evaluator: LC := \ (#0) evalVarInterp evalAppInterp evalLamInterp lc_nil.

Lemma evalVarInterpClosed: closed evalVarInterp.
Proof. by apply /closedP => //. Qed.
Lemma evalAppInterpClosed: closed evalAppInterp.
Proof. by apply /closedP => //. Qed.
Lemma evalLamInterpClosed: closed evalLamInterp.
Proof. by apply /closedP => //. Qed.

Hint Resolve evalVarInterpClosed evalAppInterpClosed evalLamInterpClosed : lc_step_db.

(* trivial substitution to closed terms *)
Ltac trivsubst :=
  match goal with
  | |- (levelledSubstitution 0 ?s ?t ?s') =>
     try (
       apply: ClosedTermsStableUnderSubstitution; apply /closedP; simpl
     )
  end.

(* single step LC *)
Ltac slc :=
  try (apply: betaRed || (apply: appStepL; slc) || (apply: appStepR; slc));
  try (by rewrite substituteLevelledComp);
  auto with lc_step_db (*try apply: UptickedVariablesStableUnderSubstitution.*).

(* normalize LC (i.e., multi-step LC) *)
Ltac nlc :=
  match goal with
  | |- ?s -->* ?t =>
    do 1 (
      apply: rt_trans;
      [
        apply: rt_step; slc (* no try, fail here if slc fails! *)
      |
        simpl;
        (try rewrite UptickedVariablesStableUnderSubstitution');
        (try apply: rt_refl)
      ]
    )
  end.

Example normalization': forall r s t, (\ \ \ #1) r s t -->* s.
Proof.
  move => ? ? ?; repeat nlc.
Qed.

Example normalization'': forall t, (\ \ #1) (\ #0) (\ # 0) t -->* t.
Proof.
  move => ?; repeat nlc.
Qed.

Example normalization''': forall s t, lc_fst (lc_pair s t) -->* s.
Proof.
  rewrite /lc_fst.
  rewrite /lc_pair.
  move => s t.
  do 6 nlc.
  have K: (substituteLevelled 1 (uptickVariables (uptickVariables s)) = s). admit.
  rewrite K.
  simpl.
  rewrite UptickedVariablesStableUnderSubstitution'.
  nlc.
  nlc.
  (* nlc fails here to prove it *)
Admitted.

(*
Example ex: forall t, evaluator (internalizeLC t) -->* t.
Proof.
  move => t.
  do 4 nlc.
  nlc.
  -
  repeat nlc.
  nlc.
  apply: rt_trans.
  - constructor.
    apply: betaRed.
    constructor.
    + do ! constructor; auto with lc_step_db.
    + auto with lc_step_db.
      by trivsubst.
  - apply: rt_trans.
    + constructor.
      do 3 ! apply: appStepL.
      apply: betaRed.
      by rewrite substituteLevelledComp.
    + simpl.

      apply: rt_trans.
      constructor.
      * do 2 apply: appStepL.
        apply: betaRed.
        by rewrite substituteLevelledComp.
      *
      *
      simpl.
      simpl.
      apply substituteLevelledP.

      simpl.

    cbv.
      cbn.
      *
        auto with lc_step_db.
        assert (K: closed evalVarInterp). admit. auto 10 with lc_step_db.
        apply: ClosedTermsStableUnderSubstitution. auto with lc_step_db.
  apply betaRed.
  apply appRedL.

  do ! constructor.
  apply: betaRed.

*)


Require Export ct01.

Conjecture perm_nil_sort_cons : forall (a : nat) (l :list nat),
  permutation [] l -> {l'0 : list nat | sorted l'0 /\ permutation l'0 (a :: l)}.

Conjecture sort_ind_case : forall (a a0 : nat) (l' l x : list nat),
  sorted (a0 :: l') -> permutation (a0 :: l') l
  -> sorted x -> permutation x (a :: l')
  -> {l'0 : list nat | sorted l'0 /\ permutation l'0 (a :: l)}.

Lemma sort_prog_IH : forall (a : nat) (l l' : list nat),
  sorted l' -> permutation l' l ->
  {l'0 : list nat | sorted l'0 /\ permutation l'0 (a :: l)}.
Proof.
intros; revert l H H0; induction l'; intros.
- apply perm_nil_sort_cons; eassumption.
- destruct (IHl' l'); clear IHl'.
  + inversion H; eassumption.
  + apply Permutation_refl.
  + destruct a1; eapply sort_ind_case; eassumption.
Qed.


Require Import Basic.
Require Import Heuristic.
Require Import Full.
Require Import ListEx.
Require Import Bool.
Require Import Arith.EqNat.
Require Import Integer.
Require Import EqDec.
Require Import ZArith.
Require Import BinInt.
Require Import ZProperties.
Require Import Bool.
Require Import Logic.Classical_Pred_Type.
Require Import Logic.Classical_Prop.
Require Import Permutation.
Require Import Coq.Sorting.Mergesort.
Require Import Psatz. (* for lia *)
Require Import Space.Tactics.

Module Import ZOrder := OTF_to_TTLB Z.
Module Import ZSort := Sort ZOrder.

Module ZZOrder <: TotalLeBool.
  Definition t : Set := (Z*Z).
  Definition leb (x y : t) : bool := ZOrder.leb (snd x) (snd y).
  Theorem leb_total : forall (x y : t), leb x y = true \/ leb y x = true.
    intros. destruct x. destruct y.
    unfold leb. simpl.
    apply ZOrder.leb_total.
  Qed.
End ZZOrder.
Module Import ZZSort := Sort ZZOrder.

Section Queens.
Context `{BAS:Basic}.
Context `{SEA:@Search BAS}.
Context `{INT:@Integer BAS}.

Definition uncurry {A B C} (f:A->B->C) (ab:A*B) : C :=
  f (fst ab) (snd ab).

Fixpoint nListSpace `{Basic} {A} (s:Space A) (n:nat) : Space (list A) :=
  match n with
  | 0%nat => single []
  | S n => bind (nListSpace s n) (fun l =>
          bind s (fun a => single (a :: l)))
  end.

Fixpoint index' {A} n (l : list A) :=
  match l with
  | [] => []
  | a::l => (a,n) :: index' (plus one n) l
  end.

Definition index {A} : list A -> list (A * Int) :=
  index' zero.

Definition isLegal (queens : list (Int * Int)) : bool :=
  forallb (fun x => x) [
    distinct (map fst queens);
    distinct (map snd queens);
    distinct (map (uncurry plus) queens);
    distinct (map (uncurry minus) queens)
  ].

Definition solveNQueens (n:nat) : Result (list (Int * Int)).
  refine (search
    (bind (nListSpace (range zero (natToInt n)) n)
      (fun xs:list Int => _))).
  refine (let ps := index xs in _).
  refine (if isLegal ps then single ps else empty).
Defined.

(* Proofs of completation and soundness for solution *)

Definition collision (p1 p2 : Z * Z) : Prop :=
  let ' (x1, y1) := p1 in
  let ' (x2, y2) := p2 in
    (* x1 = x2 => queens are in the same row *)
    (* y1 = y2 => queens are in the same column *)
    (* |x2 - x1| = |y2 - y1| => queens are in the same diagonal *)
    (x1 = x2) \/ (y1 = y2) \/ (Zabs (x1 - x2) = Zabs (y1 - y2)).

Definition ith (i : nat) (l : list (Z*Z)) := nth i l (0, 0).

Definition distinctIndices {A} (i j : nat) (l : list A) : Prop :=
  (i < length l)%nat /\ (j < length l)%nat /\ i <> j.

Definition inBounds (p : Z * Z) (n : nat) : Prop :=
  let '(x, y) := p in
  0 <= x < Z.of_nat n /\ 0 <= y < Z.of_nat n.

Definition noCollisions (positions : list (Z*Z)) : Prop :=
  forall (i j : nat), distinctIndices i j positions
               -> ~collision (ith i positions) (ith j positions).

Definition allInBounds (positions : list (Z*Z)) : Prop :=
  forall (p : Z*Z), In p positions -> inBounds p (length positions).

Definition correct (n : nat) (positions : list (Z*Z)) : Prop :=
  length positions = n /\ allInBounds positions /\ noCollisions positions.

Lemma diagonalOptimization : forall (x1 x2 y1 y2 : Z),
    Zabs (x1 - x2) = Zabs (y1 - y2)
    <-> ((x1 + y1) = (x2 + y2) \/ (x1 - y1) = (x2 - y2)).
Proof.
  intros. lia.
Qed.

Definition collision' (p1 p2 : Z * Z): Prop :=
  match p1, p2 with
    (x1, y1), (x2, y2) =>
    (x1 = x2) \/ (y1 = y2) \/ (x1 + y1) = (x2 + y2) \/ (x1 - y1) = (x2 - y2)
  end.

Lemma collisionEquiv : forall (p1 p2 : Z * Z), collision p1 p2 <-> collision' p1 p2.
Proof.
  intros. unfold collision. unfold collision'.
  destruct p1 as [x1 y1]. destruct p2 as [x2 y2].
  lia.
Qed.

Definition noCollisions' (positions : list (Z*Z)) : Prop :=
  ~exists (i j : nat), distinctIndices i j positions
                /\ collision (ith i positions) (ith j positions).

Lemma collisionsEquiv : forall (positions : list (Z*Z)),
    noCollisions positions <-> noCollisions' positions.
Proof.
  firstorder idtac.
Qed.

Definition existsCollision (positions : list (Z*Z)) : Prop :=
  exists (i j : nat), distinctIndices i j positions
               /\ collision (ith i positions) (ith j positions).

Lemma existsCollisionNot : forall (positions : list (Z*Z)),
    existsCollision positions <-> ~noCollisions positions.
Proof.
  intros. unfold existsCollision. unfold noCollisions.
  firstorder idtac.
  apply not_all_ex_not in H. destruct H.
  apply not_all_ex_not in H. destruct H.
  apply imply_to_and in H. destruct H.
  apply NNPP in H0.
  firstorder idtac.
Qed.

Definition forSomePairAlike (positions : list (Z*Z))
           (quantity : (Z*Z) -> Z) : Prop :=
  exists (i j: nat), distinctIndices i j positions
              /\ quantity (ith i positions) = quantity (ith j positions).

Lemma xAlikeCollision : forall (positions : list (Z*Z)),
    forSomePairAlike positions (fun p => fst p)
    -> existsCollision positions.
Proof.
  unfold existsCollision, forSomePairAlike.
  intros.
  destruct H as (i & j & D & E).
  exists i, j.
  unfold collision.
  repeat break_match.
  intuition.
Qed.

Lemma yAlikeCollision : forall (positions : list (Z*Z)),
    forSomePairAlike positions (fun p => snd p)
    -> existsCollision positions.
Proof.
  unfold existsCollision, forSomePairAlike.
  intros.
  destruct H as (i & j & D & E).
  exists i, j.
  unfold collision.
  repeat break_match.
  intuition.
Qed.

Lemma sumAlikeCollision : forall (positions : list (Z*Z)),
    forSomePairAlike positions (fun p => fst p + snd p)
    -> existsCollision positions.
Proof.
  unfold existsCollision, forSomePairAlike.
  intros.
  destruct H as (i & j & D & E).
  exists i, j.
  unfold collision.
  repeat break_match.
  split; auto.
  right. right.
  apply diagonalOptimization.
  auto.
Qed.

Lemma diffAlikeCollision : forall (positions : list (Z*Z)),
    forSomePairAlike positions (fun p => fst p - snd p)
    -> existsCollision positions.
Proof.
  unfold existsCollision, forSomePairAlike.
  intros.
  destruct H as (i & j & D & E).
  exists i, j.
  unfold collision.
  repeat break_match.
  split; auto.
  right. right.
  apply diagonalOptimization.
  auto.
Qed.

Lemma alikeIfCollision : forall (positions : list (Z*Z)),
    existsCollision positions ->
    forSomePairAlike positions (fun p => fst p)
    \/ forSomePairAlike positions (fun p => snd p)
    \/ forSomePairAlike positions (fun p => fst p + snd p)
    \/ forSomePairAlike positions (fun p => fst p - snd p).
Proof.
  unfold existsCollision, forSomePairAlike, collision.
  intros ? (i & j & D & C).
  repeat break_match.
  (intuition idtac); [left|
                      right; left|
                      right; right; apply diagonalOptimization in H0;
                        destruct H0; [left | right]];
  (exists i, j; rewrite Heqp; rewrite Heqp0; intuition).
Qed.

Theorem collisionIffAlike : forall (positions : list (Z*Z)),
    existsCollision positions <->
    forSomePairAlike positions (fun p => fst p)
    \/ forSomePairAlike positions (fun p => snd p)
    \/ forSomePairAlike positions (fun p => fst p + snd p)
    \/ forSomePairAlike positions (fun p => fst p - snd p).
Proof.
  intros. split; intros.
  * auto using alikeIfCollision.
  * destruct H as [|[|[|]]].
    - auto using xAlikeCollision.
    - auto using yAlikeCollision.
    - auto using sumAlikeCollision.
    - auto using diffAlikeCollision.
Qed.

Definition distinct' {A} (l : list A) : Prop :=
  forall (i j : nat) (d : A), distinctIndices i j l -> nth i l d <> nth j l d.

Lemma distinct'_iff_NoDup : forall A (l : list A), distinct' l <-> NoDup l.
Proof.
  unfold distinct'.
  destruct l.
  - intuition. constructor. destruct H0. simpl in *. omega.
  - split; intros.
    + rewrite NoDup_nth with (d := a).
      revert H. generalize (a :: l). clear l. intros.
      destruct (eq_nat_dec i j); firstorder idtac.
    + revert H H0. generalize (a :: l). clear l. intros.
      rewrite NoDup_nth with (d := d) in H.
      firstorder.
Qed.

Lemma distinctIndicesTransfer {A B} :
  forall (l1 : list A) (l2 : list B) (i j : nat),
    length l1 = length l2 ->
    distinctIndices i j l1 -> distinctIndices i j l2.
Proof. unfold distinctIndices. intuition. Qed.

Lemma notAlikeIffDistinct :
  forall (positions : list (Z*Z)) (quantity : (Z*Z) -> Z),
    distinct' (map quantity positions)
    <-> ~forSomePairAlike positions quantity.
Proof.
  intros. unfold forSomePairAlike, distinct'.
  split; intros.
  * intro H'. destruct H' as (i & j & D & Q).
    unfold ith in Q.
    rewrite <- !map_nth with (f := quantity) in Q.
    eapply H; eauto.
    eapply distinctIndicesTransfer; [|eauto].
    auto using map_length.
  * intro H'.
    apply H.
    exists i, j.
    split.
    + eapply distinctIndicesTransfer; eauto using map_length.
    + unfold ith.
      rewrite <- !map_nth with (f := quantity).
      rewrite !nth_indep with (d := quantity _) (d' := d) by firstorder.
      assumption.
Qed.

Theorem noCollisionsIffDistinct : forall (positions : list (Z*Z)),
    noCollisions positions
    <-> distinct' (map (fun p => fst p) positions)
      /\ distinct' (map (fun p => snd p) positions)
      /\ distinct' (map (fun p => fst p + snd p) positions)
      /\ distinct' (map (fun p => fst p - snd p) positions).
Proof.
  intros. split; intros.
  * apply collisionsEquiv in H.
    split; [| split; [| split]];
      (apply notAlikeIffDistinct; intro H';
       assert (existsCollision positions)
         by (apply collisionIffAlike; intuition);
       contradiction).
  * destruct H as (Hx & Hy & Hs & Hd).
    apply collisionsEquiv. unfold noCollisions'. intro H.
    apply notAlikeIffDistinct in Hx.
    apply notAlikeIffDistinct in Hy.
    apply notAlikeIffDistinct in Hs.
    apply notAlikeIffDistinct in Hd.
    destruct H as (i & j & D & Q).
    unfold collision in Q. unfold forSomePairAlike in *.
    remember (ith i positions) as p1.
    remember (ith j positions) as p2.
    destruct p1 as [x1 y1]. destruct p2 as [x2 y2].
    destruct Q; [apply Hx |
      destruct H; [apply Hy |
        apply diagonalOptimization in H;
        destruct H; [apply Hs | apply Hd]]];
    (exists i; exists j; rewrite <- Heqp1; rewrite <- Heqp2; split; intuition).
Qed.

Theorem distinctComputation {A} `{eqDec A} : forall (l : list A),
    distinct l = true <-> distinct' l.
Proof.
  intros l.
  rewrite distinct_iff_NoDup, distinct'_iff_NoDup.
  intuition.
Qed.

Corollary distinctComputationFalse {A} `{eqDec A} : forall (l : list A),
    distinct l = false -> ~distinct' l.
Proof.
  intros.
  intro H'.
  apply distinctComputation in H'.
  rewrite H0 in H'. inversion H'.
Qed.

Definition denoteIntTuple (q : Int * Int) : Z * Z :=
  let ' (x, y) := q in (⟦ x ⟧, ⟦ y ⟧).

Lemma distinctIndicesCons {A} : forall (a : A) (l : list A) (i j : nat),
    distinctIndices (S i) (S j) (a :: l) -> distinctIndices i j l.
Proof.
  unfold distinctIndices. simpl. intros.
  destruct H. destruct H0.
  split; intuition.
Qed.

Lemma intBijective : forall (i j : Int),
    ⟦ i ⟧ = ⟦ j ⟧ <-> i = j.
Proof.
  intros. split; intros.
  * apply denoteInjective. assumption.
  * rewrite H. reflexivity.
Qed.

Lemma distinctBijective {A} {B} : forall (l : list A) (f : A -> B) (a : A),
    (forall (a1 a2 : A), f a1 = f a2 <-> a1 = a2) ->
    distinct' l <-> distinct' (map f l).
Proof.
  intros.
  rewrite !distinct'_iff_NoDup.
  split; intros.
  * apply FinFun.Injective_map_NoDup; firstorder.
  * eauto using NoDup_map_inv.
Qed.

Lemma distinctCons {A} : forall (a : A) (l : list A),
    distinct' (a :: l) -> distinct' l.
Proof.
  intros a l.
  rewrite !distinct'_iff_NoDup.
  now inversion 1.
Qed.

Lemma distinctIntIffDistinctZ : forall (l : list Int),
    distinct' l <-> distinct' (map (fun i => ⟦ i ⟧) l).
Proof.
  intros.
  apply distinctBijective.
  * apply zero.
  * intros. apply intBijective.
Qed.

Lemma fstIntFstZ : forall (l : list (Int * Int)),
    map fst (map denoteIntTuple l) = map (fun i => ⟦ i ⟧) (map fst l).
Proof.
  intros.
  rewrite !map_map.
  apply map_ext.
  destruct a.
  reflexivity.
Qed.

Lemma sndIntSndZ : forall (l : list (Int * Int)),
    map snd (map denoteIntTuple l) = map (fun i => ⟦ i ⟧) (map snd l).
Proof.
  intros.
  rewrite !map_map.
  apply map_ext.
  destruct a.
  reflexivity.
Qed.

Lemma sumIntSumZ : forall (l : list (Int * Int)),
    map (fun p => fst p + snd p) (map denoteIntTuple l)
    = map (fun i => ⟦ i ⟧) (map (uncurry plus) l).
Proof.
  intros.
  rewrite !map_map.
  apply map_ext.
  destruct a.
  unfold uncurry.
  space_crush.
Qed.

Lemma diffIntdiffZ : forall (l : list (Int * Int)),
    map (fun p => fst p - snd p) (map denoteIntTuple l)
    = map (fun i => ⟦ i ⟧) (map (uncurry minus) l).
Proof.
  intros.
  rewrite !map_map.
  apply map_ext.
  destruct a.
  unfold uncurry.
  space_crush.
Qed.

Theorem isLegalIffNoCollisions : forall (positions : list (Int * Int)),
    isLegal positions = true <->
    noCollisions (map denoteIntTuple positions).
Proof.
  unfold isLegal.
  intros. split; intros.
  * rewrite forallb_forall in H.
    rewrite noCollisionsIffDistinct.
    rewrite fstIntFstZ.
    rewrite sndIntSndZ.
    rewrite sumIntSumZ.
    rewrite diffIntdiffZ.
    rewrite <- !distinctIntIffDistinctZ.
    rewrite <- !@distinctComputation.
    intuition.
  * apply noCollisionsIffDistinct in H.
    destruct H as (R & C & D1 & D2).
    rewrite fstIntFstZ in *.
    rewrite sndIntSndZ in *.
    rewrite sumIntSumZ in *.
    rewrite diffIntdiffZ in *.
    rewrite <- distinctIntIffDistinctZ in *.
    rewrite <- !@distinctComputation with (H := eqDecInteger) in *.
    rewrite forallb_forall. intro x.
    simpl.
    intuition congruence.
Qed.

Lemma nListSpaceLength {A} : forall (n : nat) (s : Space A) (l : list A),
   Ensembles.In ⟦ nListSpace s n ⟧ l -> length l = n.
Proof.
  intro n.
  induction n; simpl; intros; space_crush.
  subst. simpl. eauto.
Qed.

Lemma denoteNatToInt : forall (n : nat),
    ⟦ natToInt n ⟧ = Z.of_nat n.
Proof.
  intros.
  induction n; cbn [natToInt]; space_crush.
  lia.
Qed.
Hint Rewrite denoteNatToInt : space.

Lemma rangeBounds : forall (n : nat) (i : Int),
    Ensembles.In ⟦ range zero (natToInt n) ⟧ i -> 0 <= ⟦ i ⟧ < Z.of_nat n.
Proof.
  unfold range.
  intros.
  space_crush.
  break_if; space_crush.
Qed.

Lemma nListSpaceListMember {A} : forall (n : nat) (s : Space A) (l : list A),
    Ensembles.In ⟦ nListSpace s n ⟧ l
    -> forall (a : A), In a l -> Ensembles.In ⟦ s ⟧ a.
Proof.
  induction n; simpl; intros; space_crush; simpl in *; intuition idtac; eauto; congruence.
Qed.

Lemma nListSpaceRangeBounds : forall (n : nat) (l : list Int),
    Ensembles.In ⟦ (nListSpace (range zero (natToInt n)) n) ⟧ l
                 -> forall (i : Int), In i l -> 0 <= ⟦ i ⟧ < Z.of_nat n.
Proof.
  intros.
  apply nListSpaceListMember with (a := i) in H; [| assumption].
  apply rangeBounds. assumption.
Qed.

Lemma indexLength' {A} : forall (l : list A) (i : Int),
    length (index' i l) = length l.
Proof.
  induction l; simpl; auto.
Qed.

Lemma indexLength {A} : forall (l : list A), length (index l) = length l.
  intros.
  apply indexLength'.
Qed.
Hint Rewrite @indexLength : list.

Lemma indexBounds' {A} : forall (l' : list A) (i : Int) (p' : A * Int),
    In p' (index' i l')
    -> ⟦ i ⟧ <= ⟦ (snd p') ⟧ < ⟦ i ⟧ + Z.of_nat (length l').
Proof.
  induction l'; simpl; intros.
  - intuition.
  - destruct H.
    + subst. simpl. lia.
    + apply IHl' in H.
      space_crush. lia.
Qed.

Lemma indexBounds {A} : forall (l : list A),
    let n := length l in
    forall (p : (A * Int)), In p (index l) -> 0 <= ⟦ snd p ⟧ < Z.of_nat n.
Proof.
  unfold index.
  intros.
  apply (indexBounds' l zero p) in H.
  space_crush.
Qed.

Lemma indexPreservesBound' : forall (l : list Int) (n : nat),
    (forall (i : Int), In i l -> 0 <= ⟦ i ⟧ < Z.of_nat n)
    -> (forall (p : (Int * Int)) (i : Int), In p
       (index' i l) -> 0 <= ⟦ (fst p) ⟧ < Z.of_nat n).
Proof.
  induction l; simpl; intros.
  - intuition.
  - destruct H0; subst; eauto.
Qed.

Lemma indexPreservesBound : forall (l : list Int) (n : nat),
    (forall (i : Int), In i l -> 0 <= ⟦ i ⟧ < Z.of_nat n)
    -> (forall (p : (Int * Int)), In p (index l) -> 0 <= ⟦ fst p ⟧ < Z.of_nat n).
Proof.
  unfold index.
  eauto using indexPreservesBound'.
Qed.

Lemma indexAllInBounds : forall (l : list Int),
    let n := length l in
    (forall (i : Int), In i l -> 0 <= ⟦ i ⟧ < Z.of_nat n) ->
    allInBounds (map denoteIntTuple (index l)).
Proof.
  intros. unfold allInBounds, inBounds. intros.
  apply in_map_iff in H0.
  destruct H0.
  destruct p, x.

  rewrite map_length. rewrite indexLength.
  destruct H0.
  unfold denoteIntTuple in H0.
  inversion H0. subst. clear H0.
  split.
  * eapply indexPreservesBound with (p := (_, _)); eauto.
  * eapply indexBounds with (p := (_, _)); eauto.
Qed.

Theorem solveNQueensSound : forall (n : nat) (l : list (Int * Int)),
    solveNQueens n = solution l -> correct n (map denoteIntTuple l).
Proof.
  intros.
  unfold correct.
  unfold solveNQueens in H.
  apply searchSolution in H.
  space_crush.
  break_if; space_crush.

  assert (length x = n) by eauto using nListSpaceLength.
  subst.

  apply isLegalIffNoCollisions in Heqb.
  eauto using indexAllInBounds, nListSpaceRangeBounds.
Qed.

Lemma distinctPermutation {A} : forall (l1 l2 : list A),
    Permutation l1 l2 -> distinct' l1 -> distinct' l2.
Proof.
  intros l1 l2.
  rewrite !distinct'_iff_NoDup.
  apply Permutation_NoDup.
Qed.

Lemma permutationNoCollisions : forall (l1 l2 : list (Z*Z)),
    Permutation l1 l2 -> noCollisions l1 -> noCollisions l2.
Proof.
  intros l1 l2 H.
  rewrite !noCollisionsIffDistinct.
  intuition eauto using distinctPermutation, Permutation_map.
Qed.

Lemma permutationIsLegal : forall (l1 l2 : list (Int * Int)),
    Permutation l1 l2 -> isLegal l1 = true -> isLegal l2 = true.
Proof.
  intros l1 l2 H.
  rewrite !isLegalIffNoCollisions.
  eauto using permutationNoCollisions, Permutation_map.
Qed.

Lemma permutationCorrect' : forall (l1 l2 : list (Z*Z)) (n : nat),
    Permutation l1 l2 -> correct n l1 -> correct n l2.
Proof.
  unfold correct, allInBounds.
  intros.
  erewrite <- Permutation_length by eauto.
  intuition idtac.
  - eauto using Permutation_in, Permutation_sym.
  - eauto using permutationNoCollisions.
Qed.

Lemma permutationCorrect : forall (l1 l2 : list (Int*Int)) (n : nat),
    Permutation l1 l2
    -> correct n (map denoteIntTuple l1) -> correct n (map denoteIntTuple l2).
Proof.
  eauto using permutationCorrect', Permutation_map.
Qed.

Local Notation zToInt := fromZ.
Local Notation zToIntOk := denoteFromZOk.

Lemma zToIntZeroOk : zToInt 0 = zero.
  apply denoteInjective.
  space_crush.
Qed.

Lemma zToIntOneOk : zToInt 1 = one.
  apply denoteInjective.
  space_crush.
Qed.

Lemma zToIntPlusOk : forall (i j : Z), zToInt (i + j) = plus (zToInt i) (zToInt j).
  intros.
  apply denoteInjective.
  space_crush.
Qed.

Lemma zToIntEqualOk : forall (i j : Z),
    equal (zToInt i) (zToInt j) = Z.eqb i j.
Proof.
  space_crush.
Qed.

Lemma zToIntLeOk : forall (i j : Z),
    le (zToInt i) (zToInt j) = Z.leb i j.
Proof.
  space_crush.
Qed.

Definition zTupleToIntTuple (p : Z*Z) : (Int*Int) :=
  let '(x, y) := p in (zToInt x, zToInt y).

Lemma indexPreservesFst' {A} : forall (l : list A) i, map fst (index' i l) = l.
Proof.
  induction l; simpl; intros; congruence.
Qed.

Lemma indexPreservesFst {A} : forall (l : list A), (map fst (index l)) = l.
Proof.
  intros.
  apply indexPreservesFst'.
Qed.

Fixpoint countUp (n : nat) (start : Int) : list Int :=
  match n with
  | S n' => start :: countUp n' (plus one start)
  | O => []
  end.

Lemma sndIndexCountsUp' {A} : forall (l : list A) (i : Int),
    map snd (index' i l) = countUp (length l) i.
Proof.
  induction l; simpl; intros; congruence.
Qed.

Lemma sndIndexCountsUp {A} : forall (l : list A) (n : nat),
    length l = n -> map snd (index l) = countUp n zero.
Proof.
  intros.
  subst.
  apply sndIndexCountsUp'.
Qed.

Lemma sndIndex' {A} :
  forall (l : list (A * Int)) i,
      map snd l = countUp (length l) i ->
      index' i (map fst l) = l.
Proof.
  induction l; simpl; intros.
  - auto.
  - destruct a; simpl in *.
    f_equal.
    + congruence.
    + apply IHl. congruence.
Qed.

Lemma sndIndex {A} : forall (l : list (A*Int)),
    map snd l = countUp (length l) zero -> index (map fst l) = l.
Proof.
  unfold index.
  eauto using sndIndex'.
Qed.

Lemma intToZInvolutive : forall (p : Z*Z),
    denoteIntTuple (zTupleToIntTuple p) = p.
Proof.
  intros. destruct p. simpl.
  auto using f_equal2, zToIntOk.
Qed.

Lemma intToZInvolutiveMap : forall (l : list (Z*Z)),
    map denoteIntTuple (map zTupleToIntTuple l) = l.
Proof.
  intros.
  rewrite map_map.
  rewrite map_ext with (g := id).
  - apply map_id.
  - apply intToZInvolutive.
Qed.

Lemma intSndToZSnd : forall (l : list (Z*Z)),
    map snd (map zTupleToIntTuple l) = map zToInt (map snd l).
Proof.
  intros.
  rewrite !map_map.
  apply map_ext.
  destruct a; reflexivity.
Qed.

Lemma zToIntInj : forall (z1 z2 : Z),
    zToInt z1 = zToInt z2 -> z1 = z2.
Proof.
  intros.
  apply f_equal with (f := denote) in H.
  space_crush.
Qed.

Lemma zToIntMapInj : forall (l1 l2 : list Z),
    map zToInt l1 = map zToInt l2 -> l1 = l2.
Proof.
  eauto using map_inj, zToIntInj.
Qed.

Lemma zToIntMapBij : forall (l1 l2 : list Z),
    map zToInt l1 = map zToInt l2 <-> l1 = l2.
Proof.
  intros. split; intros.
  * auto using zToIntMapInj.
  * congruence.
Qed.

Fixpoint zCountUp (n : nat) (start : Z) : list Z :=
  match n with
  | S n' => start :: zCountUp n' (1 + start)
  | O => []
  end.

Lemma countUpToZCountUp : forall (n : nat) (start : Int),
    countUp n start = map zToInt (zCountUp n ⟦ start ⟧).
Proof.
  intro n. induction n; intros.
  * reflexivity.
  * cbn [countUp zCountUp map].
    rewrite IHn.
    space_crush.
Qed.

Lemma sortedBySecond : forall (l : list (Z*Z)),
    Sorted.LocallySorted (fun p1 p2 => is_true (leb (snd p1) (snd p2))) l
    -> Sorted.LocallySorted (fun z1 z2 => is_true (leb z1 z2)) (map snd l).
Proof.
  intros; induction H; simpl; constructor; try assumption.
Qed.

Theorem sortDistinctListRangeGeneral : forall (l : list Z) (n : nat) (i : Z),
    Sorted.StronglySorted Z.le l
    -> length l = n
    -> NoDup l
    -> (forall z, In z l -> i <= z < i + Z.of_nat n)
    -> l = zCountUp n i.
Proof.
  intros l n i H. revert n i.
  induction H; simpl; intros n i ? ND Range; subst.
  * reflexivity.
  * rename H0 into AleL.
    cbn [zCountUp].
    invc ND. rename H2 into Nin. rename H3 into ND.

    assert (i <= a) by (apply Range; auto).

    assert (forall z, In z l -> a < z) as Alt.
    {
      intros z Hin.
      apply Z.le_neq.
      split.
      - eapply Forall_forall; eauto.
      - congruence.
    }

    assert (forall z : Z, In z l -> 1 + i <= z < (1 + i) + Z.of_nat (length l)) as Range'.
    {
      intros z Hin.
      pose proof (Range _ (or_intror Hin)).
      apply Alt in Hin.
      lia.
    }
    specialize (IHStronglySorted (length l) (1 + i) eq_refl ltac:(auto) Range').
    rewrite <- IHStronglySorted.

    f_equal.
    destruct l as [|b l].
    + specialize (Range _ (or_introl eq_refl)). simpl in Range. omega.
    + assert (b = 1 + i) by (cbn [length zCountUp] in IHStronglySorted; congruence).
      assert (a < b) by intuition.
      omega.
Qed.

Lemma LocallySorted_ext : forall A (R1 R2 : A -> A -> Prop),
    (forall x y, R1 x y <-> R2 x y) ->
    forall l, Sorted.LocallySorted R1 l -> Sorted.LocallySorted R2 l.
Proof.
  intros A R1 R2 HR l H.
  induction H; constructor; firstorder.
Qed.

Lemma sortDistinctListRange : forall (l : list Z) (n : nat),
    length l = n
    -> distinct' l -> (forall z, In z l -> 0 <= z < Z.of_nat n)
    -> Sorted.LocallySorted (fun z1 z2 => is_true (leb z1 z2)) l
    -> l = zCountUp n 0.
Proof.
  intros. apply sortDistinctListRangeGeneral; auto.
  - apply Sorted.Sorted_StronglySorted. red. intros. omega.
    apply Sorted.Sorted_LocallySorted_iff.
    eapply LocallySorted_ext; [|eauto].
    simpl. intros. rewrite leb_le. intuition.
  - now rewrite <- distinct'_iff_NoDup.
Qed.

Lemma sortedIndex : forall (p : list (Z*Z)) (n : nat),
    correct n p ->
    map zTupleToIntTuple (sort p)
    = index (map fst (map zTupleToIntTuple (sort p))).
Proof.
  intros.
  assert (Permutation p (sort p)) by (apply Permuted_sort).
  destruct H as (? & IB & NC).
  apply noCollisionsIffDistinct in NC.
  rewrite sndIndex.
  * reflexivity.
  * rewrite map_length.
    erewrite <- Permutation_length by eauto.
    rewrite intSndToZSnd. rewrite countUpToZCountUp. rewrite zToIntMapBij.
    rewrite denoteZeroOk.
    apply sortDistinctListRange.
    + rewrite map_length. auto using Permutation_length, Permutation_sym.
    + intuition eauto using distinctPermutation, Permutation_map.
    + intros. unfold allInBounds in *. unfold inBounds in *.
      apply in_map_iff in H1.
      destruct H1 as ([x y] & ? & Hin). simpl in *. subst.
      eapply Permutation_in in Hin.
      apply IB in Hin. intuition.
      auto using Permutation_sym.
    + apply sortedBySecond.
      apply Sorted_sort.
Qed.

Lemma if_true :
  forall A b (x y : A), b = true -> (if b then x else y) = x.
Proof.
  intros. subst. reflexivity.
Qed.

Lemma inRangeIfInBounds : forall (z : Z) (n : nat),
    0 <= z < Z.of_nat n -> Ensembles.In ⟦ range zero (natToInt n) ⟧ (zToInt z).
Proof.
  intros.
  unfold range.
  space_crush.
  exists (zToInt z).
  split; space_crush.
  rewrite if_true; space_crush.
Qed.

Lemma inNListSpaceIfInSpace {A} : forall (l : list A) (s : Space A) (n : nat),
    length l = n ->
    (forall a, In a l -> Ensembles.In ⟦ s ⟧ a) -> Ensembles.In ⟦ nListSpace s n ⟧ l.
Proof.
  induction l; intros; subst; simpl in *; space_crush.
  exists l.
  split; space_crush.
  exists a.
  space_crush.
Qed.

Lemma correctArrangementsInIndex : forall (p : list (Z*Z)) (n : nat),
    correct n p ->
    (exists p', Permutation p p'
           /\ Ensembles.In ⟦ bind (nListSpace (range zero (natToInt n)) n)
                                 (fun xs:list Int => if isLegal (index xs)
                                                  then single (index xs)
                                                  else empty) ⟧
                          (map zTupleToIntTuple p')).
Proof.
  intros.
  exists (sort p).
  assert (Permutation p (sort p)) by apply Permuted_sort.
  split; [assumption|].
  space_crush.
  assert (correct n (sort p)) by eauto using permutationCorrect'.
  exists (map fst (map zTupleToIntTuple (sort p))).
  split.
  * destruct H1 as (L & A & NC).
    apply inNListSpaceIfInSpace; [now rewrite !map_length|].
    intros a.
    rewrite in_map_iff.
    intros [[x1 y1]]. simpl. intros (?). subst a.
    rewrite in_map_iff.
    intros [[x2 y2]]. simpl. intros (E). inversion E; subst; clear E.
    intro Hin.

    apply inRangeIfInBounds.
    apply A in Hin.
    destruct Hin.
    assumption.
  * erewrite <- sortedIndex by eauto.
    rewrite (proj2 (isLegalIffNoCollisions _))
      by (rewrite intToZInvolutiveMap; unfold correct in *; intuition).
    space_crush.
Qed.

Theorem solveNQueensComplete : forall (n : nat),
    solveNQueens n = uninhabited -> ~exists l, correct n l.
Proof.
  intros.
  intro H'.
  destruct H' as [l C].
  apply correctArrangementsInIndex in C.
  destruct C as (l' & P & H1).
  rewrite searchUninhabited in H1 by auto.
  inversion H1.
Qed.

Definition solver {A} (P : A -> Prop) := {a | P a} + {~exists a, P a}.

Definition solveNQueensDep n : option (solver (correct n)).
  destruct (solveNQueens n) as [l| | ] eqn:eq.
  - (* solution *)
    refine (Some _).
    left.
    exists (map denoteIntTuple l).
    apply solveNQueensSound.
    assumption.
  - (* unihabited *)
    refine (Some _).
    right.
    apply solveNQueensComplete.
    assumption.
  - (* unknown, this should never happen, because we only deal with
    integers in finite ranges *)
    refine None.
Defined.

End Queens.

Require Import Rosette.Quantified.

Definition solveNQueensRosette := solveNQueensDep.

Extraction Language Scheme.
Extraction "queens" solveNQueensRosette.


Require Export Coq.Unicode.Utf8.
Require Export FSubProd.

(*************************************************************************)
(* Reduction relation                                                    *)
(*************************************************************************)

Fixpoint Value (t : Tm) : Prop :=
  match t with
    | abs _ _  => True
    | tabs _ _ => True
    | prod x y => Value x ∧ Value y
    | _        => False
  end.

Inductive Match : Pat → Tm → Tm → Tm → Prop :=
  | M_Var {T v t} :
      Match (pvar T) v t (substTm X0 v t)
  | M_Prod {p1 p2 v1 v2 t t' t''} :
      Match p2 (weakenTm v2 (bindPat p1)) t t' →
      Match p1 v1 t' t'' →
      Match (pprod p1 p2) (prod v1 v2) t t''.

Inductive red : Tm → Tm → Prop :=
  | appabs {T11 t12 t2} :
      Value t2 → red (app (abs T11 t12) t2) (substTm X0 t2 t12)
  | tapptabs {T11 T2 t12} :
      red (tapp (tabs T11 t12) T2) (tsubstTm X0 T2 t12)
  | appfun {t1 t1' t2} :
      red t1 t1' → red (app t1 t2) (app t1' t2)
  | apparg {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (app t1 t2) (app t1 t2')
  | typefun {t1 t1' T2} :
      red t1 t1' → red (tapp t1 T2) (tapp t1' T2)
  | prodl {t1 t1' t2} :
      red t1 t1' → red (prod t1 t2) (prod t1' t2)
  | prodr {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (prod t1 t2) (prod t1 t2')
  | lettp {p t1 t1' t2} :
      red t1 t1' → red (lett p t1 t2) (lett p t1' t2)
  | lettv {p t1 t3 t2} :
      Value t1 → Match p t1 t2 t3 → red (lett p t1 t2) t3.


(*******************************************************************************

 Representable definitions of adjunctions/adjoint equivalence

 We look at representable versions of adjunctions and adjoint equivalences.

 The first thing we notice, is that every adjunction in a bicategory gives rise
 to an adjunction on the hom-categories. However, note that in general, we do
 not get an adjunction from an adjunction on the hom-categories.

 For adjoint equivalences, the situation is different: for those, the two
 definitions are actually equivalent.

 Contents
 1. Every adjunction gives rise to an adjunction on the hom-categories
 2. Representable definition of adjoint equivalences
 3. Adjoint equivalence to homwise adjoint equivalence
 4. Homwise adjoint equivalence to adjoint equivalence
 5. The two definitions are equivalent

 *******************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.

Local Open Scope cat.

Definition left_adjoint_repr
           {B : bicat}
           {x y : B}
           (l : x --> y)
  : UU
  := ∏ (w : B), is_left_adjoint (post_comp w l).

Section LeftAdjointToLeftAdjointRepr.
  Context {B : bicat}
          {x y : B}
          (l : x --> y)
          (Hl : left_adjoint l).

  Let r : y --> x := left_adjoint_right_adjoint Hl.
  Let η : id₁ _ ==> l · r := left_adjoint_unit Hl.
  Let ε : r · l ==> id₁ _ := left_adjoint_counit Hl.

  Section AdjointRepr.
    Context (w : B).

    Definition left_adjoint_to_repr_unit
      : functor_identity _
        ⟹
        post_comp w l ∙ post_comp w r.
    Proof.
      use make_nat_trans.
      - exact (λ f, rinvunitor _ • (f ◃ η) • lassociator _ _ _).
      - abstract
          (intros f₁ f₂ τ ; cbn ;
           rewrite !vassocl ;
           rewrite rwhisker_rwhisker ;
           rewrite !vassocr ;
           rewrite rinvunitor_natural ;
           rewrite <- rwhisker_hcomp ;
           apply maponpaths_2 ;
           rewrite !vassocl ;
           rewrite vcomp_whisker ;
           apply idpath).
    Defined.

    Definition left_adjoint_to_repr_counit
      : post_comp w r ∙ post_comp w l
        ⟹
        functor_identity _.
    Proof.
      use make_nat_trans.
      - exact (λ f, rassociator _ _ _ • (f ◃ ε) • runitor _).
      - abstract
          (intros f₁ f₂ τ ; cbn ;
           rewrite !vassocr ;
           rewrite rwhisker_rwhisker_alt ;
           rewrite !vassocl ;
           rewrite <- vcomp_runitor ;
           apply maponpaths ;
           rewrite !vassocr ;
           rewrite vcomp_whisker ;
           apply idpath).
    Defined.
  End AdjointRepr.

  Definition left_adjoint_to_left_adjoint_repr_form_adjunction
             (w : B)
    : form_adjunction
        (post_comp w l)
        (post_comp w r)
        (left_adjoint_to_repr_unit w)
        (left_adjoint_to_repr_counit w).
  Proof.
    split.
    - intro f ; cbn.
      rewrite !vassocl.
      refine (_ @ lwhisker_id2 _ _).
      refine (!_).
      etrans.
      {
        apply maponpaths.
        exact (!(internal_triangle1 Hl)).
      }
      rewrite <- runitor_triangle.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite <- rassociator_rassociator.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !rwhisker_vcomp.
      rewrite !vassocl.
      rewrite lassociator_rassociator.
      rewrite id2_right.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite rwhisker_hcomp, lwhisker_hcomp.
      rewrite triangle_r_inv.
      apply idpath.
    - intro f ; cbn.
      rewrite !vassocl.
      refine (_ @ lwhisker_id2 _ _).
      refine (!_).
      etrans.
      {
        apply maponpaths.
        exact (!(internal_triangle2 Hl)).
      }
      rewrite <- rinvunitor_triangle.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- lassociator_lassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !rwhisker_vcomp.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      refine (!_).
      apply runitor_rwhisker.
  Qed.

  Definition left_adjoint_to_left_adjoint_repr_are_adjoints
             (w : B)
    : are_adjoints (post_comp w l) (post_comp w r).
  Proof.
    use make_are_adjoints.
    - exact (left_adjoint_to_repr_unit w).
    - exact (left_adjoint_to_repr_counit w).
    - exact (left_adjoint_to_left_adjoint_repr_form_adjunction w).
  Defined.

  Definition left_adjoint_to_left_adjoint_repr
    : left_adjoint_repr l
    := λ w,
       post_comp w r
       ,,
       left_adjoint_to_left_adjoint_repr_are_adjoints w.

  Definition left_adjoint_to_adjunction_cat
             (w : B)
             (HB_2_1 : is_univalent_2_1 B)
    : @adjunction bicat_of_univ_cats (univ_hom HB_2_1 w x) (univ_hom HB_2_1 w y).
  Proof.
    refine (post_comp w l
            ,,
            ((post_comp w r
            ,,
            (left_adjoint_to_repr_unit w
            ,,
            left_adjoint_to_repr_counit w))
            ,,
            (_ ,, _))).
    - abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         cbn ;
         intro ;
         rewrite !id2_right, id2_left ;
         apply left_adjoint_to_left_adjoint_repr_form_adjunction).
    - abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         cbn ;
         intro ;
         rewrite !id2_right, id2_left ;
         apply left_adjoint_to_left_adjoint_repr_form_adjunction).
  Defined.
End LeftAdjointToLeftAdjointRepr.

(**
 2. Representable definition of adjoint equivalences
 *)
Definition left_adjoint_equivalence_repr
           {B : bicat}
           {x y : B}
           (l : x --> y)
  : UU
  := ∏ (w : B), adj_equivalence_of_cats (post_comp w l).

Definition isaprop_left_adjoint_equivalence_repr
           {B : bicat}
           (HB_2_1 : is_univalent_2_1 B)
           {x y : B}
           (l : x --> y)
  : isaprop (left_adjoint_equivalence_repr l).
Proof.
  use impred ; intro w.
  use isofhlevelweqf.
  - exact (@left_adjoint_equivalence
             bicat_of_univ_cats
             (univ_hom HB_2_1 _ _)
             (univ_hom HB_2_1 _ _)
             (post_comp w l)).
  - exact (@adj_equiv_is_equiv_cat
             (univ_hom HB_2_1 _ _)
             _
             _).
  - apply isaprop_left_adjoint_equivalence.
    exact univalent_cat_is_univalent_2_1.
Qed.

(**
 3. Adjoint equivalence to homwise adjoint equivalence
 *)
Section LeftAdjointToLeftAdjointRepr.
  Context {B : bicat}
          {x y : B}
          (l : x --> y)
          (Hl : left_adjoint_equivalence l).

  Let r : y --> x := left_adjoint_right_adjoint Hl.
  Let η : invertible_2cell (id₁ _) (l · r) := left_equivalence_unit_iso Hl.
  Let ε : invertible_2cell (r · l) (id₁ _) := left_equivalence_counit_iso Hl.

  Section ToEquivalence.
    Context (w : B).

    Let L : hom w x ⟶ hom w y := post_comp w l.
    Let R : hom w y ⟶ hom w x := post_comp w r.

    Definition left_adjequiv_to_left_adjequiv_repr_equiv
      : equivalence_of_cats (hom w x) (hom w y).
    Proof.
      use make_equivalence_of_cats.
      - use make_adjunction_data.
        + exact L.
        + exact R.
        + apply left_adjoint_to_repr_unit.
        + apply left_adjoint_to_repr_counit.
      - split.
        + intro f.
          apply is_inv2cell_to_is_z_iso ; cbn.
          is_iso.
          exact (pr2 (left_equivalence_unit_iso Hl)).
        + intro f.
          apply is_inv2cell_to_is_z_iso ; cbn.
          is_iso.
          exact (pr2 (left_equivalence_counit_iso Hl)).
    Defined.
  End ToEquivalence.

  Definition left_adjequiv_to_left_adjequiv_repr
    : left_adjoint_equivalence_repr l
    := λ w, adjointificiation (left_adjequiv_to_left_adjequiv_repr_equiv w).
End LeftAdjointToLeftAdjointRepr.

(**
 4. Homwise adjoint equivalence to adjoint equivalence
 *)
Section LeftAdjointReprToLeftAdjoint.
  Context {B : bicat}
          {x y : B}
          (l : x --> y)
          (Hl : left_adjoint_equivalence_repr l).

  Let r : y --> x := right_adjoint (Hl y) (id₁ y).
  Let η : invertible_2cell (r · l) (id₁ y)
    := nat_z_iso_pointwise_z_iso
         (counit_nat_z_iso_from_adj_equivalence_of_cats
            (Hl y))
         (id₁ y).

  Definition left_adjoint_repr_to_left_adjoint_counit
    : invertible_2cell (l · r) (id₁ x).
  Proof.
    apply z_iso_to_inv2cell.
    refine (z_iso_comp
              (nat_z_iso_pointwise_z_iso
                 (unit_nat_z_iso_from_adj_equivalence_of_cats
                    (Hl x))
                 (l · r))
              (z_iso_comp
                 (functor_on_z_iso
                    (right_adjoint (Hl x))
                    _)
                 (z_iso_inv
                    (nat_z_iso_pointwise_z_iso
                       (unit_nat_z_iso_from_adj_equivalence_of_cats
                          (Hl x))
                       (id₁ x))))).
   cbn.
   apply inv2cell_to_z_iso.
   exact (comp_of_invertible_2cell
            (rassociator_invertible_2cell _ _ _)
            (comp_of_invertible_2cell
               (lwhisker_of_invertible_2cell _ η)
               (comp_of_invertible_2cell
                  (runitor_invertible_2cell _)
                  (linvunitor_invertible_2cell _)))).
  Defined.

  Definition left_adjoint_repr_to_left_adjoint_data
    : left_adjoint_data l
    := r ,, (left_adjoint_repr_to_left_adjoint_counit^-1 ,, pr1 η).

  Definition left_adjoint_repr_to_left_adjoint_axioms
    : left_equivalence_axioms left_adjoint_repr_to_left_adjoint_data.
  Proof.
    simple refine (_ ,, _).
    - apply is_invertible_2cell_inv.
    - exact (pr2 η).
  Defined.

  Definition left_adjoint_repr_to_left_adjoint_equivalence
    : left_adjoint_equivalence l
    := equiv_to_adjequiv
         _
         (left_adjoint_repr_to_left_adjoint_data
          ,,
          left_adjoint_repr_to_left_adjoint_axioms).
End LeftAdjointReprToLeftAdjoint.

(**
 5. The two definitions are equivalent
 *)
Definition left_adjoint_equivalence_weq_left_adjoint_equivalence_repr
           {B : bicat}
           (HB : is_univalent_2_1 B)
           {x y : B}
           (l : x --> y)
  : left_adjoint_equivalence_repr l ≃ left_adjoint_equivalence l.
Proof.
  use weqimplimpl.
  - exact (left_adjoint_repr_to_left_adjoint_equivalence l).
  - exact (left_adjequiv_to_left_adjequiv_repr l).
  - apply isaprop_left_adjoint_equivalence_repr.
    exact HB.
  - apply isaprop_left_adjoint_equivalence.
    exact HB.
Defined.