Require Import Frap.

Set Implicit Arguments.

(** * Specification styles for data abstraction *)

(* One of the classic formalisms for data abstraction is the *algebraic* style,
 * where requirements on implementations are written out as quantified
 * equalities.  Any implementation must satisfy these equalities, but we grant
 * implementations freedom in internal details. *)
Module Algebraic.
  (* Here's an example of an algebraic interface or *specification* ("spec" for
   * short).  It's for purely functional queues, which follow first-in-first-out
   * disciplines. *)
  Module Type QUEUE.
    Parameter t : Set -> Set.

    Parameter empty : forall A, t A.
    Parameter enqueue : forall A, t A -> A -> t A.
    Parameter dequeue : forall A, t A -> option (t A * A).

    Axiom dequeue_empty : forall A,
        dequeue (empty A) = None.
    Axiom empty_dequeue : forall A (q : t A),
        dequeue q = None -> q = empty A.

    Axiom dequeue_enqueue : forall A (q : t A) x,
        dequeue (enqueue q x) = Some (match dequeue q with
                                      | None => (empty A, x)
                                      | Some (q', y) => (enqueue q' x, y)
                                      end).
  End QUEUE.

  (* First, there is a fairly straightforward implementation with lists. *)
  Module ListQueue : QUEUE.
    Definition t : Set -> Set := list.

    Definition empty A : t A. Admitted.
    Definition enqueue A (q : t A) (x : A) : t A. Admitted.
    Fixpoint dequeue A (q : t A) : option (t A * A). Admitted.

    Theorem dequeue_empty : forall A, dequeue (empty A) = None.
    Proof.
    Admitted.

    Theorem empty_dequeue : forall A (q : t A),
        dequeue q = None -> q = empty A.
    Proof.
    Admitted.

    Theorem dequeue_enqueue : forall A (q : t A) x,
        dequeue (enqueue q x) = Some (match dequeue q with
                                      | None => (empty A, x)
                                      | Some (q', y) => (enqueue q' x, y)
                                      end).
    Proof.
    Admitted.
  End ListQueue.

  Module ReversedListQueue : QUEUE.
    Definition t : Set -> Set := list.

    Definition empty A : t A. Admitted.
    Definition enqueue A (q : t A) (x : A) : t A. Admitted.
    Fixpoint dequeue A (q : t A) : option (t A * A). Admitted.

    Theorem dequeue_empty : forall A, dequeue (empty A) = None.
    Proof.
    Admitted.

    Theorem empty_dequeue : forall A (q : t A),
        dequeue q = None -> q = empty A.
    Proof.
    Admitted.

    Theorem dequeue_enqueue : forall A (q : t A) x,
        dequeue (enqueue q x) = Some (match dequeue q with
                                      | None => (empty A, x)
                                      | Some (q', y) => (enqueue q' x, y)
                                      end).
    Proof.
    Admitted.
  End ReversedListQueue.

  Module DelayedSum (Q : QUEUE).
    (* First, the function to enqueue the first [n] natural numbers. *)
    Fixpoint makeQueue (n : nat) (q : Q.t nat) : Q.t nat :=
      match n with
      | 0 => q
      | S n' => makeQueue n' (Q.enqueue q n')
      end.

    (* Next, the function to dequeue repeatedly, keeping a sum. *)
    Fixpoint computeSum (n : nat) (q : Q.t nat) : nat :=
      match n with
      | 0 => 0
      | S n' => match Q.dequeue q with
                | None => 0
                | Some (q', v) => v + computeSum n' q'
                end
      end.

    (* This function gives the expected answer, in a simpler form, of
     * [computeSum] after [makeQueue]. *)
    Fixpoint sumUpto (n : nat) : nat :=
      match n with
      | 0 => 0
      | S n' => n' + sumUpto n'
      end.

    Theorem computeSum_ok : forall n,
        computeSum n (makeQueue n (Q.empty nat)) = sumUpto n.
    Proof.
    Admitted.
  End DelayedSum.
End Algebraic.

Module AlgebraicWithEquivalenceRelation.
  Module Type QUEUE.
    Parameter t : Set -> Set.

    Parameter empty : forall A, t A.
    Parameter enqueue : forall A, t A -> A -> t A.
    Parameter dequeue : forall A, t A -> option (t A * A).

    (* v-- New part! *)
    Parameter equiv : forall A, t A -> t A -> Prop.
    Infix "~=" := equiv (at level 70).

    (* It really is an equivalence relation. *)
    Axiom equiv_refl : forall A (a : t A), a ~= a.
    Axiom equiv_sym : forall A (a b : t A), a ~= b -> b ~= a.
    Axiom equiv_trans : forall A (a b c : t A), a ~= b -> b ~= c -> a ~= c.

    Axiom equiv_enqueue : forall A (a b : t A) (x : A),
        a ~= b
        -> enqueue a x ~= enqueue b x.

    (* We define a derived relation for results of [dequeue]. *)
    Definition dequeue_equiv A (a b : option (t A * A)) :=
      match a, b with
      | None, None => True
      | Some (qa, xa), Some (qb, xb) => qa ~= qb /\ xa = xb
      | _, _ => False
      end.

    Infix "~~=" := dequeue_equiv (at level 70).

    Axiom equiv_dequeue : forall A (a b : t A),
        a ~= b
        -> dequeue a ~~= dequeue b.

    (* We retain the three axioms from the prior interface, using our fancy
     * relation instead of equality on queues. *)

    Axiom dequeue_empty : forall A,
        dequeue (empty A) = None.
    Axiom empty_dequeue : forall A (q : t A),
        dequeue q = None -> q ~= empty A.

    Axiom dequeue_enqueue : forall A (q : t A) x,
        dequeue (enqueue q x)
        ~~= match dequeue q with
            | None => Some (empty A, x)
            | Some (q', y) => Some (enqueue q' x, y)
            end.
  End QUEUE.

  (* It's easy to redo [ListQueue], specifying normal equality for the
   * equivalence relation. *)
  Module ListQueue : QUEUE.
    Definition t : Set -> Set := list.

    Definition empty A : t A := nil.
    Definition enqueue A (q : t A) (x : A) : t A := x :: q.
    Fixpoint dequeue A (q : t A) : option (t A * A) :=
      match q with
      | [] => None
      | x :: q' =>
        match dequeue q' with
        | None => Some ([], x)
        | Some (q'', y) => Some (x :: q'', y)
        end
      end.

    Definition equiv A (a b : t A) := a = b.
    Infix "~=" := equiv (at level 70).

    Theorem equiv_refl : forall A (a : t A), a ~= a.
    Proof.
      equality.
    Qed.

    Theorem equiv_sym : forall A (a b : t A), a ~= b -> b ~= a.
    Proof.
      equality.
    Qed.

    Theorem equiv_trans : forall A (a b c : t A), a ~= b -> b ~= c -> a ~= c.
    Proof.
      equality.
    Qed.

    Theorem equiv_enqueue : forall A (a b : t A) (x : A),
        a ~= b
        -> enqueue a x ~= enqueue b x.
    Proof.
      unfold equiv; equality.
    Qed.

    Definition dequeue_equiv A (a b : option (t A * A)) :=
      match a, b with
      | None, None => True
      | Some (qa, xa), Some (qb, xb) => qa ~= qb /\ xa = xb
      | _, _ => False
      end.

    Infix "~~=" := dequeue_equiv (at level 70).

    Theorem equiv_dequeue : forall A (a b : t A),
        a ~= b
        -> dequeue a ~~= dequeue b.
    Proof.
      unfold equiv, dequeue_equiv; simplify.
      rewrite H.
      cases (dequeue b).

      cases p.
      equality.

      propositional.
    Qed.

    Theorem dequeue_empty : forall A, dequeue (empty A) = None.
    Proof.
      simplify.
      equality.
    Qed.

    Theorem empty_dequeue : forall A (q : t A),
        dequeue q = None -> q ~= empty A.
    Proof.
      simplify.
      cases q.

      simplify.
      unfold equiv.
      equality.

      simplify.
      cases (dequeue q).
      cases p.
      equality.
      equality.
    Qed.

    Theorem dequeue_enqueue : forall A (q : t A) x,
        dequeue (enqueue q x)
        ~~= match dequeue q with
            | None => Some (empty A, x)
            | Some (q', y) => Some (enqueue q' x, y)
            end.
    Proof.
      unfold dequeue_equiv, equiv.
      induct q; simplify.

      equality.

      cases (dequeue q).

      cases p.
      equality.
      equality.
    Qed.
  End ListQueue.

  (* However, now we can implement the classic two-stacks optimized queue! *)
  Module TwoStacksQueue : QUEUE.
    Record stackpair (A : Set) := {
      EnqueueHere : list A;
      DequeueHere : list A
    }.

    Definition t := stackpair.

    Definition empty A : t A := {|
      EnqueueHere := [];
      DequeueHere := []
    |}.
    Definition enqueue A (q : t A) (x : A) : t A := {|
      EnqueueHere := x :: q.(EnqueueHere);
      DequeueHere := q.(DequeueHere)
    |}.
    Definition dequeue A (q : t A) : option (t A * A) :=
      match q.(DequeueHere) with
      | x :: dq => Some ({| EnqueueHere := q.(EnqueueHere);
                            DequeueHere := dq |}, x)
      | [] =>
        match rev q.(EnqueueHere) with
        | [] => None
        | x :: eq => Some ({| EnqueueHere := [];
                              DequeueHere := eq |}, x)
        end
      end.

    Definition equiv A (a b : t A) : Prop. Admitted.
    Infix "~=" := equiv (at level 70).

    Theorem equiv_refl : forall A (a : t A), a ~= a.
    Proof.
    Admitted.

    Theorem equiv_sym : forall A (a b : t A), a ~= b -> b ~= a.
    Proof.
    Admitted.

    Theorem equiv_trans : forall A (a b c : t A), a ~= b -> b ~= c -> a ~= c.
    Proof.
    Admitted.

    Theorem equiv_enqueue : forall A (a b : t A) (x : A),
        a ~= b
        -> enqueue a x ~= enqueue b x.
    Proof.
    Admitted.

    Definition dequeue_equiv A (a b : option (t A * A)) :=
      match a, b with
      | None, None => True
      | Some (qa, xa), Some (qb, xb) => qa ~= qb /\ xa = xb
      | _, _ => False
      end.

    Infix "~~=" := dequeue_equiv (at level 70).

    Theorem equiv_dequeue : forall A (a b : t A),
        a ~= b
        -> dequeue a ~~= dequeue b.
    Proof.
    Admitted.
      (*unfold equiv, dequeue_equiv, elements, dequeue; simplify.
      cases (DequeueHere a); simplify.
      cases (rev (EnqueueHere a)); simplify.
      cases (DequeueHere b); simplify.
      cases (rev (EnqueueHere b)); simplify.
      propositional.
      SearchRewrite (_ ++ []).
      rewrite app_nil_r in H.
      rewrite app_nil_r in H.
      equality.
      cases (EnqueueHere a); simplify.
      cases (EnqueueHere b); simplify.
      cases (rev l); simplify.
      equality.
      equality.
      equality.
      cases (rev l0); simplify.
      equality.
      equality.
      cases (DequeueHere b); simplify.
      cases (rev (EnqueueHere b)); simplify.
      rewrite app_nil_r in H.
      rewrite app_nil_r in H.
      equality.
      rewrite app_nil_r in H.
      rewrite app_nil_r in H.
      equality.
      rewrite app_nil_r in H.
      rewrite H in Heq0.
      SearchRewrite (rev (_ ++ _)).
      rewrite rev_app_distr in Heq0.
      rewrite rev_app_distr in Heq0.
      simplify.
      invert Heq0.
      unfold equiv, elements.
      simplify.
      rewrite rev_app_distr.
      SearchRewrite (rev (rev _)).
      rewrite rev_involutive.
      rewrite rev_involutive.
      equality.
      cases (DequeueHere b); simplify.
      cases (rev (EnqueueHere b)); simplify.
      rewrite app_nil_r in H.
      rewrite <- H in Heq1.
      cases (EnqueueHere a); simplify.
      cases (rev l); simplify.
      equality.
      rewrite rev_app_distr in Heq1.
      simplify.
      equality.
      rewrite rev_app_distr in Heq1.
      rewrite rev_app_distr in Heq1.
      simplify.
      equality.
      unfold equiv, elements.
      simplify.
      rewrite app_nil_r in H.
      rewrite <- H in Heq1.
      rewrite rev_app_distr in Heq1.
      rewrite rev_app_distr in Heq1.
      simplify.
      invert Heq1.
      rewrite rev_involutive.
      rewrite rev_app_distr.
      rewrite rev_involutive.
      equality.
      unfold equiv, elements.
      simplify.
      SearchAbout app cons nil.
      apply app_inj_tail.
      rewrite <- app_assoc.
      rewrite <- app_assoc.
      assumption.
    Qed.*)

    Theorem dequeue_empty : forall A, dequeue (empty A) = None.
    Proof.
      simplify.
      equality.
    Qed.

    Theorem empty_dequeue : forall A (q : t A),
        dequeue q = None -> q ~= empty A.
    Proof.
    Admitted.
      (*simplify.
      cases q.
      unfold dequeue in *.
      simplify.
      cases DequeueHere0.
      cases (rev EnqueueHere0).
      cases EnqueueHere0.
      equality.
      simplify.
      cases (rev EnqueueHere0); simplify.
      equality.
      equality.
      equality.
      equality.
    Qed.*)

    Theorem dequeue_enqueue : forall A (q : t A) x,
        dequeue (enqueue q x)
        ~~= match dequeue q with
            | None => Some (empty A, x)
            | Some (q', y) => Some (enqueue q' x, y)
            end.
    Proof.
    Admitted.
      (*unfold dequeue_equiv, equiv; simplify.
      cases q; simplify.
      unfold dequeue, enqueue; simplify.
      cases DequeueHere0; simplify.

      cases (rev EnqueueHere0); simplify.

      equality.

      unfold elements; simplify.
      SearchRewrite (rev (_ ++ _)).
      rewrite rev_app_distr.
      simplify.
      equality.

      equality.
    Qed.*)
  End TwoStacksQueue.

  Module DelayedSum (Q : QUEUE).
    Fixpoint makeQueue (n : nat) (q : Q.t nat) : Q.t nat :=
      match n with
      | 0 => q
      | S n' => makeQueue n' (Q.enqueue q n')
      end.

    Fixpoint computeSum (n : nat) (q : Q.t nat) : nat :=
      match n with
      | 0 => 0
      | S n' => match Q.dequeue q with
                | None => 0
                | Some (q', v) => v + computeSum n' q'
                end
      end.

    Fixpoint sumUpto (n : nat) : nat :=
      match n with
      | 0 => 0
      | S n' => n' + sumUpto n'
      end.

    Infix "~=" := Q.equiv (at level 70).
    Infix "~~=" := Q.dequeue_equiv (at level 70).

    Lemma makeQueue_congruence : forall n a b,
        a ~= b
        -> makeQueue n a ~= makeQueue n b.
    Proof.
      induct n; simplify.

      assumption.

      apply IHn.
      apply Q.equiv_enqueue.
      assumption.
    Qed.

    Lemma dequeue_makeQueue : forall n q,
        Q.dequeue (makeQueue n q)
        ~~= match Q.dequeue q with
            | Some (q', v) => Some (makeQueue n q', v)
            | None =>
              match n with
              | 0 => None
              | S n' => Some (makeQueue n' q, n')
              end
            end.
    Proof.
      induct n.

      simplify.
      cases (Q.dequeue q).
      cases p.
      unfold Q.dequeue_equiv.
      propositional.
      apply Q.equiv_refl.
      unfold Q.dequeue_equiv.
      propositional.

      simplify.
      unfold Q.dequeue_equiv in *.
      specialize (IHn (Q.enqueue q n)).
      cases (Q.dequeue (makeQueue n (Q.enqueue q n))).

      cases p.
      pose proof (Q.dequeue_enqueue q n).
      unfold Q.dequeue_equiv in *.
      cases (Q.dequeue (Q.enqueue q n)).

      cases p.
      cases (Q.dequeue q).

      cases p.
      propositional.
      apply Q.equiv_trans with (b := makeQueue n t0).
      assumption.
      apply makeQueue_congruence.
      assumption.
      equality.

      propositional.
      apply Q.equiv_trans with (b := makeQueue n t0).
      assumption.
      apply makeQueue_congruence.
      apply Q.equiv_trans with (b := Q.empty nat).
      assumption.
      apply Q.equiv_sym.
      apply Q.empty_dequeue.
      assumption.
      equality.

      cases (Q.dequeue q).

      cases p.
      propositional.

      propositional.

      pose proof (Q.dequeue_enqueue q n).
      unfold Q.dequeue_equiv in H.
      cases (Q.dequeue (Q.enqueue q n)).

      cases p.
      propositional.

      cases (Q.dequeue q).

      cases p.
      propositional.

      propositional.
    Qed.

    Theorem computeSum_congruence : forall n a b,
        a ~= b
        -> computeSum n a = computeSum n b.
    Proof.
      induct n.

      simplify.
      equality.

      simplify.
      pose proof (Q.equiv_dequeue H).
      unfold Q.dequeue_equiv in H0.
      cases (Q.dequeue a).

      cases p.
      cases (Q.dequeue b).
      cases p.
      rewrite IHn with (b := t0).
      equality.
      equality.
      propositional.

      cases (Q.dequeue b).
      propositional.
      equality.
    Qed.

    Theorem computeSum_ok : forall n,
        computeSum n (makeQueue n (Q.empty nat)) = sumUpto n.
    Proof.
      induct n.

      simplify.
      equality.

      simplify.
      pose proof (dequeue_makeQueue n (Q.enqueue (Q.empty nat) n)).
      unfold Q.dequeue_equiv in H.
      cases (Q.dequeue (makeQueue n (Q.enqueue (Q.empty nat) n))).

      cases p.
      pose proof (Q.dequeue_enqueue (Q.empty nat) n).
      unfold Q.dequeue_equiv in H0.
      cases (Q.dequeue (Q.enqueue (Q.empty nat) n)).

      cases p.
      rewrite Q.dequeue_empty in H0.
      propositional.
      f_equal.
      equality.
      rewrite <- IHn.

      apply computeSum_congruence.
      apply Q.equiv_trans with (b := makeQueue n t0).
      assumption.
      apply makeQueue_congruence.
      assumption.

      rewrite Q.dequeue_empty in H0.
      propositional.

      pose proof (Q.dequeue_enqueue (Q.empty nat) n).
      unfold Q.dequeue_equiv in H0.
      cases (Q.dequeue (Q.enqueue (Q.empty nat) n)).

      cases p.
      propositional.

      rewrite Q.dequeue_empty in H0.
      propositional.
    Qed.
  End DelayedSum.
End AlgebraicWithEquivalenceRelation.

Module RepFunction.
  Module Type QUEUE.
    Parameter t : Set -> Set.

    Parameter empty : forall A, t A.
    Parameter enqueue : forall A, t A -> A -> t A.
    Parameter dequeue : forall A, t A -> option (t A * A).

    Parameter rep : forall A, t A -> list A.

    (* Fill in laws here. *)
  End QUEUE.

  Module ListQueue : QUEUE.
    Definition t : Set -> Set := list.

    Definition empty A : t A := nil.
    Definition enqueue A (q : t A) (x : A) : t A := x :: q.
    Fixpoint dequeue A (q : t A) : option (t A * A) :=
      match q with
      | [] => None
      | x :: q' =>
        match dequeue q' with
        | None => Some ([], x)
        | Some (q'', y) => Some (x :: q'', y)
        end
      end.

    Definition rep A (q : t A) : list A. Admitted.

    (*Theorem empty_rep : forall A,
        rep (empty A) = [].
    Proof.
      equality.
    Qed.

    Theorem enqueue_rep : forall A (q : t A) x,
        rep (enqueue q x) = x :: rep q.
    Proof.
      equality.
    Qed.

    Theorem dequeue_empty : forall A (q : t A),
        rep q = []
        -> dequeue q = None.
    Proof.
      unfold rep; simplify.
      rewrite H.
      equality.
    Qed.

    Theorem dequeue_nonempty : forall A (q : t A) xs x,
        rep q = xs ++ [x]
        -> exists q', dequeue q = Some (q', x) /\ rep q' = xs.
    Proof.
      unfold rep; induct q.

      simplify.
      cases xs; simplify.
      equality.
      equality.

      simplify.
      cases xs; simplify.
      invert H; simplify.
      exists [].
      equality.

      invert H.
      assert (exists q' : t A, dequeue (xs ++ [x]) = Some (q', x) /\ q' = xs).
      apply IHq.
      equality.
      first_order.
      rewrite H.
      exists (a0 :: x0).
      equality.
    Qed.*)
  End ListQueue.

  Module TwoStacksQueue : QUEUE.
    Record stackpair (A : Set) := {
      EnqueueHere : list A;
      DequeueHere : list A
    }.

    Definition t := stackpair.

    Definition empty A : t A := {|
      EnqueueHere := [];
      DequeueHere := []
    |}.
    Definition enqueue A (q : t A) (x : A) : t A := {|
      EnqueueHere := x :: q.(EnqueueHere);
      DequeueHere := q.(DequeueHere)
    |}.
    Definition dequeue A (q : t A) : option (t A * A) :=
      match q.(DequeueHere) with
      | x :: dq => Some ({| EnqueueHere := q.(EnqueueHere);
                            DequeueHere := dq |}, x)
      | [] =>
        match rev q.(EnqueueHere) with
        | [] => None
        | x :: eq => Some ({| EnqueueHere := [];
                              DequeueHere := eq |}, x)
        end
      end.

    Definition rep A (q : t A) : list A. Admitted.

    (*Theorem empty_rep : forall A,
        rep (empty A) = [].
    Proof.
      equality.
    Qed.

    Theorem enqueue_rep : forall A (q : t A) x,
        rep (enqueue q x) = x :: rep q.
    Proof.
      equality.
    Qed.

    Theorem dequeue_empty : forall A (q : t A),
        rep q = []
        -> dequeue q = None.
    Proof.
      unfold rep, dequeue; simplify.
      cases (DequeueHere q); simplify.
      rewrite app_nil_r in H.
      rewrite H.
      simplify.
      equality.
      cases (EnqueueHere q); simplify.
      cases (rev l); simplify.
      equality.
      equality.
      equality.
    Qed.

    Theorem dequeue_nonempty : forall A (q : t A) xs x,
        rep q = xs ++ [x]
        -> exists q', dequeue q = Some (q', x) /\ rep q' = xs.
    Proof.
      unfold rep, dequeue; simplify.

      cases (DequeueHere q); simplify.

      rewrite app_nil_r in H.
      rewrite H.
      rewrite rev_app_distr; simplify.
      exists {| EnqueueHere := []; DequeueHere := rev xs |}.
      simplify.
      rewrite rev_involutive.
      equality.

      exists {| EnqueueHere := EnqueueHere q; DequeueHere := l |}.
      simplify.
      rewrite app_assoc in H.
      apply app_inj_tail in H.
      propositional.
      rewrite H1.
      equality.
    Qed.*)
  End TwoStacksQueue.

  Module DelayedSum (Q : QUEUE).
    Fixpoint makeQueue (n : nat) (q : Q.t nat) : Q.t nat :=
      match n with
      | 0 => q
      | S n' => makeQueue n' (Q.enqueue q n')
      end.

    Fixpoint computeSum (n : nat) (q : Q.t nat) : nat :=
      match n with
      | 0 => 0
      | S n' => match Q.dequeue q with
                | None => 0
                | Some (q', v) => v + computeSum n' q'
                end
      end.

    Fixpoint sumUpto (n : nat) : nat :=
      match n with
      | 0 => 0
      | S n' => n' + sumUpto n'
      end.

    Fixpoint upto (n : nat) : list nat :=
      match n with
      | 0 => []
      | S n' => upto n' ++ [n']
      end.

    Theorem computeSum_ok : forall n,
        computeSum n (makeQueue n (Q.empty nat)) = sumUpto n.
    Proof.
    Admitted.
  End DelayedSum.
End RepFunction.

(** * Data abstraction with fixed parameter types *)

Module Type FINITE_SET.
  Parameter key : Set. (* What type of data may be added to these sets? *)
  Parameter t : Set.   (* What is the type of sets themselves? *)

  Parameter empty : t.
  Parameter add : t -> key -> t.
  Parameter member : t -> key -> bool.

  Axiom member_empty : forall k, member empty k = false.

  Axiom member_add_eq : forall k s,
      member (add s k) k = true.
  Axiom member_add_noteq : forall k1 k2 s,
      k1 <> k2
      -> member (add s k1) k2 = member s k2.

  Axiom decidable_equality : forall a b : key, a = b \/ a <> b.
  (* ^-- This one may be surprising. *)
End FINITE_SET.

Module Type SET_WITH_EQUALITY.
  Parameter t : Set.
  Parameter equal : t -> t -> bool.

  Axiom equal_ok : forall a b, if equal a b then a = b else a <> b.
End SET_WITH_EQUALITY.

Module ListSet(SE : SET_WITH_EQUALITY) <: FINITE_SET with Definition key := SE.t.
  Definition key := SE.t.
  Definition t := list SE.t.

  Definition empty : t := [].
  Definition add (s : t) (k : key) : t := k :: s.
  Fixpoint member (s : t) (k : key) : bool :=
    match s with
    | [] => false
    | k' :: s' => SE.equal k' k || member s' k
    end.

  Theorem member_empty : forall k, member empty k = false.
  Proof.
    simplify.
    equality.
  Qed.

  Theorem member_add_eq : forall k s,
      member (add s k) k = true.
  Proof.
    simplify.
    pose proof (SE.equal_ok k k).
    cases (SE.equal k k); simplify.
    equality.
    equality.
  Qed.

  Theorem member_add_noteq : forall k1 k2 s,
      k1 <> k2
      -> member (add s k1) k2 = member s k2.
  Proof.
    simplify.
    pose proof (SE.equal_ok k1 k2).
    cases (SE.equal k1 k2); simplify.
    equality.
    equality.
  Qed.

  Theorem decidable_equality : forall a b : key, a = b \/ a <> b.
  Proof.
    simplify.
    pose proof (SE.equal_ok a b).
    cases (SE.equal a b); propositional.
  Qed.
End ListSet.

(* Here's an example decidable-equality type for natural numbers. *)
Module NatWithEquality <: SET_WITH_EQUALITY with Definition t := nat.
  Definition t := nat.

  Fixpoint equal (a b : nat) : bool :=
    match a, b with
    | 0, 0 => true
    | S a', S b' => equal a' b'
    | _, _ => false
    end.

  Theorem equal_ok : forall a b, if equal a b then a = b else a <> b.
  Proof.
    induct a; simplify.

    cases b.
    equality.
    equality.

    cases b.
    equality.
    specialize (IHa b).
    cases (equal a b).
    equality.
    equality.
  Qed.
End NatWithEquality.

(* And here's how to instantiate the generic set for the naturals. *)
Module NatSet := ListSet(NatWithEquality).

(* Now, some generic client code, for testing duplicate-freeness of lists. *)
Module FindDuplicates (FS : FINITE_SET).
  Fixpoint noDuplicates' (ls : list FS.key) (s : FS.t) : bool :=
    match ls with
    | [] => true
    | x :: ls' => negb (FS.member s x) && noDuplicates' ls' (FS.add s x)
    end.

  Definition noDuplicates (ls : list FS.key) := noDuplicates' ls FS.empty.

  (* A characterization of having a duplicate: the list can be partitioned into
   * pieces revealing the same element [a] at two boundaries. *)
  Definition hasDuplicate (ls : list FS.key) :=
    exists ls1 a ls2 ls3, ls = ls1 ++ a :: ls2 ++ a :: ls3.

  (* A characterization of containing an element [a]: the list can be
   * partitioned into two pieces, with [a] at the boundary. *)
  Definition contains (a : FS.key) (ls : list FS.key) :=
    exists ls1 ls2, ls = ls1 ++ a :: ls2.

  Lemma noDuplicates'_ok : forall ls s, if noDuplicates' ls s
                                        then ~(hasDuplicate ls
                                               \/ exists a, FS.member s a = true
                                                            /\ contains a ls)
                                        else (hasDuplicate ls
                                              \/ exists a, FS.member s a = true
                                                           /\ contains a ls).
  Proof.
    induct ls; simplify.

    unfold hasDuplicate, contains.
    propositional.
    first_order.
    cases x; simplify.
    equality.
    equality.

    first_order.
    cases x0; simplify.
    equality.
    equality.
    cases (FS.member s a); simplify.
    right.
    exists a.
    propositional.
    unfold contains.
    exists [].
    exists ls.
    simplify.
    equality.

    specialize (IHls (FS.add s a)).
    cases (noDuplicates' ls (FS.add s a)).
    propositional.

    apply H1.
    exists a.
    propositional.
    apply FS.member_add_eq.
    unfold hasDuplicate, contains in *.
    first_order.
    cases x; simplify.
    invert H0.
    exists x1.
    exists x2.
    equality.

    invert H0.
    exfalso.
    apply H with (x := x).
    exists x0.
    exists x1.
    exists x2.
    equality.

    first_order.
    apply H1 with x.
    propositional.
    pose proof (FS.decidable_equality a x).
    propositional.
    rewrite H4.
    apply FS.member_add_eq.
    rewrite FS.member_add_noteq.
    assumption.
    assumption.
    cases x0; simplify.
    equality.
    invert H2.
    exists x0.
    exists x1.
    equality.

    first_order.
    left.
    exists (a :: x).
    exists x0.
    exists x1.
    exists x2.
    simplify.
    equality.
    cases (FS.member s x).

    right.
    exists x.
    propositional.
    exists (a :: x0).
    exists x1.
    simplify.
    equality.

    left.
    pose proof (FS.decidable_equality a x).
    propositional.

    exists nil.
    exists a.
    exists x0.
    exists x1.
    simplify.
    equality.
    rewrite FS.member_add_noteq in H.
    equality.
    assumption.
  Qed.

  Theorem noDuplicates_ok : forall ls, if noDuplicates ls
                                       then ~hasDuplicate ls
                                       else hasDuplicate ls.
  Proof.
    simplify.
    pose proof (noDuplicates'_ok ls FS.empty).
    unfold noDuplicates.
    cases (noDuplicates' ls FS.empty); first_order.
    rewrite FS.member_empty in H.
    equality.
  Qed.
End FindDuplicates.

Module NatDuplicateFinder := FindDuplicates(NatSet).

Compute NatDuplicateFinder.noDuplicates [].
Compute NatDuplicateFinder.noDuplicates [1].
Compute NatDuplicateFinder.noDuplicates [1; 2].
Compute NatDuplicateFinder.noDuplicates [1; 2; 3].
Compute NatDuplicateFinder.noDuplicates [1; 2; 1; 3].

(** * Custom implementations of abstract data types *)

Fixpoint fromRange' (from to : nat) : NatSet.t :=
  match to with
  | 0 => NatSet.add NatSet.empty 0
  | S to' => if NatWithEquality.equal to from
             then NatSet.add NatSet.empty to
             else NatSet.add (fromRange' from to') (S to')
  end.

Definition fromRange (from to : nat) : NatSet.t :=
  if Compare_dec.leb from to
  then fromRange' from to
  else NatSet.empty.

Module NatRangeSet (*<: FINITE_SET with Definition key := nat*).
  Definition key := nat.

  (*Definition t := ....

  Definition empty : t := ....
  Definition add (s : t) (k : key) : t := ....
  Definition member (s : t) (k : key) : bool := ....*)

  (*Theorem member_empty : forall k, member empty k = false.
  Proof.
    simplify.
    equality.
  Qed.

  Lemma member_fromRange' : forall k from to,
      from <= to
      -> NatSet.member (fromRange' from to) k = Compare_dec.leb from k && Compare_dec.leb k to.
  Proof.
    induct to; simplify.

    cases k; simplify.
    rewrite Compare_dec.leb_correct by assumption.
    equality.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    equality.

    cases from; simplify.
    cases k; simplify.
    apply IHto.
    linear_arithmetic.
    pose proof (NatWithEquality.equal_ok to k).
    cases (NatWithEquality.equal to k); simplify.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    equality.
    rewrite IHto by linear_arithmetic.
    cases to.
    rewrite Compare_dec.leb_correct_conv by linear_arithmetic.
    equality.
    cases (Compare_dec.leb k to).
    apply Compare_dec.leb_complete in Heq0.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    equality.
    apply Compare_dec.leb_complete_conv in Heq0.
    rewrite Compare_dec.leb_correct_conv by linear_arithmetic.
    equality.

    pose proof (NatWithEquality.equal_ok to from).
    cases (NatWithEquality.equal to from); simplify.

    cases k; simplify.
    equality.
    pose proof (NatWithEquality.equal_ok to k).
    cases (NatWithEquality.equal to k); simplify.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    equality.
    cases (Compare_dec.leb from k); simplify.
    apply Compare_dec.leb_complete in Heq1.
    rewrite Compare_dec.leb_correct_conv by linear_arithmetic.
    equality.
    equality.

    cases k; simplify.
    apply IHto.
    linear_arithmetic.
    rewrite IHto by linear_arithmetic.
    pose proof (NatWithEquality.equal_ok to k).
    cases (NatWithEquality.equal to k); simplify.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    equality.

    cases to.
    rewrite (Compare_dec.leb_correct_conv 0 k) by linear_arithmetic.
    equality.
    cases (Compare_dec.leb k to).
    apply Compare_dec.leb_complete in Heq1.
    rewrite (Compare_dec.leb_correct k (S to)) by linear_arithmetic.
    equality.
    apply Compare_dec.leb_complete_conv in Heq1.
    rewrite (Compare_dec.leb_correct_conv (S to) k) by linear_arithmetic.
    equality.
  Qed.

  Theorem member_add_eq : forall k s,
      member (add s k) k = true.
  Proof.
    unfold member, add; simplify.
    cases s.

    SearchAbout Compare_dec.leb.
    rewrite Compare_dec.leb_correct.
    equality.
    linear_arithmetic.

    cases (Compare_dec.leb from k); simplify.
    cases (Compare_dec.leb k to); simplify.
    rewrite Heq.
    rewrite Heq0.
    apply Compare_dec.leb_complete in Heq.
    apply Compare_dec.leb_complete in Heq0.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    equality.

    pose proof (NatWithEquality.equal_ok k (from - 1)).
    cases (NatWithEquality.equal k (from - 1)).
    apply leb_complete in Heq.
    apply leb_complete_conv in Heq0.
    linear_arithmetic.
    simplify.
    pose proof (NatWithEquality.equal_ok k (to + 1)).
    cases (NatWithEquality.equal k (to + 1)); simplify.
    cases (Compare_dec.leb from to).
    rewrite Heq.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    equality.
    apply NatSet.member_add_eq.
    pose proof (NatWithEquality.equal_ok k k).
    cases (NatWithEquality.equal k k); simplify.
    equality.
    equality.

    pose proof (NatWithEquality.equal_ok k (from - 1)).
    cases (NatWithEquality.equal k (from - 1)); simplify.
    cases (Compare_dec.leb from to).
    apply Compare_dec.leb_complete in Heq1.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    equality.
    pose proof (NatWithEquality.equal_ok k (to + 1)).
    cases (NatWithEquality.equal k (to + 1)); simplify.
    pose proof (NatWithEquality.equal_ok k k).
    cases (NatWithEquality.equal k k); simplify.
    equality.
    equality.
    pose proof (NatWithEquality.equal_ok k k).
    cases (NatWithEquality.equal k k); simplify.
    equality.
    equality.
    pose proof (NatWithEquality.equal_ok k (to + 1)).
    cases (NatWithEquality.equal k (to + 1)); simplify.
    cases (Compare_dec.leb from to).
    apply Compare_dec.leb_complete in Heq2.
    apply Compare_dec.leb_complete_conv in Heq.
    linear_arithmetic.
    apply NatSet.member_add_eq.
    pose proof (NatWithEquality.equal_ok k k).
    cases (NatWithEquality.equal k k); simplify.
    equality.
    equality.

    apply NatSet.member_add_eq.
  Qed.

  Theorem member_add_noteq : forall k1 k2 s,
      k1 <> k2
      -> member (add s k1) k2 = member s k2.
  Proof.
    simplify.
    unfold member, add.
    cases s.

    cases (Compare_dec.leb k1 k2); simplify.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    apply Compare_dec.leb_complete in Heq.
    rewrite Compare_dec.leb_correct_conv.
    equality.
    unfold key in *. (* Tricky step!  Coq needs to see that we are really working with numbers. *)
    linear_arithmetic.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    equality.

    cases (Compare_dec.leb from k1); simplify.
    cases (Compare_dec.leb k1 to); simplify.
    equality.

    pose proof (NatWithEquality.equal_ok k1 (from - 1)).
    cases (NatWithEquality.equal k1 (from - 1)); simplify.
    apply leb_complete in Heq.
    apply leb_complete_conv in Heq0.
    linear_arithmetic.
    pose proof (NatWithEquality.equal_ok k1 (to + 1)).
    cases (NatWithEquality.equal k1 (to + 1)); simplify.
    cases (Compare_dec.leb from to).
    rewrite H1.
    cases (Compare_dec.leb from k2); simplify.
    cases (Compare_dec.leb k2 to).
    apply Compare_dec.leb_complete in Heq5.
    apply Compare_dec.leb_complete in Heq3.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    equality.
    apply Compare_dec.leb_complete in Heq3.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    apply Compare_dec.leb_complete_conv in Heq5.
    unfold key in *.
    rewrite Compare_dec.leb_correct_conv by linear_arithmetic.
    equality.
    rewrite andb_false_r.
    equality.
    simplify.
    pose proof (NatWithEquality.equal_ok k1 k2).
    cases (NatWithEquality.equal k1 k2); simplify.
    equality.
    unfold fromRange.
    rewrite Heq3.
    apply NatSet.member_empty.
    pose proof (NatWithEquality.equal_ok k1 k2).
    cases (NatWithEquality.equal k1 k2); simplify.
    equality.
    unfold fromRange.
    cases (Compare_dec.leb from to); simplify.
    apply member_fromRange'.
    apply Compare_dec.leb_complete.
    assumption.
    equality.

    pose proof (NatWithEquality.equal_ok k1 (from - 1)).
    cases (NatWithEquality.equal k1 (from - 1)); simplify.
    cases (Compare_dec.leb from to).
    apply Compare_dec.leb_complete in Heq1.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    f_equal.
    f_equal.
    cases (Compare_dec.leb k1 k2).
    apply Compare_dec.leb_complete in Heq2.
    apply Compare_dec.leb_complete_conv in Heq.
    unfold key in *.
    rewrite Compare_dec.leb_correct by linear_arithmetic.
    equality.
    apply Compare_dec.leb_complete_conv in Heq2.
    apply Compare_dec.leb_complete_conv in Heq.
    unfold key in *.
    rewrite Compare_dec.leb_correct_conv by linear_arithmetic.
    equality.
    pose proof (NatWithEquality.equal_ok k1 (to + 1)).
    cases (NatWithEquality.equal k1 (to + 1)); simplify.
    pose proof (NatWithEquality.equal_ok k1 k2).
    cases (NatWithEquality.equal k1 k2); simplify.
    unfold key in *; linear_arithmetic.
    unfold fromRange.
    rewrite Heq1.
    apply NatSet.member_empty.
    pose proof (NatWithEquality.equal_ok k1 k2).
    cases (NatWithEquality.equal k1 k2); simplify.
    equality.
    unfold fromRange.
    rewrite Heq1.
    apply NatSet.member_empty.
    pose proof (NatWithEquality.equal_ok k1 (to + 1)).
    cases (NatWithEquality.equal k1 (to + 1)); simplify.
    cases (Compare_dec.leb from to).
    rewrite Heq; simplify.
    apply Compare_dec.leb_complete in Heq2.
    apply Compare_dec.leb_complete_conv in Heq.
    linear_arithmetic.
    rewrite NatSet.member_add_noteq by assumption; simplify.
    unfold fromRange.
    rewrite Heq2.
    apply NatSet.member_empty.
    pose proof (NatWithEquality.equal_ok k1 k2).
    cases (NatWithEquality.equal k1 k2); simplify.
    equality.
    unfold fromRange.
    cases (Compare_dec.leb from to); simplify.
    apply member_fromRange'.
    apply Compare_dec.leb_complete; assumption.
    equality.
    apply NatSet.member_add_noteq.
    assumption.
  Qed.

  Theorem decidable_equality : forall a b : key, a = b \/ a <> b.
  Proof.
    simplify.
    pose proof (NatWithEquality.equal_ok a b).
    cases (NatWithEquality.equal a b); propositional.
  Qed.*)
End NatRangeSet.

(* Time for a head-to-head performance contest between our naive and clever
 * sets! *)

(*Module FasterNatDuplicateFinder := FindDuplicates(NatRangeSet).

Fixpoint upto (n : nat) : list nat :=
  match n with
  | 0 => []
  | S n' => n' :: upto n'
  end.

Compute upto 10.

Time Compute NatDuplicateFinder.noDuplicates (upto 1000).
Time Compute FasterNatDuplicateFinder.noDuplicates (upto 1000).*)


Require Import VST.floyd.proofauto.

Definition zip_with {A B C : Type} (f : A -> B -> C) (xs : list A) (ys : list B) : list C
  := map (uncurry f) (combine xs ys).

Definition sum_Z := fold_right Z.add 0.

Lemma sum_Z_app xs ys : sum_Z (xs ++ ys) = sum_Z xs + sum_Z ys.
Proof.
  induction xs; simpl; lia.
Qed.

Lemma sum_Z_sublist (xs : list Z) (i : Z) :
  0 <= i < Zlength xs -> sum_Z (sublist 0 (i+1) xs) = sum_Z (sublist 0 i xs) + Znth i xs.
Proof.
  intros.
  rewrite (sublist_split 0 i (i+1)) by lia.
  rewrite (sublist_one i (i+1)) by lia.
  rewrite sum_Z_app; simpl.
  lia.
Qed.

Lemma Zlength_combine (xs ys : list Z) :
  Zlength (combine xs ys) = Z.min (Zlength xs) (Zlength ys).
Proof.
  apply Zlength_length.
  list_solve.
  rewrite combine_length.
  rewrite Z2Nat.inj_min.
  rewrite 2 ZtoNat_Zlength.
  reflexivity.
Qed.

Lemma Znth_combine (xs ys : list Z) (i : Z) :
  0 <= i < Zlength (combine xs ys) ->
  Znth i (combine xs ys) = (Znth i xs, Znth i ys).
Proof.
  intros.
  set (n := Zlength (combine xs ys)).
  rewrite <- (Znth_firstn (combine xs ys) i n).
  rewrite combine_firstn.
  rewrite <- nth_Znth.
  rewrite combine_nth.
  rewrite 2 nth_Znth.
  rewrite 2 Znth_firstn.
  reflexivity.
  all: unfold n.
  all: repeat (rewrite Zlength_combine in *).
  all: repeat (rewrite Zlength_firstn).
  all: repeat (rewrite firstn_length).
  all: repeat (rewrite <- ZtoNat_Zlength).
  all: lia.
Qed.

Definition onehot (a b x : Z) : list Z :=
  list_repeat (Z.to_nat (x - a)) 0 ++ [1] ++ list_repeat (Z.to_nat (b - x - 1)) 0.

Definition addvec : list Z -> list Z -> list Z := zip_with Z.add.

Definition count_frequency (xs : list Z) (a b : Z) : list Z
  := fold_right addvec (list_repeat (Z.to_nat (b - a)) 0) (map (onehot a b) xs).

Definition flipped_inner_product (xs ys : list Z) : Z :=
  sum_Z (zip_with Z.mul xs (rev ys)).

Lemma Zlength_onehot (a b x : Z) :
  a <= x < b -> Zlength (onehot a b x) = b - a.
Proof.
  intros.
  unfold onehot.
  rewrite 2 Zlength_app.
  rewrite 2 Zlength_list_repeat.
  - assert (Zlength_one : Zlength [1] = 1) by reflexivity.
    rewrite Zlength_one.
    lia.
  - lia.
  - lia.
Qed.

Lemma Zlength_count_frequency (xs : list Z) (a b : Z) :
  a <= b ->
  Forall (fun x => a <= x < b) xs ->
  Zlength (count_frequency xs a b) = b - a.
Proof.
  intros.
  unfold count_frequency.
  induction xs; simpl.
  - rewrite Zlength_list_repeat; lia.
  - unfold addvec, zip_with in *.
    rewrite Zlength_map.
    rewrite Zlength_combine.
    rewrite IHxs.
    rewrite Zlength_onehot.
    + lia.
    + inversion H0.
      lia.
    + inversion H0.
      assumption.
Qed.

Lemma length_count_frequency (xs : list Z) (a b : Z) :
  a <= b ->
  Forall (fun x => a <= x < b) xs ->
  length (count_frequency xs a b) = Z.to_nat (b - a).
Proof.
  intros.
  rewrite <- (Zlength_count_frequency xs a b); try assumption.
  rewrite ZtoNat_Zlength.
  reflexivity.
Qed.

Lemma combine_list_repeat_l (A B : Type) (y : A) (xs : list B) :
  combine (list_repeat (length xs) y) xs = map (fun x => (y,x)) xs.
Proof.
  induction xs.
  - reflexivity.
  - simpl.
    rewrite IHxs.
    reflexivity.
Qed.

Lemma addvec_id_l (xs : list Z) :
  addvec (list_repeat (length xs) 0) xs = xs.
Proof.
  unfold addvec, zip_with.
  rewrite combine_list_repeat_l.
  rewrite map_map.
  apply map_id.
Qed.

Lemma combine_list_repeat_r (A B : Type) (xs : list A) (y : B) :
  combine xs (list_repeat (length xs) y) = map (fun x => (x, y)) xs.
Proof.
  induction xs.
  - reflexivity.
  - simpl.
    rewrite IHxs.
    reflexivity.
Qed.

Lemma addvec_id_r (xs : list Z) :
  addvec xs (list_repeat (length xs) 0) = xs.
Proof.
  unfold addvec, zip_with.
  rewrite combine_list_repeat_r.
  rewrite map_map.
  simpl.
  assert ((fun x : Z => x + 0) = (fun x => x)).
  - apply functional_extensionality.
    intros.
    apply Z.add_0_r.
  - rewrite H.
    apply map_id.
Qed.

Lemma addvec_sym (xs ys : list Z) :
  addvec xs ys = addvec ys xs.
Proof with (rewrite Zlength_combine; lia).
  unfold addvec, zip_with.
  apply Znth_eq_ext.
  - rewrite 2 Zlength_map.
    rewrite 2 Zlength_combine.
    lia.
  - intros.
    rewrite Zlength_map, Zlength_combine in H.
    rewrite 2 Znth_map.
    rewrite 2 Znth_combine.
    simpl.
    all: try (rewrite Zlength_combine).
    all: lia.
Qed.

Lemma addvec_assoc (xs ys zs : list Z) :
  addvec xs (addvec ys zs) = addvec (addvec xs ys) zs.
Proof.
  revert zs.
  revert ys.
  induction xs.
  - reflexivity.
  - intros.
    destruct ys, zs.
    + reflexivity.
    + reflexivity.
    + reflexivity.
    + unfold addvec, zip_with in *.
      simpl in *.
      rewrite IHxs.
      assert (H : a + (z + z0) = (a + z) + z0) by lia.
      rewrite H.
      reflexivity.
Qed.

Lemma count_frequency_cons (a b x : Z) (xs : list Z) :
  count_frequency (x :: xs) a b = addvec (onehot a b x) (count_frequency xs a b).
Proof.
  reflexivity.
Qed.

Lemma count_frequency_app (xs ys : list Z) (a b : Z) :
  a <= b ->
  Forall (fun x => a <= x < b) ys ->
  count_frequency (xs ++ ys) a b = addvec (count_frequency xs a b) (count_frequency ys a b).
Proof.
  intros.
  induction xs.
  - unfold count_frequency at 2.
    simpl.
    rewrite <- (length_count_frequency ys a b); try assumption.
    rewrite addvec_id_l.
    reflexivity.
  - simpl.
    rewrite 2 count_frequency_cons.
    rewrite IHxs.
    apply addvec_assoc.
Qed.

Lemma Znth_addvec (xs ys : list Z) (i : Z) :
  0 <= i < Z.min (Zlength xs) (Zlength ys) ->
  Znth i (addvec xs ys) = Znth i xs + Znth i ys.
Proof.
  intros.
  unfold addvec, zip_with.
  rewrite Znth_map.
  rewrite Znth_combine.
  reflexivity.
  all : rewrite Zlength_combine; lia.
Qed.

Lemma Znth_onehot_1 (a b x : Z) :
  a <= x < b ->
  Znth (x - a) (onehot a b x) = 1.
Proof.
  intros.
  unfold onehot.
  rewrite Znth_app2 by (rewrite Zlength_list_repeat; lia).
  rewrite Zlength_list_repeat by lia.
  rewrite Z.sub_diag.
  simpl.
  apply Znth_0_cons.
Qed.

Lemma Znth_onehot_0 (a b x i : Z) :
  a <= x < b ->
  0 <= i < b - a ->
  i <> x - a ->
  Znth i (onehot a b x) = 0.
Proof.
  intros.
  assert (Hi : i < x - a \/ i > x - a) by lia.
  assert (L1 : Zlength [1] = 1) by reflexivity.
  unfold onehot.
  destruct Hi.
  - rewrite Znth_app1 by (rewrite Zlength_list_repeat; lia).
    apply Znth_list_repeat_inrange.
    lia.
  - rewrite app_Znth2 by (rewrite Zlength_list_repeat; lia).
    rewrite app_Znth2 by (rewrite Zlength_list_repeat, L1; lia).
    rewrite Zlength_list_repeat by lia.
    apply Znth_list_repeat_inrange.
    lia.
Qed.

Lemma Zlength_addvec (xs ys : list Z) :
  Zlength (addvec xs ys) = Z.min (Zlength xs) (Zlength ys).
Proof.
  unfold addvec, zip_with.
  rewrite Zlength_map.
  apply Zlength_combine.
Qed.

Lemma addvec_onehot_r (a b x : Z) (xs : list Z) :
  a <= x < b ->
  Zlength xs = b - a ->
  upd_Znth (x-a) xs (Znth (x-a) xs + 1) = addvec xs (onehot a b x).
Proof.
  intros.
  apply Znth_eq_ext.
  - rewrite Zlength_upd_Znth.
    rewrite Zlength_addvec.
    rewrite Zlength_onehot; lia.
  - intros.
    rewrite Zlength_upd_Znth in H1.
    assert (DE : i = x - a \/ i <> x - a) by lia.
    destruct DE.
    + rewrite H2.
      rewrite upd_Znth_same by lia.
      rewrite Znth_addvec by (rewrite Zlength_onehot; lia).
      rewrite Znth_onehot_1 by assumption.
      reflexivity.
    + rewrite Znth_upd_Znth_diff by assumption.
      rewrite Znth_addvec.
      rewrite Znth_onehot_0; try lia.
      rewrite Zlength_onehot; lia.
Qed.

Lemma addvec_onehot_l (a b x : Z) (xs : list Z) :
  a <= x < b ->
  Zlength xs = b - a ->
  upd_Znth (x-a) xs (Znth (x-a) xs + 1) = addvec (onehot a b x) xs.
Proof.
  intros.
  rewrite (addvec_onehot_r a b x xs) by assumption.
  apply addvec_sym.
Qed.


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

(* G. Huet 1-9-95 *)

(** We consider a Set [U], given with a commutative-associative operator [op],
    and a congruence [cong]; we show permutation lemmas *)

Section Axiomatisation.

  Variable U : Type.
  Variable op : U -> U -> U.
  Variable cong : U -> U -> Prop.

  Hypothesis op_comm : forall x y:U, cong (op x y) (op y x).
  Hypothesis op_ass : forall x y z:U, cong (op (op x y) z) (op x (op y z)).

  Hypothesis cong_left : forall x y z:U, cong x y -> cong (op x z) (op y z).
  Hypothesis cong_right : forall x y z:U, cong x y -> cong (op z x) (op z y).
  Hypothesis cong_trans : forall x y z:U, cong x y -> cong y z -> cong x z.
  Hypothesis cong_sym : forall x y:U, cong x y -> cong y x.

  (** Remark. we do not need: [Hypothesis cong_refl : (x:U)(cong x x)]. *)

  Lemma cong_congr :
    forall x y z t:U, cong x y -> cong z t -> cong (op x z) (op y t).
  Proof.
    intros; apply cong_trans with (op y z).
    apply cong_left; trivial.
    apply cong_right; trivial.
  Qed.

  Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)).
  Proof.
    intros; apply cong_right; apply op_comm.
  Qed.

  Lemma comm_left : forall x y z:U, cong (op (op x y) z) (op (op y x) z).
  Proof.
    intros; apply cong_left; apply op_comm.
  Qed.

  Lemma perm_right : forall x y z:U, cong (op (op x y) z) (op (op x z) y).
  Proof.
    intros.
    apply cong_trans with (op x (op y z)).
    apply op_ass.
    apply cong_trans with (op x (op z y)).
    apply cong_right; apply op_comm.
    apply cong_sym; apply op_ass.
  Qed.

  Lemma perm_left : forall x y z:U, cong (op x (op y z)) (op y (op x z)).
  Proof.
    intros.
    apply cong_trans with (op (op x y) z).
    apply cong_sym; apply op_ass.
    apply cong_trans with (op (op y x) z).
    apply cong_left; apply op_comm.
    apply op_ass.
  Qed.

  Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)).
  Proof.
    intros; apply cong_trans with (op (op x y) z).
    apply cong_sym; apply op_ass.
    apply op_comm.
  Qed.

  (** Needed for treesort ... *)
  Lemma twist :
    forall x y z t:U, cong (op x (op (op y z) t)) (op (op y (op x t)) z).
  Proof.
    intros.
    apply cong_trans with (op x (op (op y t) z)).
    apply cong_right; apply perm_right.
    apply cong_trans with (op (op x (op y t)) z).
    apply cong_sym; apply op_ass.
    apply cong_left; apply perm_left.
  Qed.

End Axiomatisation.


Print unit.

(*
Inductive unit : Set :=  tt : unit
*)

Print True.

(*
Inductive True : Prop :=  I : True
*)

(* it would seem that the types unit and True are isomorphic *)

Definition toUnit (x:True) : unit := tt.

Definition toTrue (x:unit) : True := I.

Lemma check1 : forall (x:True), toTrue (toUnit x) = x.
Proof. intros x. unfold toTrue. destruct x. reflexivity. Qed.

Lemma check2 : forall (x:unit), toUnit (toTrue x) = x.
Proof. intros x. unfold toUnit. destruct x. reflexivity. Qed.

Definition unitToBool (x:unit) : bool :=
    match x with
    | tt            => true
    end.

Lemma check3 : forall (x:unit), unitToBool x = true.
Proof. intros x. destruct x. reflexivity. Qed.

Definition TrueToBool (x:True) : bool :=
    match x with
    | I             => true
    end.

Lemma check4 : forall (x:True), TrueToBool x = true.
Proof. intros x. destruct x. reflexivity. Qed.


Require Import Equiv Properties.

(* Como teremos apenas um grupo podemos definir a classe Group bundled.
   Para a classe ActionGroup e NominalSets seria interessante fazer
   unbundled.

   Exemplo de unbundled:
   Group {A} {Setoid A} (null: A) (op: A -> A -> A) (inv: A -> A) := {
      assoc: forall p1 p2 p3, op p1 (op p2 p3) == op (op p1 p2) p3;
      left_inv: forall p, op p (inv p) == null
   }.

   Uma vantagem do unblundled é que podemos definir multiplas instâncias
   diferentes de grupos para um mesmo tipo através de diferentes operações
   e operadores. No bundled teremos problema de overlaping instances.

   O problema deste método é que não temos como referenciar as operações,
   e operadores: null, op e inv. Para isso é necessário definir
   cada um como uma classe unitária:
   Class GroupOp A := grp_op: A -> A -> A.

   Exemplo bundled:
   Group (A: Type) := {
      grp_setoid :> Setoid A;
      null: A;
      grp_op: A -> A -> A;
      grp_inv: A -> A;

      assoc: forall p1 p2 p3, op p1 (op p2 p3) == op (op p1 p2) p3;
      left_inv: forall p, op p (inv p) == null
   }. *)

(** *Canonical names  *)
Class Neutral A := neutral: A.
Class Binop A := b_op: A -> A -> A.
Class Negate A := negate: A -> A.
Typeclasses Transparent Neutral Binop Negate.

Infix "+" := b_op (at level 50, left associativity) : nominal_scope.
Notation "(+)" := b_op (only parsing) : nominal_scope.
Notation "( x +)" := (b_op x) (only parsing) : nominal_scope.
Notation "(+ x )" := (λ y, y + x) (only parsing) : nominal_scope.

Notation "- x" := (negate x) : nominal_scope.
Notation "(-)" := negate (only parsing) : nominal_scope.
Notation "x - y" := (x + -y)%nominal : nominal_scope.

Section GroupClass.
  Context A {Ea: Equiv A}.

  Class Group {GU: Neutral A} {GN: Negate A} {GOp: Binop A}: Prop :=
    { g_setoid :> Setoid A;
      g_op_proper :> Proper ((=) ==> (=) ==> (=)) (+);
      g_ne_proper :> Proper ((=) ==> (=)) (-);
      g_assoc :> Associative (+);
      g_left_id :> LeftIdentity (+) neutral;
      g_right_id :> RightIdentity (+) neutral;
      g_left_inv :> LeftInverse (+) (-) neutral;
      g_right_inv :> RightInverse (+) (-) neutral
    }.
End GroupClass.
Arguments g_op_proper {_ _ _ _ _ _}.
Arguments g_ne_proper {_ _ _ _ _ _}.
Arguments g_right_inv {_ _ _ _ _ _}.
Arguments g_left_inv {_ _ _ _ _ _}.

Section GroupProperties.
  Context `{Group G}.

  Global Instance negate_involutive: Involutive (-).
  Proof.
    intros x; rewrite <-(left_identity x) at 2;
      rewrite <- (left_inverse (-x)), <- associativity,
      left_inverse, right_identity.
    reflexivity.
  Qed.

  Global Instance: Injective (-).
  Proof.
    repeat (split; try apply _);
      intros x y E; rewrite <-(involutive x), <-(involutive y), E;
        reflexivity.
  Qed.

  Lemma negate_neutral: -neutral = neutral.
  Proof.
    rewrite <-(left_inverse neutral) at 2; rewrite right_identity;
      reflexivity.
  Qed.
End GroupProperties.

(** *Group Action *)
Class Action `(Group A) X := action: A -> X -> X.
Infix "∙" := action (at level 50, left associativity): nominal_scope.
Notation "(∙)" := action (only parsing).
Typeclasses Transparent Action.

Section GroupAction.
  (* Action of Group A over set X *)
  Context `(Ga: Group A) X {Ex: Equiv X}.

  (* Left group action *)
  Class GroupAction {GAct: Action Ga X}: Prop :=
    { gct_setoid :> Setoid X;
      gct_proper :> Proper ((=) ==> (=) ==> (=)) (∙);
      gct_compat: forall p q r, p ∙ (q ∙ r) = (q + p) ∙ r;
      gct_id :> LeftIdentity (∙) neutral }.
End GroupAction.
Arguments gct_proper {_ _ _ _ _ _ _ _ _ _}.
Arguments gct_compat {_ _ _ _ _ _ _ _ _ _}.
Arguments gct_id {_ _ _ _ _ _ _ _ _ _}.


From Coq Require Import Reals.
From Interval Require Import Tactic.

Open Scope R_scope.

Goal forall x y, -1/2 <= x <= 1/2 -> -1/2 <= y <= 1/2 ->
  Rabs (exp (x + y) / (exp x * exp y) - 1) <= 1/10.
Proof.
intros x y Hx Hy.
interval with (i_autodiff x, i_bisect y, i_bisect x).
Qed.


Require Import WildCat.
Require Import Pointed.
Require Import Spaces.Int Spaces.Circle Spaces.Spheres.
Require Import Algebra.AbGroups.
Require Import Homotopy.HomotopyGroup.

(** The fundamental group of the 1-sphere *)

Local Open Scope wc_iso_scope.

Section Pi1S1.
  Context `{Univalence}.

  Local Open Scope int_scope.
  Local Open Scope pointed_scope.

  Theorem Pi1Circle : Pi 1 [Circle, base] ≅ abgroup_Z.
  Proof.
    (** We give the isomorphism backwards, so we check the operation is preserved coming from the integer side. *)
    symmetry.
    srapply Build_GroupIsomorphism'.
    { equiv_via (base = base).
      2: exact (equiv_tr 0 (loops [Circle, base])).
      symmetry.
      exact equiv_loopCircle_int. }
    intros a b.
    cbn; apply ap.
    apply loopexp_add.
  Defined.

  Theorem Pi1S1 : Pi 1 (psphere 1) ≅ abgroup_Z.
  Proof.
    etransitivity.
    2: apply Pi1Circle.
    apply groupiso_pi_functor.
    apply pequiv_S1_Circle.
  Defined.

End Pi1S1.


Require Export Category Functor NaturalTransformation.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Section FunctorCategory.
  Context `{Funext}.

  Variable C : PreCategory.
  Variable D : PreCategory.

  (** There is a category Fun(C, D) of functors from [C] to [D]. *)

  Definition FunctorCategory : PreCategory.
    refine (@Build_PreCategory (Functor C D)
                               (NaturalTransformation (C := C) (D := D))
                               (IdentityNaturalTransformation (C := C) (D := D))
                               (NTComposeT (C := C) (D := D))
                               _
                               _
                               _
                               _);
    abstract (nt_eq; auto with morphism).
  Defined.
End FunctorCategory.

Notation "C ^ D" := (FunctorCategory D C) : category_scope.
Notation "[ C , D ]" := (FunctorCategory C D) : category_scope.

Lemma IsStrict_FunctorCategory `{Funext} C `{IsStrictCategory D}
: IsStrictCategory [C, D].
Proof.
  typeclasses eauto.
Defined.


Require Import Permutation List Lia.

Inductive value := x0 | x1 | x2 | x3 | x4 | x5 | x6 | x7.
Inductive variable := aux | num: value -> variable.
Definition variable_eq_dec (x y: variable): {x=y} + {x<>y}.
Proof.
  destruct x, y.
  + left; auto.
  + right; abstract congruence.
  + right; abstract congruence.
  + destruct v, v0; try (left; abstract congruence); (right; abstract congruence).
Defined.

Inductive assignment := assign: variable -> variable -> assignment.
Inductive comparison := GT: forall (more less: value), comparison.

Inductive step :=
| assignments: forall (L: list assignment), step
| conditional: forall (c: comparison) (positive negative: step), step.

Definition algorithm := list step.

Definition instantation := variable -> nat.

Definition is_increasing (i: instantation) :=
  i (num x0) <= i (num x1) /\
  i (num x1) <= i (num x2) /\
  i (num x2) <= i (num x3) /\
  i (num x3) <= i (num x4) /\
  i (num x4) <= i (num x5) /\
  i (num x5) <= i (num x6) /\
  i (num x6) <= i (num x7).
Definition list_of_values (i: instantation) :=
  i (num x0) :: i (num x1) :: i (num x2) :: i (num x3) :: i (num x4) :: i (num x5) :: i (num x6) :: i (num x7) :: nil.
Definition is_permutation (i1 i2: instantation) := Permutation (list_of_values i1) (list_of_values i2).

Definition is_sorted (start result: instantation) := is_increasing result /\ is_permutation start result.

Definition run_assignment (values: instantation) (a: assignment): instantation.
Proof.
  destruct a as [v1 v2].
  exact (fun i => if variable_eq_dec i v1 then values v2 else values i).
Defined.

Definition run_step (values: instantation) (s: step): instantation.
Proof.
  induction s.
  + induction L.
    - exact values.
    - exact (run_assignment IHL a).
  + destruct c.
    exact (if Compare_dec.gt_dec (values (num more)) (values (num less)) then IHs1 else IHs2).
Defined.

Definition run_algorithm (values: instantation) (algo: algorithm): instantation.
Proof.
  induction algo.
  + exact values.
  + exact (run_step IHalgo a).
Defined.

Definition run_algorithm_tail (values: instantation) (s: step) (algo: algorithm):
  run_algorithm values (algo ++ s :: nil) = run_algorithm (run_step values s) algo.
Proof.
  induction algo.
  + simpl. auto.
  + simpl. rewrite IHalgo. auto.
Qed.

Definition count_comparisons_in_step (s: step): nat.
Proof.
  induction s.
  + exact 0.
  + exact (1 + PeanoNat.Nat.max IHs1 IHs2).
Defined.
Definition count_comparisons_in_algorithm (a: algorithm): nat.
Proof.
  induction a as [| s L].
  + exact 0.
  + exact (IHL + count_comparisons_in_step s).
Defined.

Definition do_nothing := assignments nil.
Definition swap (x y: value) :=
  assign (num y) aux ::
  assign (num x) (num y) ::
  assign aux (num x) ::
  nil.

Definition property (L: list comparison) (i: instantation): Prop.
Proof.
  induction L.
  + exact True.
  + destruct a. exact (IHL /\ i (num less) <= i (num more)).
Defined.

Definition step1 := conditional (GT x0 x1) (assignments (swap x0 x1)) do_nothing.
Definition prop1 := GT x1 x0 :: nil.
Definition step2 := conditional (GT x2 x3) (assignments (swap x2 x3)) do_nothing.
Definition prop2 := GT x3 x2 :: prop1.
Definition step3 := conditional (GT x4 x5) (assignments (swap x4 x5)) do_nothing.
Definition prop3 := GT x5 x4 :: prop2.
Definition step4 := conditional (GT x6 x7) (assignments (swap x6 x7)) do_nothing.
Definition prop4 := GT x7 x6 :: prop3.
Definition step5 := conditional (GT x1 x3) (assignments (swap x1 x3 ++ swap x0 x2)) do_nothing.
Definition prop5 := GT x3 x1 :: prop4.
Definition step6 := conditional (GT x5 x7) (assignments (swap x5 x7 ++ swap x4 x6)) do_nothing.
Definition prop6 := GT x7 x5 :: prop5.
Definition step7 := conditional (GT x3 x7) (assignments (swap x0 x4 ++ swap x1 x5 ++ swap x2 x6 ++ swap x3 x7)) do_nothing.
Definition prop7 := GT x7 x3 :: prop6.
Definition step8_9 := conditional (GT x5 x3)
                       do_nothing
                       (conditional (GT x5 x1)
                        (assignments (swap x3 x5 ++ swap x2 x4))
                        (assignments (
                         assign (num x2) aux :: assign (num x4) (num x2) :: assign (num x0) (num x4) :: assign aux (num x0) ::
                         assign (num x3) aux :: assign (num x5) (num x3) :: assign (num x1) (num x5) :: assign aux (num x1) :: nil))).
Definition prop9 := GT x5 x3 :: prop6.
Definition step10_11 := conditional (GT x1 x4)
                         (conditional (GT x0 x4)
                          (assignments (assign (num x1) aux :: assign (num x2) (num x1) :: assign (num x3) (num x2) ::
                                        assign (num x4) (num x3) :: assign (num x0) (num x4) :: assign aux (num x0) :: nil))
                          (assignments (assign (num x2) aux :: assign (num x3) (num x2) :: assign (num x4) (num x3) ::
                                        assign (num x1) (num x4) :: assign aux (num x1) :: nil)))
                         (conditional (GT x3 x4)
                          (assignments (assign (num x3) aux :: assign (num x4) (num x3) :: assign (num x2) (num x4) ::
                                        assign aux (num x2) :: nil))
                          (assignments (swap x2 x3))).
Definition prop11 := GT x1 x0 :: GT x2 x1 :: GT x4 x2 :: GT x4 x3 :: GT x5 x4 :: GT x7 x5 :: GT x7 x6 :: nil.
Definition step12_13 := conditional (GT x1 x3)
                         (conditional (GT x0 x3)
                          (assignments (assign (num x1) aux :: assign (num x2) (num x1) :: assign (num x3) (num x2) ::
                                        assign (num x0) (num x3) :: assign aux (num x0) :: nil))
                          (assignments (assign (num x2) aux :: assign (num x3) (num x2) :: assign (num x1) (num x3) ::
                                        assign aux (num x1) :: nil)))
                         (conditional (GT x2 x3)
                          (assignments (swap x2 x3)) do_nothing).
Definition prop13 := GT x1 x0 :: GT x2 x1 :: GT x3 x2 :: GT x4 x3 :: GT x5 x4 :: GT x7 x5 :: GT x7 x6 :: nil.
Definition step14_15_16 :=
  conditional (GT x3 x6)
   (conditional (GT x1 x6)
     (conditional (GT x0 x6)
      (assignments (assign (num x1) aux :: assign (num x2) (num x1) :: assign (num x3) (num x2) :: assign (num x4) (num x3) ::
                    assign (num x5) (num x4) :: assign (num x6) (num x5) :: assign (num x0) (num x6) :: assign aux (num x0) :: nil))
      (assignments (assign (num x2) aux :: assign (num x3) (num x2) :: assign (num x4) (num x3) :: assign (num x5) (num x4) ::
                    assign (num x6) (num x5) :: assign (num x1) (num x6) :: assign aux (num x1) :: nil)))
     (conditional (GT x2 x6)
      (assignments (assign (num x3) aux :: assign (num x4) (num x3) :: assign (num x5) (num x4) :: assign (num x6) (num x5) ::
                    assign (num x2) (num x6) :: assign aux (num x2) :: nil))
      (assignments (assign (num x4) aux :: assign (num x5) (num x4) :: assign (num x6) (num x5) :: assign (num x3) (num x6) ::
                    assign aux (num x3) :: nil))))
   (conditional (GT x5 x6)
     (conditional (GT x4 x6)
      (assignments (assign (num x5) aux :: assign (num x6) (num x5) :: assign (num x4) (num x6) :: assign aux (num x4) :: nil))
      (assignments (swap x5 x6)))
     do_nothing).
Definition prop16 := GT x1 x0 :: GT x2 x1 :: GT x3 x2 :: GT x4 x3 :: GT x5 x4 :: GT x6 x5 :: GT x7 x6 :: nil.

Definition sort8: algorithm := step14_15_16 :: step12_13 :: step10_11 :: step8_9 :: step7 ::
                               step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil.

Eval compute in count_comparisons_in_algorithm sort8.

Ltac T1 after := intros; repeat split; simpl in *; unfold after; clear after;
     repeat destruct Compare_dec.gt_dec; repeat (destruct variable_eq_dec; try congruence); lia.

Definition step1_condition (before: instantation):
  let after := run_algorithm before (step1 :: nil) in
  property prop1 after.
Proof.
  T1 after.
Qed.
Definition step2_after_step1_condition (before: instantation)
  (H: property prop1 before):
  let after := run_algorithm before (step2 :: nil) in
  property prop2 after.
Proof.
  T1 after.
Qed.
Definition step3_after_step2_condition (before: instantation)
  (H: property prop2 before):
  let after := run_algorithm before (step3 :: nil) in
  property prop3 after.
Proof.
  T1 after.
Qed.
Definition step4_after_step3_condition (before: instantation)
  (H: property prop3 before):
  let after := run_algorithm before (step4 :: nil) in
  property prop4 after.
Proof.
  T1 after.
Qed.
Definition step5_after_step4_condition (before: instantation)
  (H: property prop4 before):
  let after := run_algorithm before (step5 :: nil) in
  property prop5 after.
Proof.
  T1 after.
Qed.
Definition step6_after_step5_condition (before: instantation)
  (H: property prop5 before):
  let after := run_algorithm before (step6 :: nil) in
  property prop6 after.
Proof.
  T1 after.
Qed.
Definition step7_after_step6_condition (before: instantation)
  (H: property prop6 before):
  let after := run_algorithm before (step7 :: nil) in
  property prop7 after.
Proof.
  T1 after.
Qed.
Definition step9_after_step7_condition (before: instantation)
  (H: property prop7 before):
  let after := run_algorithm before (step8_9 :: nil) in
  property prop9 after.
Proof.
  T1 after.
Qed.
Definition step11_after_step9_condition (before: instantation)
  (H: property prop9 before):
  let after := run_algorithm before (step10_11 :: nil) in
  property prop11 after.
Proof.
  T1 after.
Qed.
Definition step13_after_step11_condition (before: instantation)
  (H: property prop11 before):
  let after := run_algorithm before (step12_13 :: nil) in
  property prop13 after.
Proof.
  T1 after.
Qed.
Definition step16_after_step13_condition (before: instantation)
  (H: property prop13 before):
  let after := run_algorithm before (step14_15_16 :: nil) in
  property prop16 after.
Proof.
  T1 after.
Qed.

Lemma Permutation_Add_cons A :
  forall (a : A) l1 l2 l2', Add a l2 l2' -> Permutation l1 l2 -> Permutation (a :: l1) l2'.
Proof.
  intros a l1 l2 l2' Hadd HP.
  now etransitivity; [ apply Permutation_cons | apply Permutation_Add, Hadd ].
Qed.

Ltac permutation_solve :=
  intros; now repeat (eapply Permutation_Add_cons; [ repeat econstructor | ]).

Ltac T2 after list_of_values := intros; unfold after, list_of_values; simpl; repeat destruct Compare_dec.gt_dec;
                                repeat (destruct variable_eq_dec; try congruence); permutation_solve.

Definition step1_permutation (before: instantation):
  let after := run_algorithm before (step1 :: nil) in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  T2 after list_of_values.
Qed.
Definition step2_permutation (before: instantation):
  let after := run_algorithm before (step2 :: nil) in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  T2 after list_of_values.
Qed.
Definition step3_permutation (before: instantation):
  let after := run_algorithm before (step3 :: nil) in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  T2 after list_of_values.
Qed.
Definition step4_permutation (before: instantation):
  let after := run_algorithm before (step4 :: nil) in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  T2 after list_of_values.
Qed.
Definition step5_permutation (before: instantation):
  let after := run_algorithm before (step5 :: nil) in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  T2 after list_of_values.
Qed.
Definition step6_permutation (before: instantation):
  let after := run_algorithm before (step6 :: nil) in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  T2 after list_of_values.
Qed.
Definition step7_permutation (before: instantation):
  let after := run_algorithm before (step7 :: nil) in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  T2 after list_of_values.
Qed.
Definition step9_permutation (before: instantation):
  let after := run_algorithm before (step8_9 :: nil) in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  T2 after list_of_values.
Qed.
Definition step11_permutation (before: instantation):
  let after := run_algorithm before (step10_11 :: nil) in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  T2 after list_of_values.
Qed.
Definition step13_permutation (before: instantation):
  let after := run_algorithm before (step12_13 :: nil) in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  T2 after list_of_values.
Qed.
Definition step16_permutation (before: instantation):
  let after := run_algorithm before (step14_15_16 :: nil) in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  T2 after list_of_values.
Qed.

Theorem algorithm_cons (s: step) (a: algorithm) (before: instantation):
  run_algorithm before (s :: a) = run_algorithm (run_algorithm before a) (s :: nil).
Proof.
  simpl. reflexivity.
Qed.

Theorem algorithm_permutation (before: instantation):
  let after := run_algorithm before sort8 in
  Permutation (list_of_values before) (list_of_values after).
Proof.
  unfold sort8.
  assert (Permutation
    (list_of_values (run_algorithm before (step12_13 :: step10_11 :: step8_9 :: step7 :: step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil)))
    (list_of_values (run_algorithm before (step14_15_16 :: step12_13 :: step10_11 :: step8_9 :: step7 :: step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil)))).
  { rewrite (algorithm_cons step14_15_16). apply step16_permutation. }
  assert (Permutation
    (list_of_values (run_algorithm before (step10_11 :: step8_9 :: step7 :: step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil)))
    (list_of_values (run_algorithm before (step12_13 :: step10_11 :: step8_9 :: step7 :: step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil)))).
  { rewrite (algorithm_cons step12_13). apply step13_permutation. }
  assert (Permutation
    (list_of_values (run_algorithm before (step8_9 :: step7 :: step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil)))
    (list_of_values (run_algorithm before (step10_11 :: step8_9 :: step7 :: step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil)))).
  { rewrite (algorithm_cons step10_11). apply step11_permutation. }
  assert (Permutation
    (list_of_values (run_algorithm before (step7 :: step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil)))
    (list_of_values (run_algorithm before (step8_9 :: step7 :: step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil)))).
  { rewrite (algorithm_cons step8_9). apply step9_permutation. }
  assert (Permutation
    (list_of_values (run_algorithm before (step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil)))
    (list_of_values (run_algorithm before (step7 :: step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil)))).
  { rewrite (algorithm_cons step7). apply step7_permutation. }
  assert (Permutation
    (list_of_values (run_algorithm before (step5 :: step4 :: step3 :: step2 :: step1 :: nil)))
    (list_of_values (run_algorithm before (step6 :: step5 :: step4 :: step3 :: step2 :: step1 :: nil)))).
  { rewrite (algorithm_cons step6). apply step6_permutation. }
  assert (Permutation
    (list_of_values (run_algorithm before (step4 :: step3 :: step2 :: step1 :: nil)))
    (list_of_values (run_algorithm before (step5 :: step4 :: step3 :: step2 :: step1 :: nil)))).
  { rewrite (algorithm_cons step5). apply step5_permutation. }
  assert (Permutation
    (list_of_values (run_algorithm before (step3 :: step2 :: step1 :: nil)))
    (list_of_values (run_algorithm before (step4 :: step3 :: step2 :: step1 :: nil)))).
  { rewrite (algorithm_cons step4). apply step4_permutation. }
  assert (Permutation
    (list_of_values (run_algorithm before (step2 :: step1 :: nil)))
    (list_of_values (run_algorithm before (step3 :: step2 :: step1 :: nil)))).
  { rewrite (algorithm_cons step3). apply step3_permutation. }
  assert (Permutation
    (list_of_values (run_algorithm before (step1 :: nil)))
    (list_of_values (run_algorithm before (step2 :: step1 :: nil)))).
  { rewrite (algorithm_cons step2). apply step2_permutation. }
  assert (Permutation
    (list_of_values before)
    (list_of_values (run_algorithm before (step1 :: nil)))).
  { apply step1_permutation. }
  repeat (eapply perm_trans; eauto).
Qed.

Definition equivalent (i1 i2: instantation) :=
  forall x y, i1 x <= i1 y <-> i2 x <= i2 y.

Fixpoint distinct (L: list instantation) :=
  match L with
  | x :: (y :: t) as t0 => ~ equivalent x y /\ distinct t0
  | _ => True
  end.

Fixpoint factorial n :=
  match n with
  | O => 1
  | S m => S m * factorial m
  end.

Theorem run_algorithm_nil (i: instantation) : forall x, run_algorithm i nil x = i x.
Proof.
  intros. simpl. auto.
Qed.

Theorem run_step_cons (i: instantation) (a: assignment) (L: list assignment):
  run_step i (assignments (a :: L)) = run_assignment (run_step i (assignments L)) a.
Proof.
  simpl. auto.
Qed.

Theorem equivalent_after_assignment (i1 i2: instantation) (H: equivalent i1 i2) (a: assignment):
  equivalent (run_assignment i1 a) (run_assignment i2 a).
Proof.
  unfold equivalent in *. intros. destruct a.
  destruct v, v0; simpl; repeat (destruct variable_eq_dec); apply H.
Qed.

Theorem equivalent_after_step (i1 i2: instantation) (H: equivalent i1 i2) (s: step):
  equivalent (run_step i1 s) (run_step i2 s).
Proof.
  induction s.
  + induction L.
    - simpl. auto.
    - intros. repeat rewrite run_step_cons. apply equivalent_after_assignment; auto.
  + intros. simpl. destruct c. unfold equivalent in *. intros. repeat (destruct Compare_dec.gt_dec); eauto.
    - pose (H (num more) (num less)). lia.
    - pose (H (num more) (num less)). lia.
Qed.

Theorem equivalent_after_algorithm (i1 i2: instantation) (H: equivalent i1 i2) (a: algorithm):
  equivalent (run_algorithm i1 a) (run_algorithm i2 a).
Proof.
  unfold equivalent in *.
  + induction a; intros; simpl in *.
    - apply H.
    - apply equivalent_after_step; eauto.
Qed.

(* ?? Something about distinct instantations being factorial 8 ?? *)
Theorem max_number_of_distinct_instantations (L: list instantation):
  distinct L -> length L <= factorial 8.
Proof.
Admitted.

(* Extraction to graphviz as flowchart *)
Require Import String.
Open Scope string.

Definition value_to_string (n: value): string :=
  match n with
  | x0 => "x0"
  | x1 => "x1"
  | x2 => "x2"
  | x3 => "x3"
  | x4 => "x4"
  | x5 => "x5"
  | x6 => "x6"
  | x7 => "x7"
  end.
Definition variable_to_string (v: variable): string :=
  match v with
  | aux => "t"
  | num x => value_to_string x
  end.
Definition comparison_to_string (c: comparison) :=
  match c with
  | GT x y => "[label=""" ++ value_to_string x ++ " > " ++ value_to_string y ++ """, shape=""diamond""]; " end.
Definition assignment_to_string (a: assignment) :=
  match a with assign x y => variable_to_string x ++ "=" ++ variable_to_string y end.
Fixpoint assignment_list_to_string_aux (L: list assignment): string :=
  match L with
  | nil => ""
  | x :: nil => assignment_to_string x
  | x :: t => assignment_to_string x ++ "; " ++ assignment_list_to_string_aux t
  end.
Definition assignment_list_to_string L := "[label=""" ++ assignment_list_to_string_aux (rev L) ++ """];".

Eval compute in assignment_list_to_string (swap x0 x1).
Eval compute in comparison_to_string (GT x0 x1).

Definition count_assignment_blocks_in_step (s: step): nat.
Proof.
  induction s.
  + exact 1.
  + exact (IHs1 + IHs2).
Defined.
Eval compute in count_assignment_blocks_in_step step14_15_16.

Definition count_comparison_blocks_in_step (s: step): nat.
Proof.
  induction s.
  + exact 0.
  + exact (1 + IHs1 + IHs2).
Defined.
Eval compute in count_comparison_blocks_in_step step14_15_16.

(* http://poleiro.info/posts/2013-03-31-reading-and-writing-numbers-in-coq.html *)
Definition natToDigit (n : nat) :=
  match n with
    | 0 => "0"
    | 1 => "1"
    | 2 => "2"
    | 3 => "3"
    | 4 => "4"
    | 5 => "5"
    | 6 => "6"
    | 7 => "7"
    | 8 => "8"
    | _ => "9"
  end.
Fixpoint writeNatAux (time n : nat) (acc : string) : string :=
  let acc' := (natToDigit (Nat.modulo n 10)) ++ acc in
  match time with
    | 0 => acc'
    | S time' =>
      match Nat.div n 10 with
        | 0 => acc'
        | n' => writeNatAux time' n' acc'
      end
  end.
Definition writeNat (n : nat) : string :=
  writeNatAux n n "".


(*******************************************)
(*******************************************)
(****                                   ****)
(****   Names with decidable equality   ****)
(****                                   ****)
(*******************************************)
(*******************************************)

Require Import Coq.Arith.Peano_dec.
Require Import Coq.Lists.List.
Require Import Main.Tactics.

Module Type NameSig.

  Parameter name : Type.

  Axiom nameEq : forall x1 x2 : name, { x1 = x2 } + { x1 <> x2 }.

  Axiom nameFresh : forall l : list name, exists x, ~ In x l.

End NameSig.

Module Name : NameSig.

  Definition name := nat.

  Theorem nameEq : forall x1 x2 : nat, { x1 = x2 } + { x1 <> x2 }.
  Proof.
    induction x1; search.
  Qed.

  #[export] Hint Resolve nameEq : main.

  Theorem nameFresh : forall l : list nat, exists x, ~ In x l.
  Proof.
    clean. exists (S (fold_right max 0 l)). unfold not. clean.
    assert (forall n, In n l -> n < S (fold_right Nat.max 0 l)).
    - clear H. clean. induction l; search.
      assert ((fold_right max 0 l) < S (max a (fold_right max 0 l))); search.
      destruct H; search.
    - specialize (H0 (S (fold_right Nat.max 0 l))). search.
  Qed.

  #[export] Hint Resolve nameFresh : main.

End Name.

Export Name.

(************************************)
(* Miscellaneous facts about names. *)
(************************************)

Theorem nameInRemove :
  forall l x1 x2,
  In x1 (remove nameEq x2 l) ->
  In x1 l /\ x1 <> x2.
Proof.
  clean. induction l; search.
Qed.

#[export] Hint Resolve nameInRemove : main.