Require Export Unicode.Utf8_core.
Require Export Coq.Program.Program.
Require Import Relations RelationClasses Setoid.

Implicit Arguments projT1 [[A] [P]].
Implicit Arguments projT2 [[A] [P]].
Implicit Arguments existT [[A] [P]].

Definition prodT (A B : Type) := @sigT A (fun _ => B).
Definition pairT {A B : Type} : A -> B -> prodT A B := @existT A (fun _ => B).

Inductive prop_eq (P : Prop) (p : P) : P -> Prop :=
  prop_eq_refl : prop_eq P p p.

Implicit Arguments pairT [[A] [B]].

Definition conv_annot {T U : Type} (M : U) : U := M.
Definition app_annot {T} {U : T -> Type} {N : T} (V : U N) : U N := V.

Lemma equal_existT {A} {P : A -> Type} {p : A} {x y : P p} : x = y -> (existT p x = existT p y).
Proof. now intros ->. Defined.

Implicit Arguments exist [[A] [P]].

Lemma equal_exist {A} {P : A -> Prop} {p : A} {x y : P p} : exist p x = exist p y.
Proof. now intros. Defined.

Lemma exist_eq {A : Type} {P : A -> Prop} (x y : A) (p : P x) (q : P y) :
  x = y -> exist x p = exist y q.
Proof. intros; subst; reflexivity. Qed.

Lemma equal_f {A B : Type} {f g : A -> B} : f = g -> forall x : A, f x = g x.
Proof. now intros ->. Qed.

Lemma equal_dep_f {A} {B : A -> Type} {f g : ∀ x : A, B x} : f = g -> forall x : A, f x = g x.
Proof. now intros ->. Qed.

(* To control backtracking during proof search *)
Class Tried (P : Prop).

Ltac not_tried p :=
  match goal with
    | [ H : Tried ?Q |- _ ] =>
      match Q with
        p => fail 2
      end
    | _ => idtac
  end.

Notation " '{Σ' x , y } " := (exist x y).
Notation " '(Σ' x , y ) " := (existT x y).

(** Basic definitions for forcing *)

(** Forcing conditions come with a preorder *)

Module Type Condition.
  Parameter P : Type.
  Parameter le : relation P.
  Declare Instance le_pre : PreOrder le.

  Delimit Scope forcing_scope with forcing.
  Notation " x <= y " := (le x y) : forcing_scope.

End Condition.

Inductive prop_or_type := is_prop | is_type.

Class ForcingOp {A : Type} (a : A) (p : prop_or_type) := {
  forcing_traduction_type : Type;
  forcing_traduction : forcing_traduction_type
}.

Implicit Arguments forcing_traduction [[A] [ForcingOp]].

Class ForcingLemma {P : Prop} (p : P) := {
  forcing_traduction_prop : Prop;
  forcing_traduction_proof : forcing_traduction_prop
}.

Require Import Le.
Module NatCondition <: Condition.
  Definition P := nat.

  Definition le := Peano.le.

  Instance le_pre : PreOrder le.
  Proof. split; red; intros. apply le_n. eapply le_trans; eauto. Qed.

  Delimit Scope forcing_scope with forcing.
  Notation " x <= y " := (le x y) : forcing_scope.

End NatCondition.

Module Forcing(F : Condition).
  Import F.

  Local Open Scope forcing_scope.

  Definition Psub (p : P) := fun q : P => q <= p.

  Definition subp (p : P) := sig (Psub p).

  Definition subp_proj {p : P} (q : subp p) : P := ` q.
  Global Coercion subp_proj : subp >-> P.

  Definition ssubp {p} (q : subp p) := subp (subp_proj q).

  (** [subp] also forms valid forcing conditions *)

  Program Definition subp_intro {p : P} (q : P) (prf : q <= p) : subp p := q.

  Lemma subp_proof {p} (q : subp p) : (subp_proj q) <= p.
  Proof. apply (proj2_sig q). Defined.
  Hint Resolve subp_proof : forcing.

  Program Definition embed (p : P) : subp p := p.
  Next Obligation. red; reflexivity. Qed.

  (** We define an overloaded [ι] operator to infer canonical
     coercions of conditions into larger subsets. *)

  Class Iota p (x : subp p) q := { iota : subp q ;
    iota_identity : @eq P x iota
  }.

  Global Implicit Arguments iota [[p] [q] [Iota]].

  Notation ι r := (iota r).

  (*Hint Extern 4 => progress (unfold le in * ) : forcing.*)

  Lemma subp_proof2 p (q : subp p) : ` q <= p.
  Proof. apply subp_proof. Defined.
  Hint Resolve subp_proof2 : forcing.

  Ltac forcing_le :=
    match goal with
      | |- le (@proj1_sig _ _ ?y) ?x =>
          apply (proj2_sig y)
      | |- ` ?x <= ?y =>
          match type of x with
              subp ?r => transitivity r
          end
      | |- le (@subp_proj ?x ?y) ?x =>
          apply (proj2_sig y)
      | |- subp_proj ?x <= ?y =>
          match type of x with
              subp ?r => transitivity r
          end
    end.

  Hint Extern 2 (_ <= _) => forcing_le : forcing.
  Hint Extern 0 (_ <= _) => apply reflexivity : forcing.
  Hint Extern 0 (_ = _) => try f_equal ; reflexivity : forcing.

  Ltac forcing :=
    try solve [simpl; unfold Psub in *; auto with arith forcing].
  Obligation Tactic := program_simpl; forcing.

  (** The identity, in case no coercion was needed in fact *)
  Global Program Instance iota_reflexive p (q : subp p) : Iota p q p := { iota := (q : P) }.

  (** Self-indexing [q : P p] then [q : P q] *)
  Global Program Instance iota_lift p (q : subp p) : Iota p q q := { iota := (q : P) }.

  (** [q : P p] so forall [r : P q] [r : P p] as well *)
  Global Program Instance iota_pi {p} (q : subp p) : Iota q (iota q) p :=
    { iota := (q : P) }.

  (** [q : P p] so forall [r : P q] [r : P p] as well *)
  Global Program Instance iota_pi_inv {p} (q : subp p) (r : subp q) : Iota q r p :=
    { iota := (r : P) }.

  (** Iotas compose *)
  Program Definition iota_compose {p sp q r} (pq : Iota p sp q) (qr : Iota q (iota sp) r) : Iota p sp r :=
    {| iota := iota (iota sp) |}.

  Next Obligation. now repeat rewrite <- iota_identity. Defined.

  (**  In case [iota] does not change the type, it's the identity *)
  Lemma iota_iota_refl {p} (q : subp p) : iota (iota q) = q.
  Proof. now destruct q. Qed.

  Lemma iota_irrel {p} (q : subp p) {r} (X Y : Iota p q r) : iota (Iota:=X) q = iota (Iota:=Y) q.
  Proof. destruct X, Y. unfold iota; simpl. destruct iota0, iota1. simpl in *. subst. reflexivity. Qed.

  CoInductive iota_trans : P -> P -> Prop := .

  (** [iota_compose] is always applicable, restrict it to cases where both [p] and [r]
     are ground and check for loops. *)
  Ltac apply_iota_compose p sp q :=
    progress (is_evar p || is_evar q ||
                      (try (not_tried (iota_trans p q) ;
                            let foo := fresh "tried" in
                              set(foo:=Build_Tried (iota_trans p q)) ;
                            eapply iota_compose))).

  Hint Extern 3 (Iota ?p ?sp ?q) => apply_iota_compose p sp q : typeclass_instances.

  Ltac test_iota_compose :=
    match goal with
      |- Iota ?p ?sp ?q => apply_iota_compose p sp q
    end.

  Goal forall p sp q r (iop : Iota p sp q), Iota q (iota sp) r -> Iota p sp r.
  Proof. intros. typeclasses eauto. Qed.

  Goal forall p sp q r, Iota p sp q -> Iota p sp r.
  Proof. intros.
    Fail typeclasses eauto. admit. Qed.

  Example one_trans p (q : subp p) (r : subp q) (s : subp r) : subp q.
  Proof. exact (iota s). Defined.

  Example two_trans p (q : subp p) (r : subp q) (s : subp r) (t : subp s) : subp q.
  Proof. exact (iota t). Defined.

  Example three_trans p (q : subp p) (r : subp q) (s : subp r) (t : subp s) (u : subp t) : subp q.
  Proof. exact (iota u). Defined.

    (* Maybe use those instances more? *)
  Global Instance one_trans_inst p (q : subp p) (r : subp q) (s : subp r) : Iota _ s q := { iota := iota s }.
  Proof. reflexivity. Defined.

  Global Instance two_trans_inst p (q : subp p) (r : subp q) (s : subp r) (t : subp s) : Iota _ t q := { iota := iota t }.
  Proof. reflexivity. Defined.

  Global Instance three_trans_inst p (q : subp p) (r : subp q) (s : subp r) (t : subp s) (u : subp t) : Iota _ u q := {iota := iota u}.
  Proof. reflexivity. Defined.

  Example four_trans p (q : subp p) (r : subp q) (s : subp r) (t : subp s) (u : subp t) (v : subp u)
  : subp q.
  Proof. exact (iota v). Defined.

  Section Translation.

    Definition transport {p} (f : subp p → Type) :=
      forall q : subp p, forall r : subp q, arrow (f q) (f (iota r)).

    Section Sheaf.
      Context {p} {f : subp p -> Type}.

      Definition refl (Θ : transport f) := Eval simpl in
        forall q : subp p, forall x : f q,
          Θ q (iota q) x = x.

      Definition trans (Θ : transport f) := Eval simpl in
        forall q : subp p, forall r : subp q, forall s : subp r,
          forall x, ((Θ (iota r) s) ∘ (Θ q r)) x = Θ q (iota s) x.

      Definition trans_prop (Θ : transport f) :=
        refl Θ /\ trans Θ.

    End Sheaf.

    Definition sheaf (p : P) :=
      { sheaf_f : subp p -> Type & sig (@trans_prop p sheaf_f) }.

    Definition sheaf_f {p : P} (s : sheaf p) : subp p -> Type :=
      projT1 s.

    Program Definition Θ {p : P} (s : sheaf p) : transport (sheaf_f s) :=
      projT2 s.

    Definition sheaf_refl {p} (s : sheaf p) : refl (Θ s).
    Proof. unfold Θ. destruct s. destruct s. destruct t. simpl. assumption. Defined.

    Definition sheaf_trans {p} (s : sheaf p) : trans (Θ s).
    Proof. unfold Θ. destruct s. destruct s. destruct t. simpl. assumption. Defined.

    Program Definition sheafC (p : P) (q : subp p) (r : subp q)
      (f : sheaf q) : sheaf r :=
        existT (fun s => sheaf_f f (iota s))
        (λ s : subp r, λ t : subp s, λ x : sheaf_f f (iota s),
          (Θ f (iota s) t x)).

    Notation " '{Σ'  x } " := (exist x _).

    Next Obligation. split; red. intros.
      simpl.
      destruct q0. simpl.
      destruct f. simpl in *.
      destruct s as [θ [Hr Ht]].
      red in Hr. pose (Hr _ x). simpl in *.
      rewrite <- e at 2. unfold Θ. simpl. reflexivity.

      (* Trans *)
      pose proof (sheaf_trans f).
      intros. unfold compose. destruct f; simpl in *.
      destruct s0 as [θ [Hr Ht]].
      red in Ht. pose (Ht (iota q0) r0 s x). unfold compose in *. simpl in *.
      unfold Θ. simpl in *. rewrite <- e. destruct r0; reflexivity.
    Qed.

    Lemma sheafC_trans (p : P) : trans_prop (sheafC p).
    Proof.
      red. split; red; intros.
      (* BUG with reflexivity only: eta for records probably *)
      destruct x as [sh [tr Htr]]; simpl. unfold sheafC. simpl.
      unfold Θ. simpl. reflexivity.
      destruct x as [sh [tr Htr]]; simpl. unfold compose, sheafC. simpl. apply f_equal.
      unfold Θ. simpl. reflexivity.
    Qed.

    Program Definition sheafC_sheaf (p : P) :
              { sheaf_f : subp p -> Type & sig (@trans_prop p sheaf_f) } :=
              existT sheaf (exist (sheafC p) (sheafC_trans p)).

  End Translation.

  Section TranslationProp.

    Definition prop_transport {p} (f : subp p → Prop) :=
      forall q : subp p, forall r : subp q, f q -> f (iota r).

    Definition prop_sheaf (p : P) :=
      { sheaf_f : subp p -> Prop | prop_transport sheaf_f }.

    Definition prop_sheaf_f {p : P} (s : prop_sheaf p) : subp p -> Prop :=
      proj1_sig s.

    Program Definition prop_Θ {p : P} (s : prop_sheaf p) : prop_transport (prop_sheaf_f s) :=
      proj2_sig s.

    Program Definition prop_sheafC (p : P) (q : subp p) (r : subp q)
      (f : prop_sheaf q) : prop_sheaf r :=
        exist (fun s => prop_sheaf_f f (iota s)) _.

    Next Obligation. red. intros.
      destruct f.
      simpl in *.
      specialize (p0 _ (iota r0) H). apply p0.
    Qed.

    Program Definition prop_sheafC_sheaf (p : P) :
              { sheaf_f : subp p -> Type & sig (@trans_prop p sheaf_f) } :=
              existT prop_sheaf (prop_sheafC p).
    Next Obligation.
      red. split; red; intros.
      destruct x as [sh tr]; simpl. unfold prop_sheafC. simpl. reflexivity.
      destruct x as [sh tr]; simpl. unfold compose, prop_sheafC. simpl.
      reflexivity.
    Qed.

  End TranslationProp.

End Forcing.

Module NatForcing := Forcing(NatCondition).

Declare ML Module "forcing_plugin".


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Div2.

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive term  :=
  | S : term
  | K : term
  | App : term -> term -> term .
Axiom term_WhyType : WhyType term.
Existing Instance term_WhyType.

(* Why3 assumption *)
Fixpoint is_value(t:term) {struct t}: Prop :=
  match t with
  | (K|S) => True
  | ((App K v)|(App S v)) => (is_value v)
  | (App (App S v1) v2) => (is_value v1) /\ (is_value v2)
  | _ => False
  end.

(* Why3 assumption *)
Inductive context  :=
  | Hole : context
  | Left : context -> term -> context
  | Right : term -> context -> context .
Axiom context_WhyType : WhyType context.
Existing Instance context_WhyType.

(* Why3 assumption *)
Fixpoint is_context(c:context) {struct c}: Prop :=
  match c with
  | Hole => True
  | (Left c1 _) => (is_context c1)
  | (Right v c1) => (is_value v) /\ (is_context c1)
  end.

(* Why3 assumption *)
Fixpoint subst(c:context) (t:term) {struct c}: term :=
  match c with
  | Hole => t
  | (Left c1 t2) => (App (subst c1 t) t2)
  | (Right v1 c2) => (App v1 (subst c2 t))
  end.

(* Why3 assumption *)
Inductive infix_mnmngt : term -> term -> Prop :=
  | red_K : forall (c:context), (is_context c) -> forall (v1:term) (v2:term),
      (is_value v1) -> ((is_value v2) -> (infix_mnmngt (subst c (App (App K
      v1) v2)) (subst c v1)))
  | red_S : forall (c:context), (is_context c) -> forall (v1:term) (v2:term)
      (v3:term), (is_value v1) -> ((is_value v2) -> ((is_value v3) ->
      (infix_mnmngt (subst c (App (App (App S v1) v2) v3)) (subst c
      (App (App v1 v3) (App v2 v3)))))).

Axiom red_left : forall (t1:term) (t2:term) (t:term), (infix_mnmngt t1 t2) ->
  (infix_mnmngt (App t1 t) (App t2 t)).

Axiom red_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((infix_mnmngt t1 t2) -> (infix_mnmngt (App v t1) (App v t2))).

(* Why3 assumption *)
Inductive relTR : term -> term -> Prop :=
  | BaseTransRefl : forall (x:term), (relTR x x)
  | StepTransRefl : forall (x:term) (y:term) (z:term), (relTR x y) ->
      ((infix_mnmngt y z) -> (relTR x z)).

Axiom relTR_transitive : forall (x:term) (y:term) (z:term), (relTR x y) ->
  ((relTR y z) -> (relTR x z)).

Axiom red_star_left : forall (t1:term) (t2:term) (t:term), (relTR t1 t2) ->
  (relTR (App t1 t) (App t2 t)).

Axiom red_star_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((relTR t1 t2) -> (relTR (App v t1) (App v t2))).

Axiom reducible_or_value : forall (t:term), (exists t':term, (infix_mnmngt t
  t')) \/ (is_value t).

(* Why3 assumption *)
Definition irreducible(t:term): Prop := forall (t':term), ~ (infix_mnmngt t
  t').

Axiom irreducible_is_value : forall (t:term), (irreducible t) <->
  (is_value t).

(* Why3 assumption *)
Inductive only_K : term -> Prop :=
  | only_K_K : (only_K K)
  | only_K_App : forall (t1:term) (t2:term), (only_K t1) -> ((only_K t2) ->
      (only_K (App t1 t2))).

Axiom only_K_reduces : forall (t:term), (only_K t) -> exists v:term, (relTR t
  v) /\ ((is_value v) /\ (only_K v)).

(* Why3 assumption *)
Fixpoint size(t:term) {struct t}: Z :=
  match t with
  | (K|S) => 0%Z
  | (App t1 t2) => ((1%Z + (size t1))%Z + (size t2))%Z
  end.

Axiom size_nonneg : forall (t:term), (0%Z <= (size t))%Z.

Parameter ks: Z -> term.

Axiom ksO : ((ks 0%Z) = K).

Axiom ksS : forall (n:Z), (0%Z <= n)%Z -> ((ks (n + 1%Z)%Z) = (App (ks n)
  K)).

Axiom ks1 : ((ks 1%Z) = (App K K)).

Axiom only_K_ks : forall (n:Z), (0%Z <= n)%Z -> (only_K (ks n)).

Axiom ks_inversion : forall (n:Z), (0%Z <= n)%Z -> ((n = 0%Z) \/
  ((0%Z < n)%Z /\ ((ks n) = (App (ks (n - 1%Z)%Z) K)))).

Axiom ks_injective : forall (n1:Z) (n2:Z), (0%Z <= n1)%Z -> ((0%Z <= n2)%Z ->
  (((ks n1) = (ks n2)) -> (n1 = n2))).

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 10.

(* Why3 goal *)
Theorem WP_parameter_reduction3 : forall (t:term), (exists n:Z,
  (0%Z <= n)%Z /\ (t = (ks n))) ->
  match t with
  | S => True
  | K => True
  | (App t1 t2) => (exists n:Z, (0%Z <= n)%Z /\ (t1 = (ks n))) ->
      forall (result:term), ((is_value result) /\ forall (n:Z),
      (0%Z <= n)%Z -> (((t1 = (ks (2%Z * n)%Z)) -> (result = K)) /\
      ((t1 = (ks ((2%Z * n)%Z + 1%Z)%Z)) -> (result = (App K K))))) ->
      match result with
      | K => True
      | S => True
      | (App K v1) => True
      | (App S v1) => True
      | (App (App S v1) v2) => (exists n:Z, (0%Z <= n)%Z /\ (t2 = (ks n))) ->
          forall (v3:term), ((is_value v3) /\ forall (n:Z), (0%Z <= n)%Z ->
          (((t2 = (ks (2%Z * n)%Z)) -> (v3 = K)) /\
          ((t2 = (ks ((2%Z * n)%Z + 1%Z)%Z)) -> (v3 = (App K K))))) ->
          exists n:Z, (0%Z <= n)%Z /\ ((App (App v1 v3) (App v2
          v3)) = (ks n))
      | _ => True
      end
  end.
intros t (n, (h1, h2)).
destruct t; auto.
intros (n1, (h3, h4)).
destruct result; auto.
intros (_, ht1).
destruct result1; auto.
elimtype False.
destruct (Div2.div2 n1).
ae.
Qed.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2019                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

(* [Require Import SMTCoq.SMTCoq.] loads the SMTCoq library.
   If you are using native-coq instead of Coq 8.11, replace it with:
     Require Import SMTCoq.
   *)

Require Import SMTCoq.SMTCoq.
Require Import Bool.

Require Import ZArith.

Import BVList.BITVECTOR_LIST.
Local Open Scope bv_scope.

Import FArray.
Local Open Scope farray_scope.

(* Examples that check ZChaff certificates *)

Local Open Scope int63_scope.

Zchaff_Checker "sat.cnf" "sat.log".
Zchaff_Theorem sat "sat.cnf" "sat.log".
Check sat.

Zchaff_Checker "hole4.cnf" "hole4.log".

(* Example that checks a VeriT certificate, for logic QF_UFLIA *)

Section Verit.
  Verit_Checker "lia.smt2" "lia.vtlog".
End Verit.

(* Example that checks a LFSC certificate, for logic QF_UFLIA *)

Section Lfsc.
  Lfsc_Checker "lia.smt2" "lia.lfsc".
End Lfsc.

(********************** Examples for Comp Reports **********************)
Theorem orIntroL : forall (a b: Prop), a -> a \/ b.
Proof.
  intros a b Ha.
  left. apply Ha.
Qed.

Theorem LEMProp : forall (a : Prop), a \/ ~a.
Proof.
  intros a.
Abort.

Theorem LEMBool : forall a : bool, a || (negb a) = true.
Proof.
  intros a. destruct a.
  + simpl. reflexivity.
  + simpl. reflexivity.
Qed.

Theorem LEMBool' : forall a : bool, a || (negb a) = true.
Proof.
  smt.
Qed.

Theorem Z_congBool : forall (a b : Z) (f : Z -> Z), (Z.eqb a b) = true ->
  (Z.eqb (f a) (f b) = true).
Proof.
  intros.
  smt.
Qed.

Theorem Z_congBool : forall (a b : Z) (f : Z -> Z), (Z.eqb a b) = true ->
  (Z.eqb (f a) (f b) = true).
Proof.
  intros.
  smt.
Qed.

Theorem Z_congProp : forall (a b : Z) (f : Z -> Z), a = b -> f a = f b.
Proof.
  smt.
Qed.

Theorem BV_ulteZeroBool : forall (b : bitvector 4),
	bv_ult #b|0|0|0|0| b = true \/ bv_eq b #b|0|0|0|0| = true.
Proof.
  smt.
Qed.

Theorem BV_ulteZeroProp : forall (b : bitvector 4),
	bv_ultP #b|0|0|0|0| b \/ b = #b|0|0|0|0|.
Proof.
  smt.
Qed.

Theorem LEM_Z : forall (i : Z), i = 0%Z \/ ~(i = 0%Z).
Proof.
  smt.
Qed.

Theorem LEMBV : forall (b : bitvector 4),
  b = #b|0|0|0|0| \/ ~(b = #b|0|0|0|0|).
Proof.
  smt.
Qed.
(*************************************************************************)

(* CVC4 doesn't have a shl bit-blasting rule *)
Theorem BV_shl : forall (b : bitvector 4),
  bv_shl b #b|0|0|0|0| = b.
Proof.
  smt.
Abort.

(**************** Passing recursive functions to SMT solver ****************)

Definition f' (x : Z) : Prop := True.
Fixpoint evenP (x : nat) : Prop :=
  match x with
  | O => True
  | S n => evenP (n-1)
  end.

Definition f (x : Z) : Z := 1.
Theorem Z_congBool' : forall (a b : Z), (Z.eqb a b) = true ->
  (Z.eqb (f a) (f b) = false).
Proof.
  (*smt.*)
Abort.

Inductive ev : nat -> Prop :=
| ev_0 : ev 0
| ev_SS (n : nat) (H : ev n) : ev (S (S n)).

Theorem testPropFun : forall (a b : Z) (f : Z -> Prop), (Z.eqb a b) = true ->
  f a.
Proof.
  (*smt.*)
Abort.

(***************************** Example from Report *****************************)
Theorem F : forall (a b c : bool), (b && negb c) || (a && negb b) || negb a || c.
Proof.
  smt.
Qed.

(***********************************************************************)

Goal forall a b c,
  (a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a) = false.
Proof.
  zchaff.
Qed.

Goal forall (i j k : Z),
    let a := Z.eqb i j in
    let b := Z.eqb j k in
    let c := Z.eqb k i in
  (a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a) = false.
Proof.
  zchaff.
Qed.

(* Examples of the verit tactics (requires verit in your PATH environment
   variable), which handle
   - propositional logic
   - theory of equality
   - linear integer arithmetic
   - universally quantified hypotheses *)

Goal forall a b c, ((a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a)) = false.
Proof.
  verit_bool.
Qed.

Local Open Scope Z_scope.

Goal forall (a b : Z) (P : Z -> bool) (f : Z -> Z),
  (negb (Z.eqb (f a) b)) || (negb (P (f a))) || (P b).
Proof.
  verit_bool.
Qed.

Goal forall b1 b2 x1 x2,
    implb
      (ifb b1
           (ifb b2 (Z.eqb (2*x1+1) (2*x2+1)) (Z.eqb (2*x1+1) (2*x2)))
           (ifb b2 (Z.eqb (2*x1) (2*x2+1)) (Z.eqb (2*x1) (2*x2))))
      ((implb b1 b2) && (implb b2 b1) && (Z.eqb x1 x2)).
Proof.
  verit_bool.
Qed.

Goal forall
    (x y: Z)
    (f: Z -> Z),
    x = y + 1 -> f y = f (x - 1).
Proof.
  verit.
Qed.

Check (1 =? 2).

(*Some examples of using verit with lemmas. Use <verit H1 .. Hn>
  to temporarily add the lemmas H1 .. Hn to the verit environment. *)

Lemma const_fun_is_eq_val_0 :
  forall f : Z -> Z,
    (forall a b, f a =? f b = true) ->
    forall x, f x =? f 0 = true.
Proof.
  intros f Hf.
  verit Hf.
Qed.

Section With_lemmas.
  Variable f : Z -> Z.
  Variable k : Z.
  Hypothesis f_k_linear : forall x, f (x + 1) =? f x + k.

  Lemma fSS2:
    forall x, f (x + 2) =? f x + 2 * k.
  Proof. verit_no_check f_k_linear. Qed.
End With_lemmas.

(* Instantiating a lemma with multiple quantifiers *)
Section NonLinear.
  Lemma distr_right_inst a b (mult : Z -> Z -> Z) :
    (forall x y z, mult (x + y)  z =? mult x z + mult y z) ->
    (mult (3 + a) b =? mult 3 b + mult a b).
  Proof.
    intro H.
    verit H.
  Qed.
End NonLinear.

(* You can use <Add_lemmas H1 .. Hn> to permanently add the lemmas H1 .. Hn to
   the environment. If you did so in a section then, at the end of the section,
   you should use <Clear_lemmas> to empty the globally added lemmas because
   those lemmas won't be available outside of the section. *)

Section mult3.
  Variable mult3 : Z -> Z.
  Hypothesis mult3_0 : mult3 0 =? 0.
  Hypothesis mult3_Sn : forall n, mult3 (n+1) =? mult3 n + 3.
  Add_lemmas mult3_0 mult3_Sn.

  Lemma mult_3_4_12 : mult3 4 =? 12.
  Proof. verit. Qed.

  Clear_lemmas.
End mult3.

(* Examples of the smt tactic (requires verit and cvc4 in your PATH environment
   variable):
   - propositional logic
   - theory of equality
   - linear integer arithmetic
   - theory of fixed-sized bit-vectors
   - theory of arrays *)

Goal forall a b c, ((a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a)) = false.
Proof.
  smt.
Qed.

Goal forall (a b : Z) (P : Z -> bool) (f : Z -> Z),
  (negb (Z.eqb (f a) b)) || (negb (P (f a))) || (P b).
Proof.
  smt.
Qed.
Goal forall b1 b2 x1 x2,
    implb
      (ifb b1
           (ifb b2 (Z.eqb (2*x1+1) (2*x2+1)) (Z.eqb (2*x1+1) (2*x2)))
           (ifb b2 (Z.eqb (2*x1) (2*x2+1)) (Z.eqb (2*x1) (2*x2))))
      ((implb b1 b2) && (implb b2 b1) && (Z.eqb x1 x2)).
Proof.
  smt.
Qed.

Goal forall
    (x y: Z)
    (f: Z -> Z),
    x = y + 1 -> f y = f (x - 1).
Proof.
  smt.
Qed.

Goal forall (bv1 bv2 bv3: bitvector 4),
    bv1 = #b|0|0|0|0|  /\
    bv2 = #b|1|0|0|0|  /\
    bv3 = #b|1|1|0|0|  ->
    bv_ultP bv1 bv2 /\ bv_ultP bv2 bv3.
Proof.
  smt.
Qed.

(* All tactics have a "no_check" variant that is faster but, in case of
  failure, it will only fail at Qed *)

Goal forall (bv1 bv2 bv3: bitvector 4),
    bv1 = #b|0|0|0|0|  /\
    bv2 = #b|1|0|0|0|  /\
    bv3 = #b|1|1|0|0|  ->
    bv_ultP bv1 bv2 /\ bv_ultP bv2 bv3.
Proof.
  smt_no_check.
Qed.

(* From cvc4_bool : Uncaught exception Not_found *)
(* Goal forall (a b c d: farray Z Z), *)
(*     b[0 <- 4] = c  -> *)
(*     d = b[0 <- 4][1 <- 4]  -> *)
(*     a = d[1 <- b[1]]  -> *)
(*     a = c. *)
(* Proof. *)
(*   smt. *)
(* Qed. *)

Goal forall (a b: farray Z Z) (v w x y z t: Z)
            (r s: bitvector 4)
            (f: Z -> Z)
            (g: farray Z Z -> Z)
            (h: bitvector 4 -> Z),
    a[x <- v] = b /\ a[y <- w] = b ->
    a[z <- w] = b /\ a[t <- v] = b ->
    r = s -> v < x + 10 /\ v > x - 5 ->
    ~ (g a = g b) \/ f (h r) = f (h s).
Proof.
  smt.
Qed.

(** SMTCoq also provides conversion tactics, to inject various integer
    types into the type Z supported by SMTCoq. They can be called before
    the standard SMTCoq tactics. **)

Local Open Scope positive_scope.

Goal forall (f : positive -> positive) (x y : positive),
  implb ((x + 3) =? y)
        ((f (x + 3)) <=? (f y))
  = true.
Proof.
  pos_convert.
  verit.
Qed.

Goal forall (f : positive -> positive) (x y : positive),
  implb ((x + 3) =? y)
        ((3 <? y) && ((f (x + 3)) <=? (f y)))
  = true.
Proof.
  pos_convert.
  verit.
Qed.

Local Close Scope positive_scope.

Local Open Scope N_scope.

Goal forall (f : N -> N) (x y : N),
    implb ((x + 3) =? y)
          ((f (x + 3)) <=? (f y))
    = true.
Proof.
  N_convert.
  verit.
Qed.

Goal forall (f : N -> N) (x y : N),
    implb ((x + 3) =? y)
          ((2 <? y) && ((f (x + 3)) <=? (f y)))
    = true.
Proof.
  N_convert.
  verit.
Qed.

Local Close Scope N_scope.

Require Import NPeano.
Local Open Scope nat_scope.

Goal forall (f : nat -> nat) (x y : nat),
    implb (Nat.eqb (x + 3) y)
          ((f (x + 3)) <=? (f y))
    = true.
Proof.
  nat_convert.
  verit.
Qed.

Goal forall (f : nat -> nat) (x y : nat),
    implb (Nat.eqb (x + 3) y)
          ((2 <? y) && ((f (x + 3)) <=? (f y)))
    = true.
Proof.
  nat_convert.
  verit.
Qed.

Local Close Scope nat_scope.

(* An example with all 3 types and a binary function *)
Goal forall f : positive -> nat -> N, forall (x : positive) (y : nat),
  implb (x =? 3)%positive
    (implb (Nat.eqb y 7)
      (implb (f 3%positive 7%nat =? 12)%N
        (f x y =? 12)%N)) = true.
  pos_convert.
  nat_convert.
  N_convert.
  verit.
Qed.

Open Scope Z_scope.

(** Now more insightful examples. The first one automatically proves
    properties in group theory. **)

Section group.
  Variable op : Z -> Z -> Z.
  Variable inv : Z -> Z.
  Variable e : Z.

  (* We can prove automatically that we have a group if we only have the
     "left" versions of the axioms of a group *)
  Hypothesis associative :
    forall a b c : Z, op a (op b c) =? op (op a b) c.
  Hypothesis inverse :
    forall a : Z, (op (inv a) a =? e).
  Hypothesis identity :
    forall a : Z, (op e a =? a).
  Add_lemmas associative identity inverse.

  (* The "right" version of inverse *)
  Lemma inverse' :
    forall a : Z, (op a (inv a) =? e).
  Proof. smt. Qed.

  (* The "right" version of identity *)
  Lemma identity' :
    forall a : Z, (op a e =? a).
  Proof. smt inverse'. Qed.

  (* Some other interesting facts about groups *)
  Lemma unique_identity e':
    (forall z, op e' z =? z) -> e' =? e.
  Proof. intros pe'; smt pe'. Qed.

  Lemma simplification_right x1 x2 y:
      op x1 y =? op x2 y -> x1 =? x2.
  Proof. intro H. smt_no_check H inverse'. Qed.

  Lemma simplification_left x1 x2 y:
      op y x1 =? op y x2 -> x1 =? x2.
  Proof. intro H. smt_no_check H inverse'. Qed.

  Clear_lemmas.
End group.

(* A full example coming from CompCert, slightly revisited.
   See: https://hal.inria.fr/inria-00289542
        https://xavierleroy.org/memory-model/doc/Memory.html (Section 3)
 *)
Section CompCert.

  Definition block := Z.
  Variable mem: Set.
  Variable dec_mem : CompDec mem.
  Variable alloc_block: mem -> Z -> Z -> block.
  Variable alloc_mem: mem -> Z -> Z -> mem.
  Variable valid_block: mem -> block -> bool.

  Hypothesis alloc_valid_block_1:
    forall m lo hi b,
      valid_block (alloc_mem m lo hi) b ---> ((b =? (alloc_block m lo hi)) || valid_block m b).

  Hypothesis alloc_valid_block_2:
    forall m lo hi b,
      ((b =? (alloc_block m lo hi)) || valid_block m b) ---> valid_block (alloc_mem m lo hi) b.

  Hypothesis alloc_not_valid_block:
    forall m lo hi,
       negb (valid_block m (alloc_block m lo hi)).

  Lemma alloc_valid_block_inv m lo hi b :
    valid_block m b -> valid_block (alloc_mem m lo hi) b.
  Proof.
    intro H. unfold block in *. verit alloc_valid_block_2 H.
  Qed.

  Lemma alloc_not_valid_block_2 m lo hi b' :
    valid_block m b' -> b' =? (alloc_block m lo hi) = false.
  Proof.
    intro H. unfold block in *. verit alloc_not_valid_block H.
  Qed.

End CompCert.


(** This file develops [Isomorphic], [≅]. See ua_homomorphism.v for
    [IsHomomorphism] and [IsIsomorphism]. *)

Require Export HoTT.Classes.theory.ua_homomorphism.

Require Import
  HoTT.Types
  HoTT.Tactics.

(** Two algebras [A B : Algebra σ] are isomorphic if there is an
    isomorphism [∀ s, A s → B s]. *)

Record Isomorphic {σ : Signature} (A B : Algebra σ) := BuildIsomorphic
  { def_isomorphic : ∀ s, A s → B s
  ; is_homomorphism_isomorphic : IsHomomorphism def_isomorphic
  ; is_isomorphism_isomorphic : IsIsomorphism def_isomorphic }.

Arguments BuildIsomorphic {σ A B} def_isomorphic
            {is_homomorphism_isomorphic} {is_isomorphism_isomorphic}.

Arguments def_isomorphic {σ A B}.
Arguments is_homomorphism_isomorphic {σ A B}.
Arguments is_isomorphism_isomorphic {σ A B}.

Global Existing Instance is_homomorphism_isomorphic.
Global Existing Instance is_isomorphism_isomorphic.

Module isomorphic_notations.
  Global Notation "A ≅ B" := (Isomorphic A B) : Algebra_scope.
End isomorphic_notations.

Import isomorphic_notations.

Definition SigIsomorphic {σ : Signature} (A B : Algebra σ) :=
  { def_iso : ∀ s, A s → B s
  | { _ : IsHomomorphism def_iso | IsIsomorphism def_iso }}.

Lemma issig_isomorphic {σ : Signature} (A B : Algebra σ)
  : SigIsomorphic A B <~> A ≅ B.
Proof.
  issig.
Defined.

(** Isomorphic algebras can be identified [A ≅ B → A = B]. *)

Corollary id_isomorphic `{Univalence} {σ} {A B : Algebra σ} (e : A ≅ B)
  : A = B.
Proof.
  exact (path_isomorphism (def_isomorphic e)).
Defined.

(** Identified algebras are isomorophic [A = B → A ≅ B] *)

Lemma isomorphic_id {σ} {A B : Algebra σ} (p : A = B) : A ≅ B.
Proof.
  destruct p. exact (BuildIsomorphic (hom_id A)).
Defined.

(** To find a path between two witnesses [F G : A ≅ B], it suffices
    to find a path between the defining families of functions and
    the [is_homomorphism_hom] witnesses. *)

Lemma path_isomorphic `{Funext} {σ : Signature} {A B : Algebra σ}
  (F G : A ≅ B) (a : def_isomorphic F = def_isomorphic G)
  (b : a#(is_homomorphism_isomorphic F) = is_homomorphism_isomorphic G)
  : F = G.
Proof.
  apply (ap (issig_isomorphic A B)^-1)^-1.
  srapply path_sigma.
  - exact a.
  - apply path_sigma_hprop.
    refine (ap _ (transport_sigma _ _) @ _).
    apply b.
Defined.

(** Suppose [IsHSetAlgebra B]. To find a path between two isomorphic
    witnesses [F G : A ≅ B], it suffices to find a path between the
    defining families of functions. *)

Lemma path_hset_isomorphic `{Funext} {σ : Signature} {A B : Algebra σ}
  `{IsHSetAlgebra B} (F G : A ≅ B)
  (a : def_isomorphic F = def_isomorphic G)
  : F = G.
Proof.
  apply (path_isomorphic F G a). apply path_ishprop.
Defined.

Section path_def_isomorphic_id_transport.
  Context {σ : Signature} {A B : Algebra σ}.

  Lemma path_def_isomorphic_id_transport_dom (p : A = B)
    : def_isomorphic (isomorphic_id p)
      = transport (λ C, ∀ s, C s → B s) (ap carriers p)^ (hom_id B).
  Proof.
    by path_induction.
  Defined.

  Lemma path_def_isomorphic_id_transport_cod (p : A = B)
    : def_isomorphic (isomorphic_id p)
      = transport (λ C, ∀ s, A s → C s) (ap carriers p) (hom_id A).
  Proof.
    by path_induction.
  Defined.
End path_def_isomorphic_id_transport.

(** If [IsHSetAlgebra A], then [path_isomorphism] maps the identity
    homomorphism of [A] to the identity path. *)

(* I suspect that the following lemma holds even when [A] is not a set
   algebra. To show this, [path_isomorphism] and [path_operations_equiv]
   should be made transparent, which they are not at the moment. *)

Lemma path_path_isomorphism_hom_id_hset `{Univalence} {σ : Signature}
  (A : Algebra σ) `{IsHSetAlgebra A}
  : path_isomorphism (hom_id A) = idpath.
Proof.
  apply path_path_hset_algebra.
  rewrite path_ap_carriers_path_algebra.
  apply (paths_ind (λ s, idpath) (λ f _, path_forall A A f = idpath)).
  - apply path_forall_1.
  - intros.
    funext s.
    symmetry.
    rewrite (path_ishprop _ (isequiv_idmap (A s))).
    apply path_universe_1.
Qed.

(** The following section shows that [isomorphic_id] is an equivalence
    with inverse [id_isomorphic]. *)

Section isequiv_isomorphic_id.
  Context `{Univalence} {σ} (A B : Algebra σ) `{IsHSetAlgebra B}.

  Lemma sect_id_isomorphic : (@isomorphic_id σ A B) o id_isomorphic == idmap.
  Proof.
    intro F.
    apply path_hset_isomorphic.
    rewrite path_def_isomorphic_id_transport_cod.
    funext s x.
    rewrite !transport_forall_constant.
    rewrite path_ap_carriers_path_algebra.
    transport_path_forall_hammer.
    apply transport_path_universe.
  Qed.

  Lemma sect_isomorphic_id : id_isomorphic o (@isomorphic_id σ A B) == idmap.
  Proof.
    intro p.
    destruct p.
    apply path_path_isomorphism_hom_id_hset.
    exact _.
  Qed.

  Global Instance isequiv_isomorphic_id : IsEquiv (@isomorphic_id σ A B)
    := isequiv_adjointify
          isomorphic_id
          id_isomorphic
          sect_id_isomorphic
          sect_isomorphic_id.

End isequiv_isomorphic_id.


(*
 * Section 2 Example from the ITP 2019 paper.
 *
 * NOTE: This has changed a lot since the ITP paper! I have updated this file
 * to reflect the latest automation. To see the original ITP version,
 * take a look at the state of this file in the ITP release.
 *)

Add LoadPath "coq/examples".
Require Import Vector.
Require Import List.
Require Import Ornamental.Ornaments.

From Coq Require Import ssreflect ssrbool ssrfun Arith.

Import EqNotations.

(* syntax to match paper *)
Notation vector := Vector.t.
Notation consV n t v := (Vector.cons _ t n v).
Notation nilV := Vector.nil.

(*
 * Here is our library that we will lift.
 *)
Module hs_to_coq'.

(* From:
 * https://github.com/antalsz/hs-to-coq/blob/master/base/GHC/List.v
 *)
Definition zip {a} {b} : list a -> list b -> list (a * b)%type :=
  fix zip arg_0__ arg_1__
        := match arg_0__, arg_1__ with
           | nil, _bs => nil
           | _as, nil => nil
           | cons a as_, cons b bs => cons (pair a b) (zip as_ bs)
  end.

(* From:
 * https://github.com/antalsz/hs-to-coq/blob/master/core-semantics-no-values/semantics.v
 *)
Fixpoint zip_with {A} {B} {C} (f : A -> B -> C) (s : list A) (t : list B) : list C :=
  match s , t with
    | a :: s' , b :: t' => f a b :: zip_with f s' t'
    | _       , _       => nil
  end.

Theorem zip_with_is_zip {A} {B} :
  forall l1 l2, zip_with (@pair A B) l1 l2 = zip l1 l2.
Proof. by elim => [|a s IH] [|b t] //=; rewrite IH. Qed.

End hs_to_coq'.

(* --- Preprocess --- *)

(*
 * We define our terms using match statements, so we first need to preprocess.
 * Sometimes we can get away without this when we write terms ourselves, as is
 * true later in this file.
 *)

Preprocess Module hs_to_coq' as hs_to_coq { opaque list_ind list_rect Coq.Init.Logic }.

(* --- Search and Lift --- *)

(*
 * You can omit these lines if you'd like, since Lift does not need them,
 * but enabling these options shows that search behaves correctly:
 *)
Set DEVOID search prove coherence.
Set DEVOID search prove equivalence.

(*
 * You can omit this as well, but it makes the types look nicer:
 *)
Set DEVOID lift type.

(*
 * This option tells DEVOID to generate an induction principle that
 * will be useful later:
 *)
Set DEVOID search smart eliminators.

(*
 * We can then repair our entire module (search runs automatically):
 *)
Repair Module list vector in hs_to_coq as hs_to_coqV_p { hint "auto" }.
(*
 * This also prints suggested proofs for section and retraction.
 * The suggested proof for section is the same as the paper draft version up to renaming.
 * The suggested proof for retraction has an additional "intros" that we remove when
 * we modify the suggestion in the paper.
 *)

(*
 * That gives us these terms:
 *)
Definition zipV_p := hs_to_coqV_p.zip.
Definition zip_withV_p := hs_to_coqV_p.zip_with.
Definition zip_with_is_zipV_p := hs_to_coqV_p.zip_with_is_zip.
(*
 * Tactics from tweaked tactic suggestions "Repair" outputs
 * are at the bottom of this file.
 *)

(* Here are our lifted types: *)
Check zipV_p.
Check zip_withV_p.
Check zip_with_is_zipV_p.
(*
 * This gets us to vectors of _some_ length. Next, we'll see how with additional
 * user input, we can get vectors of a _particular_ length.
 *)

(* --- Unpack --- *)

(*
 * Now we have proofs about sigT (vector T), but we want proofs about
 * vector T n. So now we can use a methodology to get from lists to
 * these proofs.
 *
 * The intuition for this methodology is that while list T is equivalent to sigT (vector T),
 * for any n, { l : list T & length l = n } lifts to equivalent
 * { s : sigT (vector T) & projT1 s = n}, which is equivalent to vector T n.
 * Thus, we write proofs about { l : list T & length l = n },
 * lift those from list to vector, and then lift those again
 * from { s : sigT (vector T) & projT1 s = n} to vector.
 *
 * However, writing proofs about { l : list T & length l = n } isn't
 * in itself straightforward, so we break this up into parts and use
 * a nice custom eliminator to make this easier.
 *
 * Let's start by proving the length invariants
 * (these were also proven by the human for ITP 2019):
 *)
Module hs_to_coq_lengths'.

Lemma zip_length:
  forall a b (l1 : list a) (l2 : list b),
    length l1 = length l2 ->
    length (hs_to_coq.zip a b l1 l2) = length l1.
Proof.
  induction l1, l2; intros; auto.
  simpl. f_equal. rewrite IHl1; auto.
Defined.

Lemma zip_length_n:
  forall a b (n : nat) (l1 : list a) (l2 : list b),
    length l1 = n ->
    length l2 = n ->
    length (hs_to_coq.zip a b l1 l2) = n.
Proof.
  intros. rewrite <- H. apply zip_length. eapply eq_trans; eauto.
Defined.

Lemma zip_with_length:
  forall A B C f (l1 : list A) (l2 : list B),
    length l1 = length l2 ->
    length (hs_to_coq.zip_with A B C f l1 l2) = length l1.
Proof.
  induction l1, l2; intros; auto.
  simpl. f_equal. rewrite IHl1; auto.
Defined.

Lemma zip_with_length_n:
  forall A B C f (n : nat) (l1 : list A) (l2 : list B),
    length l1 = n ->
    length l2 = n ->
    length (hs_to_coq.zip_with A B C f l1 l2) = n.
Proof.
  intros. rewrite <- H. apply zip_with_length. eapply eq_trans; eauto.
Defined.

End hs_to_coq_lengths'.

Preprocess Module hs_to_coq_lengths' as hs_to_coq_lengths { opaque Datatypes Logic Coq.Init.Nat.pred Coq.Init.Peano.eq_add_S hs_to_coq.zip hs_to_coq.zip_with list_ind list_rect eq_trans eq_sym }.

(*
 * Once we have the length proofs, we write the proofs
 * about { l : list T & length l = n }. To do this,
 * it's useful to have a nice induction principle,
 * which DEVOID generated since we set the "smart elims" option (new since ITP 2019)
 * (the name of this will always be the name of your promote function
 * followed by _rect):
 *)
Definition packed_list_rect := hs_to_coqV_p.list_to_t_rect.
Check packed_list_rect.
(*
 * TECHNICAL NOTE: DEVOID for now makes some assumptions
 * about the format here. Try not to run "induction" on terms of type
 * { l : list T & length l = n } directly, and instead try to
 * use this induction principle. I'm working on relaxing this
 * assumption. It has to do with preserving definitional equalities
 * when we lift (more specifically, incompleteness of matching against Eta and Iota).
 *)

(*
 * Regression bug after updating to 8.9.1: For some reason we now need to lift this
 * explicitly. Should investigate, as it may point to a regression bug elsewhere.
 *)
Lift list vector in packed_list_rect as packed_vector_rect.

(*
 * Then we can write our proofs. Now note how everything here
 * follows a nice and easy formula:
 *)
Module packed_list.

Definition zip_length := hs_to_coq_lengths.zip_length_n.
Definition zip_with_length := hs_to_coq_lengths.zip_with_length_n.

Program Definition zip:
  forall a b n,
    { l1 : list a & length l1 = n } ->
    { l2 : list b & length l2 = n } ->
    { l3 : list (a * b) & length l3 = n }.
Proof.
  intros a b n pl1. apply packed_list_rect with (P := fun (pl1 : { l1 : list a & length l1 = n }) => { l2 : list b & length l2 = n } -> { l3 : list (a * b) & length l3 = n }).
  - intros l H pl2.
    (* list function: *)
    exists (hs_to_coq.zip a b l (projT1 pl2)).
    (* length invariant: *)
    apply zip_length; auto. apply (projT2 pl2).
  - apply pl1.
Defined.

Program Definition zip_with:
  forall A B C (f : A -> B -> C) n,
    { l1 : list A & length l1 = n } ->
    { l2 : list B & length l2 = n } ->
    { l3 : list C & length l3 = n }.
Proof.
  intros A B C f n pl1. apply packed_list_rect with (P := fun (pl1 : {l1 : list A & length l1 = n}) => {l2 : list B & length l2 = n} -> {l3 : list C & length l3 = n}).
  - intros l H pl2.
    (* list function: *)
    exists (hs_to_coq.zip_with A B C f l (projT1 pl2)).
    (* length invariant: *)
    apply zip_with_length; auto. apply (projT2 pl2).
  - apply pl1.
Defined.
(*
 * It is cleaner for lifting to separate this out (not necessary though),
 * since Preprocess doesn't handle eq_existT_uncurried nicely:
 *)
Definition eq_existT_uncurried (T : Type) (n : nat) (l1 l2 : list T) (H1 : length l1 = n) (H2 : length l2 = n) (H : {p : l1 = l2 & rew [fun l : list T => length l = n] p in H1 = H2}) :=
@eq_existT_uncurried (list T) (fun (l : list T) => length l = n) l1 l2 H1 H2 H.

(*
 * The length invariant here relates our _proofs_ of the
 * above length invariants. Ouch! Luckily, for lists,
 * we can just use UIP, since equality over natural numbers
 * is decidable:
 *)
Lemma zip_with_is_zip :
  forall A B n (pl1 : { l1 : list A & length l1 = n }) (pl2 : { l2 : list B & length l2 = n }),
    zip_with A B (A * B) pair n pl1 pl2 = zip A B n pl1 pl2.
Proof.
  intros A B n pl1.
  apply packed_list_rect with (P := fun (pl1 : {l1 : list A & length l1 = n}) => forall pl2 : {l2 : list B & length l2 = n}, zip_with A B (A * B) pair n pl1 pl2 = zip A B n pl1 pl2).
  intros l H pl2.
  unfold zip_with, zip, packed_list_rect, hs_to_coqV_p.list_to_t_rect, packed_rect. simpl.
  apply eq_existT_uncurried.
  (* list proof: *)
  exists (hs_to_coq.zip_with_is_zip A B l (projT1 pl2)).
  (* length invariant: *)
  apply (Eqdep_dec.UIP_dec Nat.eq_dec).
Defined.
(*
 * TECHNICAL NOTE: In general, we may be able to avoid using UIP over the index
 * using adjunction and coherence together to show that we do not duplicate equalities (credit to Jason Gross).
 * There is also a coq-club thread about this with an alternative approach.
 * This should hopefully work for any algebraic ornament.
 * For now, if you do not have UIP on your index, you still run into
 * the equalities of equalities problem at some point.
 *
 * I will update this file when we solve this problem.
 *)
End packed_list.

(*
 * Now we can get from that to { s : sigT (vector T) & projT1 s = n} by lifting from
 * lists to vectors (new since ITP 2019).
 *
 * Rather than preprocess here, we just set terms that use pattern matching to
 * opaque for efficiency. We use Lift intead of Repair when tactics don't matter.
 *)
Lift Module list vector in hs_to_coq_lengths as hs_to_coq_projT1s.
Lift Module list vector in packed_list as packed_vector { opaque eq_existT_uncurried Eqdep_dec.UIP_dec Nat.eq_dec }.

(* We don't need tactics for these since they're just intermediate terms: *)
Check packed_vector.zip.
Check packed_vector.zip_with.
Check packed_vector.zip_with_is_zip.

(*
 * Finally, we can get from { s : sigT (vector T) & projT1 s = n} to unpacked vectors
 * at the index we want very easily.
 *
 * First we define a constant for { s : sigT (vector T) & projT1 s = n}, since DEVOID needs
 * this for caching.
 *)
Definition packed T n := { s : sigT (vector T) & projT1 s = n}.

(*
 * We can get away without preprocessing here, though we must set some terms to opaque to do that:
 *)
Configure Lift packed vector { opaque Eqdep_dec.UIP_dec Nat.eq_dec }.

(*
 * Then we repair (lifting hs_to_coqV_p first makes this faster and makes the result prettier):
 *)
Lift Module packed vector in hs_to_coqV_p as hs_to_coqV_u.
Repair Module packed vector in packed_vector as uf.

(* We are done. Here are our final types: *)
Check uf.zip.
Check uf.zip_with.
Check uf.zip_with_is_zip.

(*
 * TECHNICAL NOTE: For this particular example, interestingly, doing these by hand
 * without DEVOID, it's possible to construct functions such that the proof
 * of uf.zip_with_is_zipV goes through by reflexivity. However, these
 * are not the analogues of the functions included in the hs_to_coq module
 * (note that the proof using reflexivity does not work for them either).
 *)

(* --- Interface --- *)

(* Client code can then call our functions and proofs, for example: *)
Definition BVand' {n : nat} (v1 : vector bool n) (v2 : vector bool n) : vector bool n :=
  uf.zip_with bool bool bool andb n v1 v2.

(* --- Tactics --- *)

(*
 * We now have working functions and proofs over unpacked vectors.
 * We can use suggested tactics to get tactic scripts, but (as noted)
 * since they struggle with dependent types, we need to do a _lot_ of tweaking
 * right now. Still, let's do it using the suggested tactics and the terms
 * DEVOID has generated. These won't give exactly the same proof terms,
 * but we're OK with that.
 *
 * For zip:
 *)
Lemma zip_length:
  forall (a b : Type) (n : nat) (l1 : {H : nat & vector a H}) (l2 : {H : nat & vector b H}),
    projT1 l1 = n ->
    projT1 l2 = n ->
    projT1 (hs_to_coqV_p.zip a b (existT _ (projT1 l1) (projT2 l1)) (existT _ (projT1 l2) (projT2 l2))) = n.
Proof.
  intros a b n l1 l2 H.
  generalize dependent (projT2 l2). generalize dependent (projT1 l2).
  generalize dependent (projT2 l1). generalize dependent (projT1 l1).
  intros n1 H v1. rewrite <- H.
  revert H. revert n. induction v1 as [|h n0 t]; auto.
  intros n H n2 v2. revert H. revert n.
  induction v2 as [|h0 n1 t0]; auto.
  intros n H H2.
  simpl. f_equal. apply (IHt n0); auto.
Qed.

Program Definition zip:
  forall (a b : Type) (n : nat),
    vector a n -> vector b n -> vector (a * b) n.
Proof.
  intros a b n v1 v2.
  rewrite <- (zip_length _ _ _ (existT _ n v1) (existT _ n v2)); auto.
  apply (projT2 (hs_to_coqV_p.zip _ _ (existT _ n v1) (existT _ n v2))).
Defined.

(*
 * Note that this doesn't simplify away hs_to_coqV_p.zip.
 * There is no real point to doing so since we need both projections anyways.
 * Similarly, for zip_with:
 *)
Lemma zip_with_length:
  forall (A B C : Type) (f : A -> B -> C) (n : nat) (l1 : {H : nat & vector A H}) (l2 : {H : nat & vector B H}),
    projT1 l1 = n ->
    projT1 l2 = n ->
    projT1 (hs_to_coqV_p.zip_with A B C f (existT _ (projT1 l1) (projT2 l1)) (existT _ (projT1 l2) (projT2 l2))) = n.
Proof.
  intros A B C f n l1 l2 H.
  generalize dependent (projT2 l2). generalize dependent (projT1 l2).
  generalize dependent (projT2 l1). generalize dependent (projT1 l1).
  intros n1 H v1. rewrite <- H.
  revert H. revert n. induction v1 as [|h n0 t]; auto.
  intros n H n2 v2. revert H. revert n.
  induction v2 as [|h0 n1 t0]; auto.
  intros n H3 H4.
  simpl. f_equal. apply (IHt n0); auto.
Qed.

Program Definition zip_with:
  forall A B C : Type, (A -> B -> C) ->
    forall n : nat, vector A n -> vector B n -> vector C n.
Proof.
  intros A B C f n v1 v2.
  rewrite <- (zip_with_length _ _ _ f _ (existT _ n v1) (existT _ n v2)); auto.
  apply (projT2 (hs_to_coqV_p.zip_with _ _ _ f (existT _ n v1) (existT _ n v2))).
Defined.

(*
 * Finally:
 *)
Lemma zip_with_is_zipV_p_tactics :
  forall (A B : Type) (l1 : {H : nat & vector A H}) (l2 : {H : nat & vector B H}),
    zip_withV_p A B (A * B) pair (existT _ (projT1 l1) (projT2 l1)) (existT _ (projT1 l2) (projT2 l2))  =
    zipV_p A B (existT _ (projT1 l1) (projT2 l1)) (existT _ (projT1 l2) (projT2 l2)).
Proof.
  intros A B l1. induction (projT2 l1) as [|h n t].
  - intros l2. induction (projT2 l2) as [|h n t]; auto.
  - intros l2. induction (projT2 l2) as [|h0 n0 t0].
    + auto.
    + specialize (IHt (existT _ n0 t0)).
      replace (existT _ (projT1 (existT [eta vector B] n0 t0)) (projT2 (existT [eta vector B] n0 t0)))
      with (existT _ n0 t0) in IHt by auto.
      replace (zip_withV_p _ _ _ pair (existT _ (S n) (consV n h t)) (existT _ (S n0) (consV n0 h0 t0)))
      with
      (existT _
        (S (projT1 (zip_withV_p A B (A * B) pair (existT _ n t) (existT _ n0 t0))))
        (consV
          (projT1 (zip_withV_p A B (A * B) pair (existT _ n t) (existT _ n0 t0)))
          (h, h0)
          (projT2 (zip_withV_p A B (A * B) pair (existT _ n t) (existT _ n0 t0))))) by auto.
    rewrite IHt. auto.
Qed.

Lemma zip_with_is_zip:
  forall (A B : Type) (n : nat) (pl1 : vector A n) (pl2 : vector B n),
    zip_with A B (A * B) pair n pl1 pl2 = zip A B n pl1 pl2.
Proof.
  intros A B n pl1 pl2.
  apply uf.eq_existT_uncurried.
  exists (zip_with_is_zipV_p A B (existT [eta vector A] n pl1) (existT [eta vector B] n pl2)).
  apply (Eqdep_dec.UIP_dec Nat.eq_dec).
Qed.