(**************************************************************************)
(*  This is part of IMP-STATES-EXCEPTIONS, it is distributed under the    *)
(*       terms  of the GNU Lesser General Public License version 3        *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms Decorations Axioms Derived_co_Pairs Derived_co_Products Proofs.
Set Implicit Arguments.
Require Import ZArith.
Require Import Bool.
Open Scope Z_scope.
Require Setoid.

Module Make(Import M: Memory.T).
  Module Export FunctionsExp := Proofs.Make(M).

 Definition modulo (p: Z * Z) :=
    match p with
      | (x, y) => x mod y
    end.

 Definition add (p: Z * Z) :=
    match p with
      | (x, y) => x + y
    end.

 Definition subt (p: Z * Z) :=
    match p with
      | (x, y) => x - y
    end.

 Definition mlt (p: Z * Z) :=
    match p with
      | (x, y) => x * y
    end.

 Definition div (p: Z * Z) :=
    match p with
      | (x, y) => x / y
    end.

 Definition chkgt (p: Z * Z) : bool :=
    match p with
      | (a1, a2) => match (a1 ?= a2)%Z with
                      | Gt => true
                      | _  => false
                    end
    end.

 Definition chkge (p: Z * Z) : bool :=
     match p with
       | (a1, a2) => match (a1 ?= a2)%Z with
                       | Lt => false
                       | _  => true
                     end
     end.

 Definition chklt (p: Z * Z) : bool :=
    match p with
      | (a1, a2) => match (a1 ?= a2)%Z with
                      | Lt => true
                      | _  => false
                    end
    end.

 Definition chkle (p: Z * Z) : bool :=
    match p with
      | (a1, a2) => match (a1 ?= a2)%Z with
                      | Gt => false
                      | _  => true
                    end
    end.

 Definition chkeq (p: Z * Z) : bool :=
    match p with
      | (a1, a2) => match (a1 ?= a2)%Z with
                      | Eq => true
                      | _  => false
                    end
    end.

 Definition chkneq (p: Z * Z) : bool :=
    match p with
      | (a1, a2) => match (a1 ?= a2)%Z with
                      | Eq => false
                      | _  => true
                    end
    end.

 Definition andB (p: bool * bool): bool :=
    match p with
      | (x, y) => match (x && y) with
                    | false => false
                    | true  => true
                  end
    end.

 Definition orB (p: bool * bool): bool :=
    match p with
      | (x, y) => match (x || y) with
                    | false => false
                    | true  => true
                  end
    end.

 Definition notB (b: bool): bool := if b then false else true.

 Definition bool_to_prop (b: bool): Prop :=
     match b with
       | false => False
       | true  => True
    end.

End Make.


Require Import PocklingtonRefl.

Open Local Scope positive_scope.

Lemma prime5846725286581 : prime 5846725286581.
Proof.
 apply (Pocklington_refl
         (Pock_certif 5846725286581 2 ((10267, 1)::(2,2)::nil) 25246)
        ((Proof_certif 10267 prime10267) ::
         (Proof_certif 2 prime2) ::
          nil)).
 vm_cast_no_check (refl_equal true).
Qed.

Lemma prime2345678901234567890123567: prime  2345678901234567890123567.
apply (Pocklington_refl

(Ell_certif
2345678901234567890123567
77361229
((30321117329139797,1)::nil)
2345678901215618787857727
31749105730618655022
74219
5508459961)
(
(Ell_certif
30321117329139797
5186
((5846725286581,1)::nil)
11370418998427425
0
15160558664569900
22740837996854850)
:: (Proof_certif 5846725286581 prime5846725286581) :: nil)).
vm_cast_no_check (refl_equal true).
Time Qed.


Require Export XR_R0.
Require Export XR_Rminus.
Require Export XR_Rplus_0_l.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rminus_0_l : forall r, R0 - r = - r.
Proof.
  intro x.
  unfold Rminus.
  rewrite Rplus_0_l.
  reflexivity.
Qed.


  (***************************************************************)
  (*   This file is part of the static analyses developement -   *)
  (*   specification of kildall's algorithm, and proof it is a   *)
  (*   bytecode verifier -                                       *)
  (*							         *)
  (*   File : vector.v		   		                 *)
  (*   Authors : S. Coupet-Grimal, W. Delobel		         *)
  (*   Content : specification of lists of fixed length (vector) *)
  (*             and related functions.			         *)
  (***************************************************************)

Global Set Asymmetric Patterns.

Section Vector.

  Require Export Eqdep.
  Require Export Arith.
  Require Export semilattices.

  (* base set : *)
  Variable A : Set.

  Inductive vector : nat->Set:=
    | vector_nil : (vector 0)
    | vector_cons : forall (n:nat), A->vector n->(vector (S n)).

  Definition eq_list:=(eq_dep nat vector).

  Definition head':=
    fun (n:nat) (v:(vector n)) =>
      match v in (vector x) return (lt 0 x)-> A with
	vector_nil => fun h:(lt O O) => (False_rec A (lt_irrefl O h)) |
	  (vector_cons n' h _) => fun H : (lt 0 (S n')) => h
      end.

  (* returns head (first element) of the list *)
  Definition head:=
    fun (n:nat)(v:(vector (S n))) =>  (head' (S n) v (lt_O_Sn n)).

  Definition tail:=
    fun (n:nat)(v:vector n) =>
      match v in (vector x) return (vector (pred x)) with
	vector_nil => vector_nil|
	  (vector_cons n' h v')=> v' end.

  Lemma empty_dep:forall (n:nat)(v:(vector n)), n=O->(eq_list O vector_nil n v).
  Proof.
    unfold eq_list; intros n v.
    dependent inversion v; auto.
    intro h; absurd  ((S n0)=0); auto.
  Qed.

  Hint Resolve empty_dep.

  Lemma empty:forall (v:(vector O)), vector_nil=v.
  Proof.
    intro v.
    apply (eq_dep_eq nat vector O).
    apply empty_dep; auto.
  Qed.

  Hint Resolve empty.

  Remark non_empty_dep:
    forall (n m : nat), m=(S n)->forall (v:(vector (S n))),
      {h:A & {t:(vector n) | (eq_list (S n) v (S n) (vector_cons n h t))}}.
  Proof.
    intros.
    generalize H.
    dependent inversion_clear v with
      (fun (n':nat)(v:(vector n')) =>
        m=n'-> {a:A & {v':(vector n)|(eq_list n' v (S n) (vector_cons n a v'))}}).
    unfold eq_list.
    intro H'.
    exists a.
    exists v0.
    constructor.
  Qed.

  Lemma non_empty:forall (n:nat)(v:(vector (S n))),
    {a:A &{t:(vector n)|v=(vector_cons n a t)}}.
  Proof.
    intros n v.
    cut (sigS (fun a:A=>
      (sig (fun t:(vector n)=>(eq_list (S n) v (S n) (vector_cons n a t)))))).
    intros H; elim H; clear H.
    intros a H; elim H; clear H.
    intros t H.
    exists a; exists t.
    apply (eq_dep_eq nat vector (S n)) .
    unfold eq_list in H; auto.
    apply (non_empty_dep n (S n)); auto.
  Defined.

  Lemma split_vector :forall (n:nat)(v:(vector (S n))),
    v=(vector_cons n (head n v) (tail (S n) v)).
  Proof.
    intros n v.
    elim (non_empty n v).
    intros h H; elim H; clear H.
    intros t e.
    rewrite e; simpl.
    auto.
  Qed.

  Definition hd' := fun  (n:nat)(v:(vector (S n))) =>
    let (a, H):= (non_empty n v) in a.

  Lemma Non_empty_Hd :
    forall (n:nat)(a:A)(v:(vector n)), (hd' n (vector_cons n a v))=a.
  Proof.
    intros n a v; unfold hd'.
    elim (non_empty n (vector_cons n a v)).
    intros x H; elim H.
    clear H; intros X H.
    injection H; auto.
  Qed.

  (* pointwise order on vectors : *)
  Inductive vector_pointwise (r:relation A):
    forall n:nat, (vector n)->(vector n) -> Prop :=
    | le_nil: vector_pointwise r 0 vector_nil vector_nil
    | le_cons: forall (a a' : A) (n : nat) (v v' : (vector n)),
      (r a a')->vector_pointwise r n v v'->vector_pointwise r (S n) (vector_cons n a v) (vector_cons n a' v').

  Definition Vector_pointwise (r:relation A) (n:nat) : relation (vector n) :=
    vector_pointwise r n.
  Definition SI_vector_pointwise (r:relation A) (n:nat) : relation (vector n) :=
    strict (inv (vector_pointwise r n)).

  (* replaces element at rank p with element a;
     leaves list unchanged if rank is greater than the size of the list *)
  Fixpoint vector_replace (n:nat) (v:vector n) (i:nat) (a:A) {struct v}:
    (vector n) :=
    match v in vector n return vector n with
      | vector_nil => vector_nil
      | vector_cons n' h t =>
       	match i with
          | 0 => vector_cons n' a t
          | (S i') => vector_cons  n' h (vector_replace n' t i' a)
        end
    end.

  (* returns True if element a belongs to the vector *)
  Fixpoint belong_element_vector (n:nat) (l : vector n) (a:A) {struct l} : Prop :=
    match l in vector n return Prop with
      | vector_nil => False
      | vector_cons n' h t => h=a \/ belong_element_vector n' t a
    end.

  (* extracts element at rank i, given a proof i is less than the size *)
  Fixpoint element_at (n:nat) (v : vector n) (i:nat) {struct v} :
    (lt i n)->A :=
    match v in vector n, i return (lt i n)->A with
      | vector_nil, _ => fun x : (lt i 0) => (False_rec A (lt_n_O i x))
      | (vector_cons p h t), 0 => fun (x : (lt 0 (S p)))=> h
      | (vector_cons p h t), (S i') =>
        fun (x : (lt (S i') (S p))) => (element_at p t i') (lt_S_n i' p x)
    end.

  (* unsafe version of element_at *)
  Fixpoint element_at_unsafe (n : nat) (v : vector n) (i : nat) {struct v} : option A :=
    match v with
      | vector_nil => None
      | vector_cons p h t =>
        match i with
       	  | 0 => Some h
	  | S i' => element_at_unsafe p t i'
	end
    end.

  (* build a constant list containing element e *)
  Fixpoint constant_list (n : nat) (a : A) {struct n} : vector n :=
    match n return vector n with
      | 0 => vector_nil
      | (S p) => vector_cons p a (constant_list p a)
    end.

End Vector.

  (* map on a vector : *)
Fixpoint vector_map (A B:Set) (g:A->B) (n:nat) (v:vector A n) {struct v} :
  vector B n :=
  match v in (vector _ n) return (vector _ n) with
    | vector_nil => vector_nil B
    | vector_cons p h t => vector_cons B p (g h) (vector_map A B g p t)
  end.

Fixpoint map2 (A B C : Set) (f : A-> B -> C) (n : nat) {struct n}:
  (vector A n)->(vector B n)-> (vector C n):=
  match n return (vector _ n)->(vector _ n)-> (vector _ n) with
    | 0 =>  (fun (v:(vector _ 0))(v':(vector _ 0)) =>  (vector_nil _))
    | (S p)=> (fun  (v:(vector _ (S p))) (v':(vector _ (S p))) =>
        (vector_cons _ p (f (head A p v) (head B p v'))
          (map2 _ _ _  f _ (tail _ _ v) (tail _ _ v'))))
  end.

Definition Map2 (A : Set) (f : binop A) (n:nat):= map2 A A A f n.

Implicit Arguments vector_cons [A n].
Implicit Arguments vector_nil [A].
Implicit Arguments head [A n].
Implicit Arguments tail [A n].
Implicit Arguments empty [A].
Implicit Arguments split_vector [A n].
Implicit Arguments vector_replace [A n].
Implicit Arguments belong_element_vector [A n].
Implicit Arguments element_at [A n].
Implicit Arguments vector_map [A B n].
Implicit Arguments map2 [A B C n].
Implicit Arguments Map2 [A].
Implicit Arguments constant_list [A].
Implicit Arguments element_at_unsafe [A n].

Ltac Split x:= replace x with (vector_cons (head x) (tail x));
  [trivial(*idtac?*) | symmetry; exact (split_vector x)].

Ltac CaseEq f:=generalize (refl_equal f); pattern f at -1 in |- *; case f.

Notation "v '[' p '<-' e ']'" := (vector_replace v p e) (at level 50).
Notation "e 'INv' v" := (belong_element_vector v e) (at level 50).
Notation "v '[' p '|' C ']'" := (element_at v p C) (at level 50).
Notation "v '[' p '|_]'" := (element_at_unsafe v p) (at level 50).


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e213m3_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Coq.Lists.List. Import ListNotations.

Require Import
        Coq.Bool.Bool
        Coq.Strings.Ascii
        Coq.Strings.String.

From SRC Require Export Utils CStrings.

Local Open Scope char.

Inductive regex : Type :=
  | Eps : regex
  | Sym : ascii -> regex
  | Alt : regex -> regex -> regex
  | Seq : regex -> regex -> regex
  | Rep : regex -> regex.

Definition is_null (s : lstring) : bool :=
  match s with
    | [] => true
    | _  => false
  end.

Definition or_fold (l : list bool) : bool :=
  fold_right (orb) false l.

Definition and_fold (l : list bool) : bool :=
  fold_right (andb) true l.

Fixpoint accept (r : regex) (u : lstring) : bool :=
  match r with
    | Eps => is_null u
    | Sym c => eq_lstring [c] u
    | Alt p q => accept p u || accept q u
    | Seq p q =>
      or_fold (map (fun '(u1, u2) => accept p u1 && accept q u2)
                   (split u))
    | Rep x =>
      let mparts r' m :=
          map (fun x =>  accept r' x) m in
      let nparts r' m :=
          map (fun x => mparts r' x) m in
      let result r' m :=
          or_fold (map (and_fold)
                       (nparts r' (parts m)))
      in
      result x u
  end.

Compute accept (Seq (Sym "a") (Sym "b")) ["a"; "b"].


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e243m9_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e150m3_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e127m1_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e285m9_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e174m3_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e213m3_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import init.

Require Import set.
Require Import unordered_list.

Require Import module_category.
Require Import algebra_category.
Require Import linear_bilinear_form.
Require Import linear_sum.
Require Import linear_transformation_space.

Require Export geometric_construct.
Require Export geometric_universal.
Require Export exterior_construct.
Require Import exterior_universal.

(* begin hide *)
Section ExteriorToGeometric.

(* end hide *)
Context {F : CRingObj} {V : ModuleObj F}.
(* begin hide *)

Let UP := cring_plus F.
Let UZ := cring_zero F.
Let UN := cring_neg F.
Let UPC := cring_plus_comm F.
Let UPZ := cring_plus_lid F.
Let UPN := cring_plus_linv F.
Let UM := cring_mult F.
Let UO := cring_one F.
Let UMC := cring_mult_comm F.

Existing Instances UP UZ UN UPC UPZ UPN UM UO UMC.

Let VP := module_plus V.
Let VS := module_scalar V.

Existing Instances VP VS.

(* end hide *)
Context (B : set_type bilinear_form).

(* begin hide *)
Let GP := geo_plus B.
Let GZ := geo_zero B.
Let GN := geo_neg B.
Let GPA := geo_plus_assoc B.
Let GPC := geo_plus_comm B.
Let GPZ := geo_plus_lid B.
Let GPN := geo_plus_linv B.
Let GM := geo_mult B.
Let GO := geo_one B.
Let GMA := geo_mult_assoc B.
Let GML := geo_mult_lid B.
Let GMR := geo_mult_rid B.
Let GS := geo_scalar B.
Let GSO := geo_scalar_id B.
Let GSL := geo_scalar_ldist B.
Let GSR := geo_scalar_rdist B.
Let GSC := geo_scalar_comp B.
Let GL := geo_ldist B.
Let GR := geo_rdist B.
Let GSML := geo_scalar_lmult B.
Let GSMR := geo_scalar_rmult B.

Existing Instances GP GZ GN GPA GPC GPZ GPN GM GO GMA GML GMR GS GSO GSL GSR GSC
    GL GR GSML GSMR.

Let G12 := direct_sum (algebra_module (geometric_algebra B))
                       (algebra_module (geometric_algebra B)).
Let G12P := module_plus G12.
Let G12S := module_scalar G12.

Existing Instances G12P G12S.

Definition geo_mult_inner_base1 (a : module_V V) (v : module_V V) (p : module_V G12)
    := (
        vector_to_geo B v * fst p,
        -vector_to_geo B v * snd p + [B|] a v · (fst p)
    ) : module_V G12.

Lemma geo_mult_inner_base_plus : ∀ a v p1 p2, geo_mult_inner_base1 a v (p1 + p2) =
    geo_mult_inner_base1 a v p1 + geo_mult_inner_base1 a v p2.
Proof.
    intros a v [p11 p12] [p21 p22]; cbn.
    unfold geo_mult_inner_base1; cbn.
    unfold plus at 1 3 4 5; cbn.
    apply f_equal2.
    -   apply ldist.
    -   rewrite ldist.
        do 2 rewrite <- plus_assoc.
        apply lplus.
        rewrite scalar_ldist.
        do 2 rewrite plus_assoc.
        apply rplus.
        apply plus_comm.
Qed.

Lemma geo_mult_inner_base_scalar : ∀ a v b p, geo_mult_inner_base1 a v (b · p) =
    b · geo_mult_inner_base1 a v p.
Proof.
    intros a v b [p1 p2].
    unfold geo_mult_inner_base1; cbn.
    unfold scalar_mult at 1 2 4 5; cbn.
    apply f_equal2.
    -   apply scalar_rmult.
    -   rewrite scalar_rmult.
        rewrite scalar_comp.
        rewrite (mult_comm _ b).
        rewrite <- scalar_comp.
        rewrite scalar_ldist.
        reflexivity.
Qed.

Definition geo_mult_inner_base2 (a : module_V V) (v : module_V V) :=
    make_module_homomorphism F G12 G12
    (geo_mult_inner_base1 a v)
    (geo_mult_inner_base_plus a v)
    (geo_mult_inner_base_scalar a v).

Let G3 := linear_trans_algebra G12.
Let G3P := algebra_plus G3.
Let G3S := algebra_scalar G3.
Let G3M := algebra_mult G3.
Let G3O := algebra_one G3.

Existing Instances G3P G3S G3M G3O.

Lemma geo_mult_inner_base2_plus : ∀ a v1 v2, geo_mult_inner_base2 a (v1 + v2) =
    geo_mult_inner_base2 a v1 + geo_mult_inner_base2 a v2.
Proof.
    intros a v1 v2.
    apply module_homomorphism_eq.
    intros [x1 x2].
    unfold plus at 2; cbn.
    unfold geo_mult_inner_base2, linear_trans_plus_base; cbn.
    unfold geo_mult_inner_base1; cbn.
    unfold plus at 5; cbn.
    apply f_equal2.
    -   rewrite (vector_to_geo_plus B).
        apply rdist.
    -   rewrite (vector_to_geo_plus B).
        rewrite neg_plus.
        rewrite rdist.
        do 2 rewrite <- plus_assoc.
        apply lplus.
        rewrite bilinear_form_rplus.
        rewrite scalar_rdist.
        do 2 rewrite plus_assoc.
        apply rplus.
        apply plus_comm.
Qed.

Lemma geo_mult_inner_base2_scalar : ∀ a b v,
    geo_mult_inner_base2 a (b · v) = b · geo_mult_inner_base2 a v.
Proof.
    intros a b v.
    apply module_homomorphism_eq.
    intros [x1 x2].
    unfold scalar_mult at 2; cbn.
    unfold linear_trans_scalar_base; cbn.
    unfold geo_mult_inner_base1; cbn.
    unfold scalar_mult at 5; cbn.
    apply f_equal2.
    -   rewrite (vector_to_geo_scalar B).
        apply scalar_lmult.
    -   rewrite (vector_to_geo_scalar B).
        rewrite bilinear_form_rscalar.
        rewrite <- scalar_comp.
        rewrite scalar_ldist.
        do 2 rewrite mult_lneg.
        rewrite scalar_rneg.
        rewrite scalar_lmult.
        reflexivity.
Qed.

Lemma geo_mult_inner_base_contract : ∀ a v,
    geo_mult_inner_base2 a v * geo_mult_inner_base2 a v = [B|] v v · 1.
Proof.
    intros a v.
    apply module_homomorphism_eq.
    intros [x1 x2].
    unfold mult, scalar_mult, one; cbn.
    unfold linear_trans_scalar_base, geo_mult_inner_base1; cbn.
    unfold scalar_mult at 3; cbn.
    apply f_equal2.
    -   rewrite mult_assoc.
        rewrite (geo_contract B).
        rewrite scalar_lmult.
        rewrite mult_lid.
        reflexivity.
    -   rewrite ldist.
        rewrite mult_assoc.
        rewrite mult_lneg, mult_rneg.
        rewrite (geo_contract B).
        rewrite neg_neg.
        rewrite <- scalar_rmult.
        rewrite mult_lneg.
        rewrite plus_rlinv.
        rewrite scalar_lmult.
        rewrite mult_lid.
        reflexivity.
Qed.

Definition geo_mult_inner_base3 a := make_module_homomorphism
    F
    V
    (algebra_module G3)
    (geo_mult_inner_base2 a)
    (geo_mult_inner_base2_plus a)
    (geo_mult_inner_base2_scalar a).

Definition geo_mult_inner_base4 a := make_to_geo
    B
    G3
    (geo_mult_inner_base3 a)
    (geo_mult_inner_base_contract a).

Definition geo_mult_inner_base a
    := ex_singleton (geometric_universal B (geo_mult_inner_base4 a)).

Definition geo_mult_inner_f_homo a := [geo_mult_inner_base a|].
Definition geo_mult_inner_f a := algebra_homo_f (geo_mult_inner_f_homo a).

Theorem geo_mult_inner_f_eq : ∀ a v,
    geo_mult_inner_f a (vector_to_geo B v) = geo_mult_inner_base2 a v.
Proof.
    intros a.
    apply [|geo_mult_inner_base a].
Qed.

Theorem geo_mult_inner_f_mult : ∀ a u v,
    geo_mult_inner_f a (u * v) = geo_mult_inner_f a u * geo_mult_inner_f a v.
Proof.
    intros a u v.
    apply algebra_homo_mult.
Qed.

Definition geo_mult_inner a v := snd (geo_mult_inner_f a v (1, 0)).

(* end hide *)
Theorem geo_mult_inner_rplus : ∀ a u v,
    geo_mult_inner a (u + v) = geo_mult_inner a u + geo_mult_inner a v.
Proof.
    intros a u v.
    unfold geo_mult_inner.
    unfold geo_mult_inner_f.
    rewrite algebra_homo_plus.
    unfold plus at 1; cbn.
    unfold linear_trans_plus_base.
    unfold plus at 1; cbn.
    reflexivity.
Qed.

Theorem geo_mult_inner_rscalar : ∀ a α v,
    geo_mult_inner a (α · v) = α · geo_mult_inner a v.
Proof.
    intros a α v.
    unfold geo_mult_inner.
    unfold geo_mult_inner_f.
    rewrite algebra_homo_scalar.
    unfold scalar_mult at 1; cbn.
    unfold linear_trans_scalar_base.
    unfold scalar_mult at 1; cbn.
    reflexivity.
Qed.

Theorem geo_mult_inner_rzero : ∀ a, geo_mult_inner a 0 = 0.
Proof.
    intros a.
    rewrite <- (scalar_lanni 0).
    rewrite geo_mult_inner_rscalar.
    apply scalar_lanni.
Qed.

Theorem geo_mult_inner_rneg : ∀ a v, geo_mult_inner a (-v) = -geo_mult_inner a v.
Proof.
    intros a v.
    rewrite <- scalar_neg_one.
    rewrite geo_mult_inner_rscalar.
    apply scalar_neg_one.
Qed.

Theorem geo_mult_inner_add : ∀ a v x,
    geo_mult_inner a (vector_to_geo B v * x) =
    [B|] a v · x - vector_to_geo B v * geo_mult_inner a x.
Proof.
    intros a v x.
    pose proof (geo_sum B x) as [l l_eq]; subst x.
    induction l as [|[α x] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite mult_ranni.
        rewrite geo_mult_inner_rzero.
        rewrite mult_ranni.
        rewrite scalar_ranni.
        rewrite neg_zero, plus_rid.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    rewrite ldist.
    rewrite scalar_rmult.
    rewrite geo_mult_inner_rplus.
    rewrite IHl; clear IHl.
    rewrite geo_mult_inner_rplus.
    rewrite ldist.
    rewrite neg_plus.
    do 2 rewrite plus_assoc.
    apply rplus.
    rewrite scalar_ldist.
    rewrite <- plus_assoc.
    rewrite (plus_comm _ (-(vector_to_geo B v * _))).
    rewrite plus_assoc.
    apply rplus.
    clear l.
    do 2 rewrite geo_mult_inner_rscalar.
    rewrite scalar_rmult.
    rewrite scalar_comp.
    rewrite (mult_comm _ α).
    rewrite <- scalar_comp.
    rewrite <- scalar_rneg.
    rewrite <- scalar_ldist.
    apply f_equal.
    unfold geo_mult_inner.
    rewrite geo_mult_inner_f_mult.
    rewrite geo_mult_inner_f_eq.
    unfold mult at 1; cbn.
    rewrite plus_comm.
    rewrite mult_lneg.
    apply rplus.
    induction x as [|x l].
    {
        cbn.
        unfold geo_mult_inner_f.
        rewrite algebra_homo_one.
        unfold one at 1; cbn.
        reflexivity.
    }
    cbn.
    rewrite geo_mult_inner_f_mult.
    unfold mult at 1; cbn.
    unfold linear_trans_mult_base.
    rewrite geo_mult_inner_f_eq.
    cbn.
    rewrite <- scalar_rmult.
    rewrite IHl; clear IHl.
    rewrite scalar_rmult.
    reflexivity.
Qed.

Theorem geo_mult_inner_scalar : ∀ a α, geo_mult_inner a (scalar_to_geo B α) = 0.
Proof.
    intros a α.
    unfold geo_mult_inner.
    unfold geo_mult_inner_f.
    rewrite scalar_to_geo_one_scalar.
    rewrite algebra_homo_scalar.
    rewrite algebra_homo_one.
    unfold scalar_mult; cbn.
    unfold linear_trans_scalar_base.
    unfold one at 1; cbn.
    unfold scalar_mult; cbn.
    rewrite scalar_ranni.
    reflexivity.
Qed.

Theorem geo_mult_inner_vector : ∀ a v,
    geo_mult_inner a (vector_to_geo B v) = [B|] a v · 1.
Proof.
    intros a v.
    rewrite <- (mult_rid (vector_to_geo B v)).
    rewrite geo_mult_inner_add.
    unfold GO.
    rewrite <- scalar_to_geo_one at 2.
    rewrite geo_mult_inner_scalar.
    rewrite mult_ranni.
    rewrite neg_zero, plus_rid.
    reflexivity.
Qed.

Theorem geo_mult_inner_bivector : ∀ a u v,
    geo_mult_inner a (vector_to_geo B u * vector_to_geo B v) =
    [B|] a u · vector_to_geo B v -
    [B|] a v · vector_to_geo B u.
Proof.
    intros a u v.
    rewrite geo_mult_inner_add.
    rewrite geo_mult_inner_vector.
    rewrite scalar_rmult.
    rewrite mult_rid.
    reflexivity.
Qed.

Theorem geo_mult_inner_lplus : ∀ a b v,
    geo_mult_inner (a + b) v = geo_mult_inner a v + geo_mult_inner b v.
Proof.
    intros a b v.
    pose proof (geo_sum B v) as [l l_eq]; subst v.
    induction l as [|[α v] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 3 rewrite geo_mult_inner_rzero.
        rewrite plus_rid.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    do 3 rewrite geo_mult_inner_rplus.
    rewrite IHl; clear IHl.
    do 2 rewrite plus_assoc.
    apply rplus.
    rewrite <- plus_assoc.
    rewrite (plus_comm (geo_mult_inner a (ulist_sum _))).
    rewrite plus_assoc.
    apply rplus; clear l.
    do 3 rewrite geo_mult_inner_rscalar.
    rewrite <- scalar_ldist.
    apply f_equal.
    induction v as [|v l].
    {
        rewrite list_image_end; cbn.
        rewrite list_prod_end.
        rewrite <- scalar_to_geo_one.
        do 3 rewrite geo_mult_inner_scalar.
        rewrite plus_rid.
        reflexivity.
    }
    rewrite list_image_add; cbn.
    do 3 rewrite geo_mult_inner_add.
    rewrite IHl; clear IHl.
    rewrite ldist.
    rewrite neg_plus.
    do 2 rewrite plus_assoc.
    apply rplus.
    rewrite bilinear_form_lplus.
    rewrite scalar_rdist.
    do 2 rewrite <- plus_assoc.
    apply lplus.
    apply plus_comm.
Qed.

Theorem geo_mult_inner_lscalar : ∀ α a v,
    geo_mult_inner (α · a) v = α · geo_mult_inner a v.
Proof.
    intros α a v.
    pose proof (geo_sum B v) as [l l_eq]; subst v.
    induction l as [|[β v] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 2 rewrite geo_mult_inner_rzero.
        rewrite scalar_ranni.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    do 2 rewrite geo_mult_inner_rplus.
    rewrite IHl; clear IHl.
    rewrite scalar_ldist.
    apply rplus; clear l.
    do 2 rewrite geo_mult_inner_rscalar.
    rewrite scalar_comp.
    rewrite mult_comm.
    rewrite <- scalar_comp.
    apply f_equal; clear β.
    induction v as [|v l].
    {
        rewrite list_image_end; cbn.
        rewrite list_prod_end.
        rewrite <- scalar_to_geo_one.
        do 2 rewrite geo_mult_inner_scalar.
        rewrite scalar_ranni.
        reflexivity.
    }
    rewrite list_image_add; cbn.
    do 2 rewrite geo_mult_inner_add.
    rewrite IHl; clear IHl.
    rewrite bilinear_form_lscalar.
    rewrite scalar_ldist.
    rewrite scalar_comp.
    rewrite scalar_rneg.
    rewrite scalar_rmult.
    reflexivity.
Qed.

(* begin hide *)
Definition geo_mult_inner_homo a := make_module_homomorphism
    F
    (algebra_module (geometric_algebra B))
    (algebra_module (geometric_algebra B))
    (geo_mult_inner a)
    (geo_mult_inner_rplus a)
    (geo_mult_inner_rscalar a).

Definition geo_mult_homo a := make_module_homomorphism
    F
    (algebra_module (geometric_algebra B))
    (algebra_module (geometric_algebra B))
    (mult (vector_to_geo B a))
    (ldist (vector_to_geo B a))
    (λ α v, scalar_rmult α (vector_to_geo B a) v).

Let GG := linear_trans_algebra (algebra_module (geometric_algebra B)).
Let GGP := algebra_plus GG.
Let GGZ := algebra_zero GG.
Let GGN := algebra_neg GG.
Let GGPA := algebra_plus_assoc GG.
Let GGPC := algebra_plus_comm GG.
Let GGPZ := algebra_plus_lid GG.
Let GGPN := algebra_plus_linv GG.
Let GGM := algebra_mult GG.
Let GGO := algebra_one GG.
Let GGL := algebra_ldist GG.
Let GGR := algebra_rdist GG.
Let GGS := algebra_scalar GG.
Let GGSL := algebra_scalar_ldist GG.

Existing Instances GGP GGZ GGN GGPA GGPC GGPZ GGPN GGM GGO GGL GGR GGS GGSL.

Theorem geo_mult_inner_alternating : ∀ a,
    geo_mult_inner_homo a * geo_mult_inner_homo a = 0.
Proof.
    intros a.
    apply module_homomorphism_eq.
    intros x.
    unfold mult at 1; cbn.
    unfold zero at 1; cbn.
    unfold linear_trans_zero_base.
    pose proof (geo_sum B x) as [l l_eq]; subst x.
    induction l as [|[α x] l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 2 rewrite geo_mult_inner_rzero.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add; cbn.
    do 2 rewrite geo_mult_inner_rplus.
    rewrite IHl; clear IHl l.
    rewrite plus_rid.
    do 2 rewrite geo_mult_inner_rscalar.
    rewrite <- (scalar_ranni α).
    apply f_equal.
    induction x as [|v l].
    {
        rewrite list_image_end; cbn.
        rewrite list_prod_end.
        rewrite <- scalar_to_geo_one.
        rewrite geo_mult_inner_scalar.
        apply geo_mult_inner_rzero.
    }
    rewrite list_image_add; cbn.
    rewrite geo_mult_inner_add.
    rewrite geo_mult_inner_rplus.
    rewrite geo_mult_inner_rneg.
    rewrite geo_mult_inner_add.
    rewrite IHl.
    rewrite mult_ranni.
    rewrite neg_zero, plus_rid.
    rewrite geo_mult_inner_rscalar.
    rewrite plus_rinv.
    reflexivity.
Qed.

Theorem geo_mult_contract : ∀ a, geo_mult_homo a * geo_mult_homo a = [B|] a a · 1.
Proof.
    intros a.
    apply module_homomorphism_eq.
    intros x.
    unfold mult at 1; cbn.
    unfold scalar_mult at 1, one at 1; cbn.
    unfold linear_trans_scalar_base; cbn.
    rewrite mult_assoc.
    rewrite (geo_contract B).
    rewrite scalar_lmult.
    rewrite mult_lid.
    reflexivity.
Qed.

Definition ext_to_geo_base1 a := -geo_mult_inner_homo a + geo_mult_homo a.

Lemma ext_to_geo_base1_plus : ∀ u v,
    ext_to_geo_base1 (u + v) = ext_to_geo_base1 u + ext_to_geo_base1 v.
Proof.
    intros u v.
    unfold ext_to_geo_base1.
    apply module_homomorphism_eq.
    intros x.
    unfold plus at 1 4 5 6; cbn.
    unfold linear_trans_plus_base; cbn.
    unfold neg at 1 2 3; cbn.
    unfold linear_trans_neg_base; cbn.
    rewrite geo_mult_inner_lplus.
    rewrite (vector_to_geo_plus B).
    rewrite rdist.
    rewrite neg_plus.
    do 2 rewrite <- plus_assoc.
    apply lplus.
    do 2 rewrite plus_assoc.
    apply rplus.
    apply plus_comm.
Qed.

Lemma ext_to_geo_base1_scalar : ∀ a v,
    ext_to_geo_base1 (a · v) = a · ext_to_geo_base1 v.
Proof.
    intros a v.
    unfold ext_to_geo_base1.
    apply module_homomorphism_eq.
    intros x.
    rewrite scalar_ldist.
    unfold scalar_mult at 3 4, plus at 1 2; cbn.
    unfold linear_trans_plus_base, linear_trans_scalar_base; cbn.
    unfold neg at 1 2; cbn.
    unfold linear_trans_neg_base; cbn.
    rewrite geo_mult_inner_lscalar.
    rewrite (vector_to_geo_scalar B).
    rewrite scalar_lmult.
    rewrite scalar_rneg.
    reflexivity.
Qed.

Lemma ext_to_geo_base_alternating : ∀ v,
    0 = ext_to_geo_base1 v * ext_to_geo_base1 v.
Proof.
    intros v.
    unfold ext_to_geo_base1.
    rewrite ldist.
    do 2 rewrite rdist.
    rewrite mult_lneg.
    rewrite mult_rneg.
    rewrite neg_neg.
    rewrite mult_lneg, mult_rneg.
    rewrite geo_mult_inner_alternating, geo_mult_contract.
    rewrite plus_lid.
    apply module_homomorphism_eq.
    intros x.
    unfold neg at 1 2; cbn.
    unfold linear_trans_neg_base; cbn.
    unfold mult at 1 2, plus at 1 2; cbn.
    unfold linear_trans_plus_base; cbn.
    unfold scalar_mult at 1; cbn.
    unfold linear_trans_scalar_base.
    unfold one at 1; cbn.
    unfold mult at 2; cbn.
    unfold zero at 1; cbn.
    unfold linear_trans_zero_base.
    rewrite geo_mult_inner_add.
    rewrite neg_plus.
    rewrite neg_neg.
    rewrite (plus_comm (-([B|] v v · x))).
    rewrite plus_rlinv.
    rewrite plus_linv.
    reflexivity.
Qed.

Definition ext_to_geo_base2 := make_module_homomorphism
    F
    V
    (algebra_module GG)
    ext_to_geo_base1
    ext_to_geo_base1_plus
    ext_to_geo_base1_scalar.

Definition ext_to_geo_base3 := make_to_ext
    V GG ext_to_geo_base2 ext_to_geo_base_alternating.

Definition ext_to_geo_base :=
    ex_singleton (exterior_universal V ext_to_geo_base3).
Definition ext_to_geo_f_homo := [ext_to_geo_base|].
Definition ext_to_geo_f := algebra_homo_f ext_to_geo_f_homo.

Let EP := ext_plus V.
Let EZ := ext_zero V.
Let EN := ext_neg V.
Let EPA := ext_plus_assoc V.
Let EPC := ext_plus_comm V.
Let EPZ := ext_plus_lid V.
Let EPN := ext_plus_linv V.
Let EM := ext_mult V.
Let EO := ext_one V.
Let EMR := ext_mult_rid V.
Let ES := ext_scalar V.
Let ESO := ext_scalar_id V.
Let ESR := ext_scalar_rdist V.

Existing Instances EP EZ EN EPA EPC EPZ EPN EM EO EMR ES ESO ESR.

Theorem ext_to_geo_f_eq :
    ∀ v, ext_to_geo_f (vector_to_ext V v) = ext_to_geo_base1 v.
Proof.
    apply [|ext_to_geo_base].
Qed.

Theorem ext_to_geo_f_mult :
    ∀ u v, ext_to_geo_f (u * v) = ext_to_geo_f u * ext_to_geo_f v.
Proof.
    apply algebra_homo_mult.
Qed.

Definition ext_to_geo (v : ext V) := ext_to_geo_f v 1 : geo B.

(* end hide *)
Theorem ext_to_geo_plus : ∀ u v,
    ext_to_geo (u + v) = ext_to_geo u + ext_to_geo v.
Proof.
    intros u v.
    unfold ext_to_geo.
    unfold ext_to_geo_f.
    rewrite algebra_homo_plus.
    unfold plus at 1; cbn.
    unfold linear_trans_plus_base.
    reflexivity.
Qed.

Theorem ext_to_geo_scalar : ∀ a v, ext_to_geo (a · v) = a · ext_to_geo v.
Proof.
    intros a v.
    unfold ext_to_geo.
    unfold ext_to_geo_f.
    rewrite algebra_homo_scalar.
    unfold scalar_mult at 1; cbn.
    unfold linear_trans_scalar_base.
    reflexivity.
Qed.

Theorem ext_to_geo_add : ∀ v x, ext_to_geo (vector_to_ext V v * x) =
    -geo_mult_inner v (ext_to_geo x) + vector_to_geo B v * ext_to_geo x.
Proof.
    intros v x.
    unfold ext_to_geo.
    rewrite ext_to_geo_f_mult.
    rewrite ext_to_geo_f_eq.
    unfold mult at 1; cbn.
    unfold linear_trans_mult_base; cbn.
    unfold ext_to_geo_base1; cbn.
    unfold plus at 1; cbn.
    unfold linear_trans_plus_base; cbn.
    reflexivity.
Qed.

Theorem ext_to_geo_neg : ∀ x, ext_to_geo (-x) = -ext_to_geo x.
Proof.
    intros x.
    rewrite <- scalar_neg_one.
    rewrite ext_to_geo_scalar.
    apply scalar_neg_one.
Qed.

Theorem ext_to_geo_zero : ext_to_geo 0 = 0.
Proof.
    rewrite <- (scalar_lanni 0).
    rewrite ext_to_geo_scalar.
    apply scalar_lanni.
Qed.

Theorem ext_to_geo_one : ext_to_geo 1 = 1.
Proof.
    unfold ext_to_geo.
    unfold ext_to_geo_f.
    rewrite algebra_homo_one.
    unfold one at 1; cbn.
    reflexivity.
Qed.

Theorem ext_to_geo_of_scalar : ∀ α,
    ext_to_geo (scalar_to_ext V α) = scalar_to_geo B α.
Proof.
    intros α.
    rewrite scalar_to_ext_one_scalar.
    rewrite ext_to_geo_scalar.
    change 1 with (one (U := ext V)).
    rewrite ext_to_geo_one.
    symmetry; apply scalar_to_geo_one_scalar.
Qed.

Theorem ext_to_geo_vector : ∀ v,
    ext_to_geo (vector_to_ext V v) = vector_to_geo B v.
Proof.
    intros v.
    rewrite <- (mult_rid (vector_to_ext V v)).
    rewrite ext_to_geo_add.
    change 1 with (one (U := ext V)).
    rewrite ext_to_geo_one.
    rewrite mult_rid.
    replace 1 with (scalar_to_geo B 1) by apply scalar_to_geo_one.
    rewrite geo_mult_inner_scalar.
    rewrite neg_zero.
    apply plus_lid.
Qed.

Theorem ext_to_geo_vector2 : ∀ u v,
    ext_to_geo (vector_to_ext V u * vector_to_ext V v) =
    -[B|] u v · 1 + vector_to_geo B u * vector_to_geo B v.
Proof.
    intros u v.
    rewrite ext_to_geo_add.
    rewrite ext_to_geo_vector.
    rewrite geo_mult_inner_vector.
    rewrite scalar_lneg.
    reflexivity.
Qed.
(* begin hide *)

End ExteriorToGeometric.
(* end hide *)


(* * Halting problem for the call-by-value lambda-calculus HaltL  *)

(* * The call-by-value lambda calculus L *)

(* ** Syntax   *)

(* The terms of L are the terms of the full lambda-calculus, using de Bruijn encoding  *)
Inductive term : Type :=
| var (n : nat) : term
| app (s : term) (t : term) : term
| lam (s : term).

(* We define a simple, capturing substitution operation *)
Fixpoint subst (s : term) (k : nat) (u : term) :=
  match s with
      | var n => if Nat.eqb n k then u else var n
      | app s t => app (subst s k u) (subst t k u)
      | lam s => lam (subst s (S k) u)
  end.

(* ** Evaluation   *)

(* Big-step evaluation is weak (no evaluations below abstractions) and call-by-value (arguments are fully evaluated when pased) *)
Inductive eval : term -> term -> Prop :=
| eval_abs s : eval (lam s) (lam s)
| eval_app s u t t' v :
    eval s (lam u) -> eval t t' -> eval (subst u 0 t') v -> eval (app s t) v.

(* The L-halting problem  *)
Definition HaltL (s : term) := exists t, eval s t.

(* Scott encoding of natural numbers  *)
Fixpoint nat_enc (n : nat) :=
  match n with
  | 0 => lam (lam (var 1))
  | S n => lam (lam (app (var 0) (nat_enc n)))
  end.

(* ** L-computable relations  *)

Require Import Vector.

Definition L_computable {k} (R : Vector.t nat k -> nat -> Prop) :=
  exists s, forall v : Vector.t nat k, forall m,
        R v m <->
        eval (Vector.fold_left (fun s n => app s (nat_enc n)) s v) (nat_enc m).


(*
Notes compiled from Studio Episode 5, Lectures 6-7
Template from FRAP Ch 5: Transition Systems
*)
Require Import Frap.

Set Implicit Arguments.

Fixpoint fact (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => fact n' * S n'
  end.

Inductive fact_state :=
| AnswerIs (answer : nat)
| WithAccumulator (input accumulator : nat).

Inductive fact_init (original_input : nat) : fact_state -> Prop :=
| FactInit : fact_init original_input (WithAccumulator original_input 1).

Check fact_init. (* fact_init : nat -> fact_state -> Prop *)
(* so fact_init is a type constructor that takes a natural number, a
*  fact_state, and produces a type whose type is Prop *)

(* Notice the args to a type constructor before the initial colon
*  (original_input above) are automatically arguments to each of
*  the inductive constructors *)

Check (fact_init 2 (AnswerIs 5)).
(* Produces a type whose type is Prop. Happens to be false! *)

Lemma fool :
  fact_init 3 (WithAccumulator 3 1).
Proof.
  Show Proof.
  exact (FactInit 3).
  Restart.
  constructor. (* or find the right constructor automatically *)
  Show Proof.
Qed.

Lemma foo2 :
  not (fact_init 5 (WithAccumulator 3 1)).
Proof.
  Print not.
  unfold not.
  intros.
  invert H. (* find the only way we could have made H, via FactInit *)
Qed.

(*
*  thought: why doesn't Coq just restrict type system so that we can only construct
*           fact_inits via the FactInit constructor?
*
*  ben: we want a language that's strong enough to encode false statements
*)

Inductive fact_final : fact_state -> Prop :=
| FactFinal : forall ans, fact_final (AnswerIs ans).

(* Compare fact_step ... *)

Inductive fact_step : fact_state -> fact_state -> Prop :=
| FactDone : forall acc,
  fact_step (WithAccumulator O acc) (AnswerIs acc)
| FactStep : forall n acc,
  fact_step (WithAccumulator (S n) acc) (WithAccumulator n (acc * S n)).

(* to a more typical definition ... *)

Definition plus : nat -> nat -> nat :=
  (* the actual defn *)
  fun a => fun b => a + b.

(*
Notice fact_step doesn't read as directly. It's a type that takes two values
and produces a type whose type is Prop.

But the only way to construct _values_ that inhibit the type `fact_step s1 s2`
are via the `FactDone` and `FactStep` constructors.

Also, fact_step, FactDone, FactStep are fundamentally different than plus. When
we apply values to the former constructors, we don't compute and return values.
Essentially all that happens when we apply values to the former is that we tag
certain values to have certain types.
*)

Inductive trc {A} (R : A -> A -> Prop) : A -> A -> Prop :=
| TrcRefl : forall x, trc R x x
| TrcFront : forall x y z,
  R x y
  -> trc R y z
  -> trc R x z.
Set Warnings "-notation-overridden".
Notation "R ^*" := (trc R) (at level 0).

(* Now let's use it to execute the factorial program. *)
Example factorial_3' : fact_step^* (WithAccumulator 3 1) (AnswerIs 6).
Proof.
  try constructor. (* fails with "unable to find instance for variable y" *)
  econstructor. (* pretend y exists for a minute *)
  constructor.
  econstructor.
  constructor.
  econstructor.
  constructor.
  econstructor.
  constructor.
  simplify.
  constructor. (* TrcRefl *)
Qed.

(* Or more succinctly: *)
Example factorial_3 : fact_step^* (WithAccumulator 3 1) (AnswerIs 6).
Proof.
  (* repeat can be used to continue trying something until it stops making progress *)
  (* repeat (let x := fresh in assert (x : True) by auto). makes infinite loop! *)
  repeat (econstructor).
Qed.

(* If you have programs that don't terminate,
   an _interpreter_ will not be able to prove all of its semantics.
   Instead, we can use _transisition systems_.  *)
Record trsys state := {
  Initial : state -> Prop;
  Step : state -> state -> Prop
}.

Definition factorial_sys (original_input : nat) : trsys fact_state := {|
  Initial := fact_init original_input;
  Step := fact_step
|}.

(* the {type} curly braces mean the type can be implicit and inferred by type
*  checker.
*
*  to pass in {type} manually, prefix the function by '@'.
*)

Inductive reachable {state} (sys : trsys state) (st : state) : Prop :=
| Reachable : forall st0,
  sys.(Initial) st0
  -> sys.(Step)^* st0 st
  -> reachable sys st.
(*
Even though we use `forall`, we read as `exists`.
*)
Print ex.
(*
Inductive ex (A : Type) (P : A -> Prop) : Prop :=
    ex_intro : forall x : A, P x -> exists y, P y

So to build a _value_ of this type, we pass in _any_ x to ex_intro,
such that P x is true.

This is just because this is how constructors work, they take _any_ values that
their type implies. By also requiring P x, the ability to call ex_intro (P x),
we have shown that such an x does exist!
*)

Lemma foo :
  exists n, n = S O.
Proof.
  exists 1; auto.
Qed.

Definition invariantFor {state} (sys : trsys state) (invariant : state -> Prop) :=
  forall s, sys.(Initial) s
            -> forall s', sys.(Step)^* s s'
                          -> invariant s'.
(*
Q: above, why is sys.(Initial) s necessary in `forall s, sys.(Initial) s` ?
A: look at its definition, this means `forall s that is an initial state of sys`
   so altogether, this is the statement:
   "forall initial states s of sys,
     forall states s' reachable from s,
      invariant holds for s'"
*)

(* for example, trivially, reachability is an invariant ! *)
Lemma bar :
  forall {state} (sys: trsys state),
    invariantFor sys (reachable sys).
Proof.
  intros.
  unfold invariantFor.
  intros.
  (* Notice H and H0 are precisely the arguments of the Reachable constructor
     to create the `reachable sys s'` goal!  *)
  econstructor; eauto.
Qed.

Lemma use_invariant' : forall {state} (sys : trsys state)
  (invariant : state -> Prop) s s',
  invariantFor sys invariant
  -> sys.(Initial) s
  -> sys.(Step)^* s s'
  -> invariant s'.
Proof.
  unfold invariantFor.
  simplify.
  eapply H.
  eassumption.
  assumption.
Qed.

Theorem use_invariant : forall {state} (sys : trsys state)
  (invariant : state -> Prop) s,
  invariantFor sys invariant
  -> reachable sys s
  -> invariant s.
Proof.
  simplify.
  invert H0.
  eapply use_invariant'.
  eassumption.
  eassumption.
  assumption.
Qed.

Lemma invariant_induction' : forall {state} (sys : trsys state)
  (invariant : state -> Prop),
  (forall s, invariant s -> forall s', sys.(Step) s s' -> invariant s')
  -> forall s s', sys.(Step)^* s s'
     -> invariant s
     -> invariant s'.
Proof.
  (* induct 2 inducts on the second inductively defined datatype in the statement,
     in this case:  sys.(Step)^* s s'
   *)
  induct 2; propositional.
  apply IHtrc.
  eapply H; eauto.
  (* Many times this well let Coq find the right arg to H.
     If it doesn't work, we can manually specify, but it might have been better
     to just use apply (H x) in the first place. *)
Qed.

Theorem invariant_induction : forall {state} (sys : trsys state)
  (invariant : state -> Prop),
  (forall s, sys.(Initial) s -> invariant s)
  -> (forall s, invariant s -> forall s', sys.(Step) s s' -> invariant s')
  -> invariantFor sys invariant.
Proof.
  unfold invariantFor; intros.
  eapply invariant_induction'.
  eassumption.
  eassumption.
  apply H.
  assumption.
Qed.

Definition fact_invariant (original_input : nat) (st : fact_state) : Prop :=
  match st with
  | AnswerIs n => fact original_input = n
  | WithAccumulator n acc => fact original_input = acc * fact n
  end.

(*
Invert is very similar to cases or destruct, but it is smarter
in that it can look backwards, looking at constraints in the type signature:

"s is Initial => s was made with fact_init => s looks like WithAccumulator"
*)
Theorem fact_invariant_ok : forall original_input,
  invariantFor (factorial_sys original_input) (fact_invariant original_input).
Proof.
  intros.
  apply invariant_induction; simplify.
  - invert H. simplify. auto.
  - invert H0; simplify; linear_arithmetic.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_8_7.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NCdistinct.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_rectangleparallelogram :
   forall A B C D,
   RE A B C D ->
   PG A B C D.
Proof.
intros.
assert ((Per D A B /\ Per A B C /\ Per B C D /\ Per C D A /\ CR A C B D)) by (conclude_def RE ).
assert (nCol D A B) by (conclude lemma_rightangleNC).
assert (nCol A B C) by (conclude lemma_rightangleNC).
assert (nCol C D A) by (conclude lemma_rightangleNC).
let Tf:=fresh in
assert (Tf:exists M, (BetS A M C /\ BetS B M D)) by (conclude_def CR );destruct Tf as [M];spliter.
assert (~ Meet A B C D).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists P, (neq A B /\ neq C D /\ Col A B P /\ Col C D P)) by (conclude_def Meet );destruct Tf as [P];spliter.
 assert (~ eq A P).
  {
  intro.
  assert (Col C D A) by (conclude cn_equalitysub).
  contradict.
  }
 assert (~ eq D P).
  {
  intro.
  assert (Col A B D) by (conclude cn_equalitysub).
  assert (Col D A B) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (Per B A D) by (conclude lemma_8_2).
 assert (Col B A P) by (forward_using lemma_collinearorder).
 assert (neq P A) by (conclude lemma_inequalitysymmetric).
 assert (Per P A D) by (conclude lemma_collinearright).
 assert (neq P D) by (conclude lemma_inequalitysymmetric).
 assert (Per P D A) by (conclude lemma_collinearright).
 assert (Per A D P) by (conclude lemma_8_2).
 assert (~ Per P A D) by (conclude lemma_8_7).
 contradict.
 }
assert (neq A B) by (forward_using lemma_NCdistinct).
assert (neq C D) by (forward_using lemma_NCdistinct).
assert (neq D C) by (forward_using lemma_NCdistinct).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (Col A B A) by (conclude_def Col ).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Col A B B) by (conclude_def Col ).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col C D C) by (conclude_def Col ).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (Col C D D) by (conclude_def Col ).
assert (BetS D M B) by (conclude axiom_betweennesssymmetry).
assert (Par A B C D) by (conclude_def Par ).
assert (~ Meet A D B C).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists P, (neq A D /\ neq B C /\ Col A D P /\ Col B C P)) by (conclude_def Meet );destruct Tf as [P];spliter.
 assert (~ eq A P).
  {
  intro.
  assert (Col B C A) by (conclude cn_equalitysub).
  assert (Col A B C) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (~ eq B P).
  {
  intro.
  assert (Col A D B) by (conclude cn_equalitysub).
  assert (Col D A B) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (neq P A) by (conclude lemma_inequalitysymmetric).
 assert (Col D A P) by (forward_using lemma_collinearorder).
 assert (Per P A B) by (conclude lemma_collinearright).
 assert (Per C B A) by (conclude lemma_8_2).
 assert (Col C B P) by (forward_using lemma_collinearorder).
 assert (neq P B) by (conclude lemma_inequalitysymmetric).
 assert (Per P B A) by (conclude lemma_collinearright).
 assert (Per B A P) by (conclude lemma_8_2).
 assert (~ Per P B A) by (conclude lemma_8_7).
 contradict.
 }
assert (neq A D) by (forward_using lemma_NCdistinct).
assert (neq B C) by (forward_using lemma_NCdistinct).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (Col A D A) by (conclude_def Col ).
assert (Col A D D) by (conclude_def Col ).
assert (Col B C B) by (conclude_def Col ).
assert (Col B C C) by (conclude_def Col ).
assert (Par A D B C) by (conclude_def Par ).
assert (PG A B C D) by (conclude_def PG ).
close.
Qed.

End Euclid.


Require Import PArith.
Require Import ZArith.
Require Import FunctionalExtensionality.
Require Import ClassicalFacts.
Require Import Relations.
Require Import RelationClasses.
Require Import EquivDec.
Require Import List.
From sflib Require Import sflib.

Require Import PromisingArch.lib.Basic.

Set Implicit Arguments.

Class orderC (A:Type) (EQ LE: relation A) (join: forall (a b:A), A) (bot: A) `{_: PartialOrder A EQ LE} := mk {
  join_l: forall a b, LE a (join a b);
  join_r: forall a b, LE b (join a b);
  join_assoc: forall a b c, EQ (join (join a b) c) (join a (join b c));
  join_comm: forall a b, EQ (join a b) (join b a);
  join_spec:
    forall a b c
      (AC: LE a c)
      (BC: LE b c),
      LE (join a b) c;

  bot_spec: forall a, LE bot a;
}.

Definition ifc (A:Type) `{_: orderC A} (cond:bool) (a:A): A :=
  if cond then a else bot.

Definition joins (A:Type) `{_: orderC A} (l:list A): A :=
  List.fold_right join bot l.

Lemma join_le (A:Type) (eq le:relation A) `{_: orderC A eq le}
      a b c d
      (AC: le a c)
      (BD: le b d):
  le (join a b) (join c d).
Proof.
  apply join_spec.
  - etrans; eauto using join_l.
  - etrans; eauto using join_r.
Qed.

Lemma bot_join (A:Type) (eq le: relation A) `{_: orderC A eq le}
      a:
  eq (join a bot) a.
Proof.
  antisym.
  - eapply join_spec; eauto.
    + refl.
    + apply bot_spec.
  - eapply join_l.
Qed.

Lemma joins_le A (eq le: relation A) `{_: orderC A eq le}
      (a:A) (l:list A)
      (IN: In a l):
  le a (joins l).
Proof.
  revert IN. induction l; ss. i. des.
  - subst. apply join_l.
  - etrans; eauto. apply join_r.
Qed.

Lemma joins_spec A (eq le: relation A) `{_: orderC A eq le}
      (l:list A) (b:A)
      (LE: forall a (IN: In a l), le a b):
  le (joins l) b.
Proof.
  revert LE. induction l; ss.
  { i. apply bot_spec. }
  i. apply join_spec.
  - apply LE. left. ss.
  - apply IHl. auto.
Qed.

Definition equiv (A:Type) `{_: Equivalence A} := R.
Definition le (A:Type) `{_: orderC A} := LE.
Definition join (A:Type) `{_: orderC A} := join.
Definition bot (A:Type) `{_: orderC A} := bot.

Definition fun_add A B `{_: EqDec A} (a:A) (b:B) (f:A -> B): A -> B :=
  fun x => if x == a then b else f x.
#[export]
Hint Unfold fun_add: core.

Lemma fun_add_spec A B `{_: EqDec A} a (b:B) f x:
  (fun_add a b f) x = if x == a then b else f x.
Proof. refl. Qed.

Definition fun_eq A B `{_: Equivalence B} (f g: A -> B): Prop :=
  forall a, R (f a) (g a).
#[export]
Hint Unfold fun_eq: core.

Definition fun_le A B `{_: orderC B} (f g: A -> B): Prop :=
  forall a, LE (f a) (g a).
#[export]
Hint Unfold fun_le: core.

Definition fun_join A B `{_: orderC B} (f g: A -> B) :=
  fun a => join (f a) (g a).
#[export]
Hint Unfold fun_join: core.

Definition fun_bot A B `{_: orderC B} := fun (_:A) => bot.
#[export]
Hint Unfold fun_bot: core.

#[export]
Program Instance fun_equiv A B `{_: Equivalence B}: Equivalence (fun_eq (A:=A) (B:=B)).
Next Obligation. ii. refl. Qed.
Next Obligation. ii. symmetry. ss. Qed.
Next Obligation. ii. etrans; eauto. Qed.

#[export]
Program Instance fun_preorder A B `{_: orderC B}: PreOrder (fun_le (A:=A) (B:=B)).
Next Obligation. ii. refl. Qed.
Next Obligation. ii. etrans; eauto. Qed.

#[export]
Program Instance fun_partialorder A B `{_: orderC B}: @PartialOrder (A -> B) (fun_eq (A:=A) (B:=B)) _ (fun_le (A:=A) (B:=B)) _.
Next Obligation.
  econs.
  - econs; ii.
    + eapply (H (x a)) in H1. inv H1. ss.
    + eapply (H (x a)) in H1. inv H1. ss.
  - ii. antisym; apply H1.
Qed.

#[export]
Program Instance fun_order A B `{_: orderC B}:
  @orderC
    (A -> B)
    (fun_eq (A:=A) (B:=B))
    (fun_le (A:=A) (B:=B))
    (fun_join (A:=A) (B:=B))
    (fun_bot (A:=A) (B:=B))
    (fun_equiv A)
    (fun_preorder A)
    (fun_partialorder (A:=A) (B:=B)).
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  ii. apply join_l.
Qed.
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  ii. apply join_r.
Qed.
Next Obligation.
  unfold fun_eq, fun_le, fun_join, fun_bot.
  i. eauto using join_assoc.
Qed.
Next Obligation.
  unfold fun_eq, fun_le, fun_join, fun_bot.
  i. eauto using join_comm.
Qed.
Next Obligation.
  unfold fun_eq, fun_le, fun_join, fun_bot.
  eauto using join_spec.
Qed.
Next Obligation.
  unfold fun_eq, fun_le, fun_join, fun_bot.
  eauto using bot_spec.
Qed.

#[export]
Program Instance fun_eq_partialorder A B `{_: orderC B eq}: @PartialOrder (A -> B) eq _ (fun_le (A:=A) (B:=B)) _.
Next Obligation.
  econs.
  - i. subst. econs; refl.
  - i. funext. i. antisym; apply H1.
Qed.

#[export]
Program Instance fun_eq_order A B `{_: orderC B eq}:
  @orderC
    (A -> B)
    eq
    (fun_le (A:=A) (B:=B))
    (fun_join (A:=A) (B:=B))
    (fun_bot (A:=A) (B:=B))
    eq_equivalence
    (fun_preorder A)
    (fun_eq_partialorder (A:=A) (B:=B)).
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  ii. apply join_l.
Qed.
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  ii. apply join_r.
Qed.
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  funext. eauto using join_assoc.
Qed.
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  funext. eauto using join_comm.
Qed.
Next Obligation.
  unfold fun_le, fun_join.
  eauto using join_spec.
Qed.
Next Obligation.
  unfold fun_le, fun_join, fun_bot.
  eauto using bot_spec.
Qed.

Inductive opt_eq X `{_: Equivalence X}: forall (a b: option X), Prop :=
| opt_eq_None: opt_eq None None
| opt_eq_Some a b (EQX: equiv a b): opt_eq (Some a) (Some b)
.
#[export]
Hint Constructors opt_eq: core.

Inductive opt_le X `{_: orderC X}: forall (a b: option X), Prop :=
| opt_le_None b: opt_le None b
| opt_le_Some a b (LEX: le a b): opt_le (Some a) (Some b)
.
#[export]
Hint Constructors opt_le: core.

Definition opt_join X `{_: orderC X}(a b:option X) :=
  match a, b with
  | None, _ => b
  | _, None => a
  | Some a, Some b => Some (join a b)
  end.
#[export]
Hint Unfold opt_join: core.

Definition opt_bot X `{_: orderC X}: option X := None.
#[export]
Hint Unfold opt_bot: core.

#[export]
Program Instance opt_equiv X `{_: Equivalence X}: Equivalence (opt_eq (X:=X)).
Next Obligation. ii. destruct x; eauto. econs. refl. Qed.
Next Obligation. ii. inv H0; eauto. econs. symmetry. ss. Qed.
Next Obligation. ii. inv H0; inv H1; eauto. econs. etrans; eauto. Qed.

#[export]
Program Instance opt_eqdec X `{_: EqDec X eq}: EqDec (option X) eq.
Next Obligation.
  destruct x, y;
    (try by left);
    (try by right; i; ss).
  destruct (H x x0).
  - left. f_equal. ss.
  - right. intro Y. inv Y. intuition.
Defined.

#[export]
Program Instance opt_preorder X `{_: orderC X}: PreOrder (opt_le (X:=X)).
Next Obligation. ii. destruct x; eauto. econs. refl. Qed.
Next Obligation. ii. inv H1; inv H2; eauto. econs. etrans; eauto. Qed.

#[export]
Program Instance opt_partialorder X `{_: orderC X}: PartialOrder (opt_eq (X:=X)) (opt_le (X:=X)).
Next Obligation.
  econs.
  - i. inv H1.
    + econs; ss.
    + econs; econs; rewrite EQX; refl.
  - i. inv H1. inv H2; inv H3; econs. antisym; eauto.
Qed.

#[export]
Program Instance opt_order X `{_: orderC X}:
  @orderC
    (option X)
    (opt_eq (X:=X))
    (opt_le (X:=X))
    (opt_join (X:=X))
    (opt_bot (X:=X))
    (opt_equiv)
    (opt_preorder)
    (opt_partialorder (X:=X)).
Next Obligation.
  destruct a, b; ss; econs.
  - apply join_l.
  - refl.
Qed.
Next Obligation.
  destruct a, b; ss; econs.
  - apply join_r.
  - refl.
Qed.
Next Obligation.
  destruct  a, b, c; econs; try by refl.
  apply join_assoc.
Qed.
Next Obligation.
  destruct  a, b; econs; try by refl.
  apply join_comm.
Qed.
Next Obligation.
  inv AC; inv BC; econs; eauto. apply join_spec; ss.
Qed.
Next Obligation.
  econs.
Qed.

Definition prop_le (a b:Prop): Prop := a -> b.

Definition prop_join (a b:Prop): Prop := a \/ b.

Definition prop_bot: Prop := False.

#[export]
Program Instance prop_preorder: PreOrder prop_le.
Next Obligation. ii. ss. Qed.
Next Obligation. ii. auto. Qed.

#[export]
Program Instance prop_partialorder: PartialOrder eq prop_le.
Next Obligation.
  econs.
  - i. inv H. econs; ss.
  - i. inv H. propext. econs; eauto.
Qed.

#[export]
Program Instance prop_order:
  @orderC
    Prop
    eq
    prop_le
    prop_join
    prop_bot
    eq_equivalence
    prop_preorder
    prop_partialorder.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  intuition.
Qed.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  intuition.
Qed.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  propext. intuition.
Qed.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  propext. intuition.
Qed.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  intuition.
Qed.
Next Obligation.
  unfold prop_le, prop_join, prop_bot in *.
  intuition.
Qed.

Definition bool_le (a b:bool): Prop := a -> b.

Definition bool_join (a b:bool): bool := a || b.

Definition bool_bot: bool := false.

#[export]
Program Instance bool_preorder: PreOrder bool_le.
Next Obligation. ii. ss. Qed.
Next Obligation. ii. auto. Qed.

#[export]
Program Instance bool_partialorder: PartialOrder eq bool_le.
Next Obligation.
  unfold bool_le in *.
  econs.
  - i. inv H. econs; ss.
  - i. inv H. destruct x, x0; intuition.
Qed.

#[export]
Program Instance bool_order:
  @orderC
    bool
    eq
    bool_le
    bool_join
    bool_bot
    eq_equivalence
    bool_preorder
    bool_partialorder.
Next Obligation.
  unfold bool_le, bool_join, bool_bot in *.
  destruct a, b; intuition.
Qed.
Next Obligation.
  unfold bool_le, bool_join, bool_bot in *.
  destruct a, b; intuition.
Qed.
Next Obligation.
  unfold bool_le, bool_join, bool_bot in *.
  destruct a, b, c; intuition.
Qed.
Next Obligation.
  unfold bool_le, bool_join, bool_bot in *.
  destruct a, b; intuition.
Qed.
Next Obligation.
  unfold bool_le, bool_join, bool_bot in *.
  destruct a, b, c; intuition.
Qed.

Definition unit_le (a b:unit): Prop := True.

Definition unit_join (a b:unit): unit := tt.

Definition unit_bot: unit := tt.

#[export]
Program Instance unit_preorder: PreOrder unit_le.
Next Obligation. ii. ss. Qed.

#[export]
Program Instance unit_partialorder: PartialOrder eq unit_le.
Next Obligation.
  ii. econs; ss. destruct x, x0; ss.
Qed.

#[export]
Program Instance unit_order:
  @orderC
    unit
    eq
    unit_le
    unit_join
    unit_bot
    eq_equivalence
    unit_preorder
    unit_partialorder.
Next Obligation.
  unfold unit_le, unit_join, unit_bot in *.
  destruct a, b; intuition.
Qed.
Next Obligation.
  unfold unit_le, unit_join, unit_bot in *.
  destruct a, b; intuition.
Qed.
Next Obligation.
  unfold unit_le, unit_join, unit_bot in *.
  ss.
Qed.


From Hammer Require Import Hammer.

Require Import NZAxioms NZBase NZMul NZOrder.

Module Type NZAddOrderProp (Import NZ : NZOrdAxiomsSig').
Include NZBaseProp NZ <+ NZMulProp NZ <+ NZOrderProp NZ.

Theorem add_lt_mono_l : forall n m p, n < m <-> p + n < p + m.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_lt_mono_l".
intros n m p; nzinduct p. now nzsimpl.
intro p. nzsimpl. now rewrite <- succ_lt_mono.
Qed.

Theorem add_lt_mono_r : forall n m p, n < m <-> n + p < m + p.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_lt_mono_r".
intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_lt_mono_l.
Qed.

Theorem add_lt_mono : forall n m p q, n < m -> p < q -> n + p < m + q.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_lt_mono".
intros n m p q H1 H2.
apply lt_trans with (m + p);
[now apply add_lt_mono_r | now apply add_lt_mono_l].
Qed.

Theorem add_le_mono_l : forall n m p, n <= m <-> p + n <= p + m.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_le_mono_l".
intros n m p; nzinduct p. now nzsimpl.
intro p. nzsimpl. now rewrite <- succ_le_mono.
Qed.

Theorem add_le_mono_r : forall n m p, n <= m <-> n + p <= m + p.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_le_mono_r".
intros n m p. rewrite (add_comm n p), (add_comm m p); apply add_le_mono_l.
Qed.

Theorem add_le_mono : forall n m p q, n <= m -> p <= q -> n + p <= m + q.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_le_mono".
intros n m p q H1 H2.
apply le_trans with (m + p);
[now apply add_le_mono_r | now apply add_le_mono_l].
Qed.

Theorem add_lt_le_mono : forall n m p q, n < m -> p <= q -> n + p < m + q.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_lt_le_mono".
intros n m p q H1 H2.
apply lt_le_trans with (m + p);
[now apply add_lt_mono_r | now apply add_le_mono_l].
Qed.

Theorem add_le_lt_mono : forall n m p q, n <= m -> p < q -> n + p < m + q.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_le_lt_mono".
intros n m p q H1 H2.
apply le_lt_trans with (m + p);
[now apply add_le_mono_r | now apply add_lt_mono_l].
Qed.

Theorem add_pos_pos : forall n m, 0 < n -> 0 < m -> 0 < n + m.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_pos_pos".
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono.
Qed.

Theorem add_pos_nonneg : forall n m, 0 < n -> 0 <= m -> 0 < n + m.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_pos_nonneg".
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono.
Qed.

Theorem add_nonneg_pos : forall n m, 0 <= n -> 0 < m -> 0 < n + m.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_nonneg_pos".
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono.
Qed.

Theorem add_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n + m.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_nonneg_nonneg".
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono.
Qed.

Theorem lt_add_pos_l : forall n m, 0 < n -> m < n + m.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.lt_add_pos_l".
intros n m. rewrite (add_lt_mono_r 0 n m). now nzsimpl.
Qed.

Theorem lt_add_pos_r : forall n m, 0 < n -> m < m + n.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.lt_add_pos_r".
intros; rewrite add_comm; now apply lt_add_pos_l.
Qed.

Theorem le_lt_add_lt : forall n m p q, n <= m -> p + m < q + n -> p < q.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.le_lt_add_lt".
intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption].
contradict H2. rewrite nlt_ge. now apply add_le_mono.
Qed.

Theorem lt_le_add_lt : forall n m p q, n < m -> p + m <= q + n -> p < q.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.lt_le_add_lt".
intros n m p q H1 H2. destruct (le_gt_cases q p); [| assumption].
contradict H2. rewrite nle_gt. now apply add_le_lt_mono.
Qed.

Theorem le_le_add_le : forall n m p q, n <= m -> p + m <= q + n -> p <= q.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.le_le_add_le".
intros n m p q H1 H2. destruct (le_gt_cases p q); [assumption |].
contradict H2. rewrite nle_gt. now apply add_lt_le_mono.
Qed.

Theorem add_lt_cases : forall n m p q, n + m < p + q -> n < p \/ m < q.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_lt_cases".
intros n m p q H;
destruct (le_gt_cases p n) as [H1 | H1]; [| now left].
destruct (le_gt_cases q m) as [H2 | H2]; [| now right].
contradict H; rewrite nlt_ge. now apply add_le_mono.
Qed.

Theorem add_le_cases : forall n m p q, n + m <= p + q -> n <= p \/ m <= q.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_le_cases".
intros n m p q H.
destruct (le_gt_cases n p) as [H1 | H1]. now left.
destruct (le_gt_cases m q) as [H2 | H2]. now right.
contradict H; rewrite nle_gt. now apply add_lt_mono.
Qed.

Theorem add_neg_cases : forall n m, n + m < 0 -> n < 0 \/ m < 0.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_neg_cases".
intros n m H; apply add_lt_cases; now nzsimpl.
Qed.

Theorem add_pos_cases : forall n m, 0 < n + m -> 0 < n \/ 0 < m.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_pos_cases".
intros n m H; apply add_lt_cases; now nzsimpl.
Qed.

Theorem add_nonpos_cases : forall n m, n + m <= 0 -> n <= 0 \/ m <= 0.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_nonpos_cases".
intros n m H; apply add_le_cases; now nzsimpl.
Qed.

Theorem add_nonneg_cases : forall n m, 0 <= n + m -> 0 <= n \/ 0 <= m.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.add_nonneg_cases".
intros n m H; apply add_le_cases; now nzsimpl.
Qed.

Lemma le_exists_sub : forall n m, n<=m -> exists p, m == p+n /\ 0<=p.
Proof. hammer_hook "NZAddOrder" "NZAddOrder.NZAddOrderProp.le_exists_sub".
intros n m H. apply le_ind with (4:=H). solve_proper.
exists 0; nzsimpl; split; order.
clear m H. intros m H (p & EQ & LE). exists (S p).
split. nzsimpl. now f_equiv. now apply le_le_succ_r.
Qed.

End NZAddOrderProp.


From Autosubst Require Export Autosubst.
From fae_gtlc_mu.cast_calculus Require Export types.
From fae_gtlc_mu Require Import prelude.
Require Coq.Logic.JMeq.

(* This file defines the alternative consistency relation (fig 9 in paper).
   The relation is inspired by the way in which casts are decomposed in terms of each other, and shall be used to define the backtranslation of casts between two consistent types. *)

Inductive alternative_consistency (A : list (type * type)) : type → type -> Type :=
  (** ground and star *)
  (* downcasting from star to ground *)
  | atomic_Unknown_Ground τG
      (G : Ground τG) :
      alternative_consistency A TUnknown τG
  (* upcasting from ground to star *)
  | atomic_Ground_Unknown τG
      (G : Ground τG) :
      alternative_consistency A τG TUnknown
  (** factorization through ground types, first direction *)
  | factorUp_Ground τ τG
      (pτnG : (Ground τ -> False))
      (pτnStar : not (τ = TUnknown))
      (pτSτG : (get_shape τ = Some τG))
      (pτConsτG : alternative_consistency A τ τG)
      (pτGConsStar : alternative_consistency A τG TUnknown)
    : alternative_consistency A τ TUnknown
  (** factorization through ground types, second direction *)
  | factorDown_Ground τ τG
      (pτnG : (Ground τ -> False))
      (pτnStar : not (τ = TUnknown))
      (pτSτG : (get_shape τ = Some τG))
      (pStarConsτG : alternative_consistency A TUnknown τG)
      (pτGConsτ : alternative_consistency A τG τ) :
      alternative_consistency A TUnknown τ
  (** identiy casts between Base and TUnknown *)
  | atomic_Base :
      alternative_consistency A TUnit TUnit
  | atomic_Unknown :
      alternative_consistency A TUnknown TUnknown
  (** between types of same structure *)
  (* Sum *)
  | throughSum τ1 τ1' τ2 τ2'
      (pCons31 : alternative_consistency A τ1 τ1')
      (pCons24 : alternative_consistency A τ2 τ2') :
      alternative_consistency A (TSum τ1 τ2) (TSum τ1' τ2')
  (* Prod *)
  | throughProd τ1 τ1' τ2 τ2'
      (pCons31 : alternative_consistency A τ1 τ1')
      (pCons24 : alternative_consistency A τ2 τ2') :
      alternative_consistency A (TProd τ1 τ2) (TProd τ1' τ2')
  (* Arrow *)
  | throughArrow τ1 τ1' τ2 τ2'
      (pCons31 : alternative_consistency A τ1' τ1)
      (pCons24 : alternative_consistency A τ2 τ2') :
      alternative_consistency A (TArrow τ1 τ2) (TArrow τ1' τ2')
  (** exposing recursive calls *)
  | exposeRecursiveCAll τl τr
      (pμτlμτrnotA : (TRec τl, TRec τr) ∉ A)
      (pUnfτlUnfτr : alternative_consistency ((TRec τl, TRec τr) :: A) τl.[TRec τl/] τr.[TRec τr/]) :
      alternative_consistency A (TRec τl) (TRec τr)
  (** using recursive calls *)
  | atomic_UseRecursion τl τr i
      (pμτlμtrinA : A !! i = Some (TRec τl, TRec τr)) :
      alternative_consistency A (TRec τl) (TRec τr).


Set Automatic Coercions Import.

Require Import List Ensembles util stability flow list_util containers
  geometry hs_solver concrete.
Require decreasing_exponential_flow EquivDec.
Set Implicit Arguments.

Module dec_exp_flow := decreasing_exponential_flow.

(* Locations *)

Inductive Location: Set := Heat | Cool | Check.

Instance Location_eq_dec: EquivDec.EqDec Location eq.
Proof. hs_solver. Defined.

Instance locations: ExhaustiveList Location :=
  { exhaustive_list := Heat :: Cool :: Check :: nil }.
Proof. hs_solver. Defined.

Lemma NoDup_locations: NoDup locations.
Proof. hs_solver. Qed.

(* States *)

Let Point := geometry.Point.
Let State : Type := (Location * Point)%type.

Definition point: State -> Point := snd.
Definition location: State -> Location := fst.
Definition clock: State -> CR := fst ∘ point.
Definition temp: State -> CR := snd ∘ point.

(* Invariant *)

Open Local Scope CR_scope.

Definition invariant (s: State): Prop :=
  0 <= clock s /\
  match location s with
  | Heat => temp s <= '10 /\ clock s <= '3
  | Cool => '5 <= temp s
  | Check => clock s <= 1
  end.

Lemma invariant_wd: forall l l', l = l' ->
  forall (p p': Point), p[=]p' -> (invariant (l, p) <-> invariant (l', p')).
Proof. unfold invariant.
  admit. (* grind ltac:(destruct l').*) (* TODO *)
Qed.

Lemma invariant_stable s: Stable (invariant s).
Proof. revert s. intros [l p]. destruct l; intros; unfold invariant; simpl location; auto. Qed.

(* Initial *)

Definition initial (s: State): Prop :=
  location s = Heat /\
  '5 <= temp s /\ temp s <= '10 /\
  clock s == 0.

Lemma initial_invariant (s: State): initial s -> invariant s.
Proof. unfold initial, invariant.
  admit. (* hs_solver. *) (* TODO *)
Qed.

(* Flow *)

Definition clock_flow (l: Location): Flow CRasCSetoid := flow.positive_linear.f.

Definition temp_flow (l: Location): Flow CRasCSetoid :=
  match l with
  | Heat => flow.scale.flow ('2) flow.positive_linear.f
  | Cool => dec_exp_flow.f
  | Check => flow.scale.flow ('(1#2)) dec_exp_flow.f
  end.

Definition flow l := product_flow (clock_flow l) (temp_flow l).

(* Reset *)

Definition reset (l l': Location) (p: Point): Point :=
  ( match l, l' with
    | Cool, Heat | Heat, Check | Check, Heat => 0
    | _, _ => fst p
    end
  , snd p).

(* Guard *)

Definition guard (s: State) (l: Location): Prop :=
  match location s, l with
  | Heat, Cool => '9 <= temp s
  | Cool, Heat => temp s <= '6
  | Heat, Check => '2 <= clock s
  | Check, Heat => '(1#2) <= clock s
  | _, _ => False
  end.

(* Concrete system itself *)

Definition system: System :=
  Build_System
  _ _
  NoDup_locations
  initial_invariant
  invariant_wd
  invariant_stable
  flow
  guard
  reset.

(* Safety *)

  Definition unsafe: Ensemble (concrete.State system) :=
    fun s => temp s <= '(45#10).

  Definition UnsafeUnreachable: Prop := unsafe ⊆ unreachable.
    (* This is proved in safe.v. *)

  (* We can also phrase the property less negatively: *)

  Definition safe := Complement unsafe.

  Definition ReachablesSafe: Prop := reachable ⊆ safe.

  (* Of course, the negative version implies the positive one: *)

  Goal UnsafeUnreachable -> ReachablesSafe.
  Proof. intros H s A B. apply H with s; assumption. Qed.


From Coq Require Import ssreflect.
Require Import Word.

(* An efficient implementation of `word n -> V`. *)
Fixpoint memory n (V : Type) : Type := match n with
    | 0 => V
    | S n => memory n (V * V)
end.

Fixpoint read {n V} (w : word n) : memory n V -> V :=
match w with
| trivial => fun mem => mem
| push_low (false,w) => fun mem => fst (read w mem)
| push_low (true,w) => fun mem => snd (read w mem)
end.

Fixpoint modify {n V} (w : word n) (f : V -> V) : memory n V -> memory n V :=
match w in word n return memory n V -> memory n V with
| trivial => fun mem => f mem
| push_low (false,w) => modify w (fun mem => (f (fst mem), snd mem))
| push_low (true,w) => modify w (fun mem => (fst mem, f (snd mem)))
end.

Definition write {n V} (w : word n) (x : V) : memory n V -> memory n V :=
modify w (fun _ => x).

Fixpoint from_fn {n} : forall {V}, (word n -> V) -> memory n V :=
match n with
| 0 => fun _ f => f trivial
| S n => fun V f => @from_fn n _ (fun w => (f (push_low (false, w)), f (push_low (true, w))))
end.

(* Theorems *)

Theorem read_from_fn {n V addr} {f : word n -> V}: read addr (from_fn f) = f addr.
Proof.
    move: V addr f; elim: n => [|n IH] V addr f.
    - by rewrite [addr]word0.
    - rewrite -(push_pop_low addr); move: (pop_low addr) => [b w].
        by case b; simpl; rewrite IH.
Qed.

Theorem eq_read {n V} {mem1 mem2 : memory n V} :
    (forall w, read w mem1 = read w mem2) -> mem1 = mem2.
Proof.
    move: V mem1 mem2; elim: n => [|n IH] V mem1 mem2 H.
    - exact (H trivial).
    - apply: IH => w.
        apply: injective_projections.
        + exact (H (push_low (false, w))).
        + exact (H (push_low (true, w))).
Qed.

Theorem from_fn_read {n V} {mem : memory n V} : from_fn (fun w => read w mem) = mem.
Proof.
    apply: eq_read => w.
    apply: read_from_fn.
Qed.

Theorem read_modify {n V addr1 addr2 f} {mem : memory n V} :
    read addr1 (modify addr2 f mem) =
    if Word.eqb addr2 addr1 then f (read addr1 mem) else read addr1 mem.
Proof.
    move: V addr1 addr2 f mem; elim: n => [|n IH] V addr1 addr2 f mem.
    - by rewrite [addr1]word0 [addr2]word0.
    - rewrite -(push_pop_low addr1) -(push_pop_low addr2).
        move: (pop_low addr1) (pop_low addr2) => [b1 w1] [b2 w2].
        simpl; case b1; case b2; simpl; rewrite IH; case (Word.eqb w2 w1); done.
Qed.

Theorem read_write {n V addr1 addr2 v} {mem : memory n V} :
    read addr1 (write addr2 v mem) =
    if Word.eqb addr2 addr1 then v else read addr1 mem.
Proof.
    apply: read_modify.
Qed.

(* Writing down a ROM by hand *)

Definition concat {n V} : memory n V * memory n V -> memory (S n) V.
Proof.
    move: V; elim: n => [|n IH] V; simpl.
    - done.
    - apply IH.
Defined.

Definition new n {A V} (f : A -> V) :
    nat_rect
        (fun _ => Type -> Type)
        (fun T => A -> T)
        (fun _ f T => f (f T))
        n
        (memory n V).
Proof.
    have: memory n V -> memory n V by []; move: {-1}(memory n V).
    elim: n => [|n IH] X g; simpl.
    - by move /f /g.
    - apply: (IH) => a.
        apply: IH => b.
        apply: g.
        apply: concat.
        exact (a,b).
Defined.

(* Testing new *)
Goal new 3 (fun x => x) 1 2 3 4 5 6 7 8 = (((1,2),(3,4)),((5,6),(7,8))).
reflexivity. Qed.


(**

Syntax of the calculus of constructions as in Streicher
"Semantics of Type Theory" formalized as a multisorted
binding signature.

Written by: Anders Mörtberg, 2017

version for simplified notion of HSS by Ralph Matthes (2022, 2023)
the file is identical to the homonymous file in the parent directory, except for importing files from the present directory

*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.Combinatorics.StandardFiniteSets.
Require Import UniMath.Combinatorics.Lists.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Slice.
Require Import UniMath.CategoryTheory.Chains.Chains.
Require Import UniMath.CategoryTheory.Chains.OmegaCocontFunctors.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.products.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.slicecat.

Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SumOfSignatures.
Require Import UniMath.SubstitutionSystems.BinProductOfSignatures.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.
Require Import UniMath.SubstitutionSystems.SignatureExamples.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.BindingSigToMonad.
Require Import UniMath.SubstitutionSystems.MonadsMultiSorted.
Require Import UniMath.SubstitutionSystems.MultiSorted.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MultiSortedMonadConstruction.

Local Open Scope cat.

Section ccs.

(* Preliminary stuff, upstream? *)
Local Infix "::" := (@cons _).
Local Notation "[]" := (@nil _) (at level 0, format "[]").
Local Notation "C / X" := (slice_cat C X).
Local Notation "a + b" := (setcoprod a b) : set.

(* Was there a general version of this somewhere? *)
Definition six_rec {A : UU} (a b c d e f : A) : stn 6 -> A.
Proof.
induction 1 as [n p].
induction n as [|n _]; [apply a|].
induction n as [|n _]; [apply b|].
induction n as [|n _]; [apply c|].
induction n as [|n _]; [apply d|].
induction n as [|n _]; [apply e|].
induction n as [|n _]; [apply f|].
induction (nopathsfalsetotrue p).
Defined.

(** We assume a two element set of sorts *)
Definition sort : hSet := @tpair _ (λ X, isaset X) bool isasetbool.

Definition ty : sort := true.
Definition el : sort := false.

Local Definition HSET_over_sort : category.
Proof.
exists (HSET / sort).
now apply has_homsets_slice_precat.
Defined.

Let HSET_over_sort2 := [HSET/sort,HSET_over_sort].

(** The grammar of expressions and objects from page 157:
<<
E ::= (Πx:E) E                product of types
    | Prop                    type of propositions
    | Proof(t)                type of proofs of proposition t

t ::= x                       variable
    | (λx:E) t                function abstraction
    | App([x:E] E, t, t)      function application
    | (∀x:E) t                universal quantification
>>

We refer to the first syntactic class as ty and the second as el. We first reformulate the rules as
follows:
<<
A,B ::= Π(A,x.B)              product of types
      | Prop                  type of propositions
      | Proof(t)              type of proofs of proposition t

t,u ::= x                     variable
      | λ(A,x.t)              function abstraction
      | App(A,x.B,t,u)        function application
      | ∀(A,x.t)              universal quantification
>>

This grammar then gives 6 operations, to the left as Vladimir's restricted 2-sorted signature (where
el is 0 and ty is 1) and to the right as a multisorted signature:

((0, 1), (1, 1), 1)                 = (([],ty), ([el], ty), ty)
(1)                                 = ([],ty)
((0, 0), 1)                         = (([], el), ty)
((0, 1), (1, 0), 0)                 = (([], ty), ([el], el), el)
((0, 1), (1, 1), (0, 0), (0, 0), 0) = (([], ty), ([el], ty), ([], el), ([], el), el)
((0, 1), (1, 0), 0)                 = (([], ty), ([el], el), el)

*)

(** The multisorted signature of CC-S *)
Definition CCS_Sig : MultiSortedSig sort.
Proof.
use make_MultiSortedSig.
- exact (stn 6,,isasetstn 6).
- apply six_rec.
  + exact ((([],,ty) :: (cons el [],,ty) :: nil),,ty).
  + exact ([],,ty).
  + exact ((([],,el) :: nil),,ty).
  + exact ((([],,ty) :: (cons el [],,el) :: nil),,el).
  + exact ((([],,ty) :: (cons el [],,ty) :: ([],,el) :: ([],,el) :: nil),,el).
  + exact ((([],,ty) :: (cons el [],,el) :: nil),,el).
Defined.

Definition CCS_Signature : Signature (HSET / sort) _ _ :=
  MultiSortedSigToSignature sort CCS_Sig.

Let Id_H := Id_H _ (BinCoproducts_HSET_slice sort).

Definition CCS_Functor : functor HSET_over_sort2 HSET_over_sort2 :=
  Id_H CCS_Signature.

Lemma CCS_Functor_Initial : Initial (FunctorAlg CCS_Functor).
Proof.
apply SignatureInitialAlgebraSetSort.
apply is_omega_cocont_MultiSortedSigToSignature.
apply slice_precat_colims_of_shape, ColimsHSET_of_shape.
Defined.

Definition CCS_Monad : Monad (HSET / sort) :=
  MultiSortedSigToMonad sort CCS_Sig.

(** Extract the constructors from the initial algebra *)
Definition CCS : HSET_over_sort2 :=
  alg_carrier _ (InitialObject CCS_Functor_Initial).

Let CCS_mor : HSET_over_sort2⟦CCS_Functor CCS,CCS⟧ :=
  alg_map _ (InitialObject CCS_Functor_Initial).

Let CCS_alg : algebra_ob CCS_Functor :=
  InitialObject CCS_Functor_Initial.

Local Lemma BP : BinProducts [HSET_over_sort,HSET].
Proof.
apply BinProducts_functor_precat, BinProductsHSET.
Defined.

Local Notation "'Id'" := (functor_identity HSET_over_sort).
Local Notation "x ⊗ y" := (BinProductObject _ (BP x y)).

(** The variables *)
Definition var_map : HSET_over_sort2⟦Id,CCS⟧ :=
  BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · CCS_mor.

Definition Pi_source (X : HSET_over_sort2) : HSET_over_sort2 :=
  ((X ∙ proj_functor sort ty) ⊗ (sorted_option_functor sort el ∙ X ∙ proj_functor sort ty)) ∙ hat_functor sort ty.

(** The Pi constructor *)
Definition Pi_map : HSET_over_sort2⟦Pi_source CCS,CCS⟧ :=
  (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 0)%stn)
    · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
    · CCS_mor.

Definition Prop_source (X : HSET_over_sort2) : HSET_over_sort2 :=
  constant_functor (slice_cat HSET _) HSET 1%CS  ∙ hat_functor sort ty.

Definition Prop_map : HSET_over_sort2⟦Prop_source CCS,CCS⟧.
Proof.
use ((CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 1)%stn) · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)) · CCS_mor).
Defined.

Definition Proof_source (X : HSET_over_sort2) : HSET_over_sort2 :=
  (X ∙ proj_functor sort el) ∙ hat_functor sort ty.

(** The Proof constructor *)
Definition Proof_map : HSET_over_sort2⟦Proof_source CCS,CCS⟧ :=
  (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 2)%stn)
    · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
    · CCS_mor.

Definition lam_source (X : HSET_over_sort2) : HSET_over_sort2 :=
  ((X ∙ proj_functor sort ty) ⊗ (sorted_option_functor sort el ∙ X ∙ proj_functor sort el)) ∙ hat_functor sort el.

(** The lambda constructor *)
Definition lam_map : HSET_over_sort2⟦lam_source CCS,CCS⟧ :=
  (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 3)%stn)
    · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
    · CCS_mor.

Definition app_source (X : HSET_over_sort2) : HSET_over_sort2 :=
  ((X ∙ proj_functor sort ty) ⊗
  ((sorted_option_functor sort el ∙ X ∙ proj_functor sort ty) ⊗
  ((X ∙ proj_functor sort el) ⊗
   (X ∙ proj_functor sort el)))) ∙ hat_functor sort el.

(** The app constructor *)
Definition app_map : HSET_over_sort2⟦app_source CCS,CCS⟧ :=
  (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 4)%stn)
    · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
    · CCS_mor.

Definition forall_source (X : HSET_over_sort2) : HSET_over_sort2 :=
  ((X ∙ proj_functor sort ty) ⊗ (sorted_option_functor sort el ∙ X ∙ proj_functor sort el)) ∙ hat_functor sort el.

(** The ∀ constructor *)
Definition forall_map : HSET_over_sort2⟦forall_source CCS,CCS⟧ :=
  (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 5)%stn)
    · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
    · CCS_mor.

Definition make_CCS_Algebra X
  (fvar    : HSET_over_sort2⟦Id,X⟧)
  (fPi     : HSET_over_sort2⟦Pi_source X,X⟧)
  (fProp   : HSET_over_sort2⟦Prop_source X,X⟧)
  (fProof  : HSET_over_sort2⟦Proof_source X,X⟧)
  (flam    : HSET_over_sort2⟦lam_source X,X⟧)
  (fapp    : HSET_over_sort2⟦app_source X,X⟧)
  (fforall : HSET_over_sort2⟦forall_source X,X⟧) : algebra_ob CCS_Functor.
Proof.
apply (tpair _ X).
use (BinCoproductArrow _ fvar).
use CoproductArrow.
intros i.
induction i as [n p].
repeat (induction n as [|n _]; try induction (nopathsfalsetotrue p)).
- exact fPi.
- exact fProp.
- exact fProof.
- exact flam.
- simpl in fapp.
  exact fapp.
- exact fforall.
Defined. (* This is slow *)

(** The recursor for ccs *)
Definition foldr_map X
  (fvar    : HSET_over_sort2⟦Id,X⟧)
  (fPi     : HSET_over_sort2⟦Pi_source X,X⟧)
  (fProp   : HSET_over_sort2⟦Prop_source X,X⟧)
  (fProof  : HSET_over_sort2⟦Proof_source X,X⟧)
  (flam    : HSET_over_sort2⟦lam_source X,X⟧)
  (fapp    : HSET_over_sort2⟦app_source X,X⟧)
  (fforall : HSET_over_sort2⟦forall_source X,X⟧) :
  algebra_mor _ CCS_alg (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall).
Proof.
apply (InitialArrow CCS_Functor_Initial (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall)).
Defined.

End ccs.


MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Examples.

Coq < Require Import Classical.

Coq < Variables P Q : Prop.
P is assumed
Q is assumed

Coq < Goal ((P -> Q) /\ ~Q) -> ~P.
1 subgoal

  P : Prop
  Q : Prop
  ============================
   (P -> Q) /\ ~ Q -> ~ P

Unnamed_thm < intros.
1 subgoal

  P : Prop
  Q : Prop
  H : (P -> Q) /\ ~ Q
  ============================
   ~ P

Unnamed_thm < elim H.
1 subgoal

  P : Prop
  Q : Prop
  H : (P -> Q) /\ ~ Q
  ============================
   (P -> Q) -> ~ Q -> ~ P

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  H : (P -> Q) /\ ~ Q
  H0 : P -> Q
  ============================
   ~ Q -> ~ P

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  H : (P -> Q) /\ ~ Q
  H0 : P -> Q
  H1 : ~ Q
  ============================
   ~ P

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <


Require Import prelude chapter2.

Definition isProp P := Π (x y: P), x = y.
Definition isSet A := Π (x y: A), isProp (x = y).

Existing Class isProp.
Existing Class isSet.

Hint Extern 2 (isProp (_ = _ :> ?A)) => eapply (_ : @isSet A) : typeclass_instances.

Local Open Scope path_scope.

(* Example 3.1.5 *)
Definition isSet_prod `{isSet A} `{isSet B} : isSet (A × B).
Proof. intros x y p q.
  refine (pair_eq_unique p · ap _ _ · (pair_eq_unique q)⁻¹).
  apply pair⁼; simpl.
  split. apply (_ : isSet A). apply (_ : isSet B).
Defined.
Hint Extern 2 (isSet (_ × _)) => eapply @isSet_prod : typeclass_instances.

Definition isSet_sig `(B:A → 𝓤) `{isSet A} `{Π a, isSet (B a)} : isSet (sig B).
Proof. intros x y p q.
  refine (sig_eq_unique p · ap _ _ · (sig_eq_unique q)⁻¹).
  apply sig⁼. exists ((_ : isSet A) _ _ _ _). apply (_ : isSet (B _)).
Defined.
Hint Extern 2 (isSet (sig _)) => eapply @isSet_sig : typeclass_instances.

(* Example 3.1.6 *)
Definition isSet_Pi {WF:Funext} `(B:A → 𝓤) {H:Π x, isSet (B x)} : isSet (Π x, B x).
Proof. intros f g p q.
  refine (funext_unique p · ap _ _ · (funext_unique q)⁻¹).
  apply funext. intro x. apply (_ : isSet (B _)).
Defined.
Hint Extern 2 (isSet (Π x, _)) => eapply @isSet_Pi : typeclass_instances.

Definition isProp_0 : isProp 𝟎 := λ x, match x with end.

Hint Extern 2 (isProp 𝟎) => eexact isProp_0 : typeclass_instances.
Hint Extern 2 (isProp 𝟏) => eexact @unit_eq_intro : typeclass_instances.

(* Lemma 3.3.3 *)
Definition prop_equiv {P Q} `{isProp P} `{isProp Q} : (P → Q) → (Q → P) → P ≃ Q.
Proof. refine (λ f g, Equiv_from_qinv_alt f g _ _).
+ intros q. apply (_ : isProp Q).
+ intros p. apply (_ : isProp P).
Defined.

(* Lemma 3.3.2 *)
Definition inh_prop_equiv_1 `{!isProp P} (x₀:P) : P ≃ 𝟏
:= prop_equiv (λ _, ★) (λ _, x₀).

(* Lemma 3.3.4 *)
Definition prop_is_set A : isProp A → isSet A.
Proof. intros f x.
  set (g := f x).
  assert (Π y z (p:y = z :> A), p = (g y)⁻¹ · g z) as H.
  + intros y z p. apply (cancelL (g y)).
    refine (_ · (concat_p_Vp _ _)⁻¹).
    refine (_ · apd g p).
    exact (transport_Id_ax _ _ _)⁻¹.
  + intros y p q. exact (H _ _ _ · (H _ _ _)⁻¹).
Defined.
Hint Extern 8 (isSet _) => eapply @prop_is_set : typeclass_instances.

Tactic Notation "funext" simple_intropattern(a) := apply weak_funext; intros a.
Tactic Notation "funext" simple_intropattern(a) simple_intropattern(b) := funext a; funext b.

(* Lemma 3.3.5 *)
Definition isProp_isProp `{!Funext} A : isProp (isProp A).
Proof. intros f g. funext x y. apply (_ : isSet A). Defined.
Hint Extern 2 (isProp (isProp _)) => eapply @isProp_isProp : typeclass_instances.

Definition isProp_isSet `{!Funext} A : isProp (isSet A).
Proof. intros f g. funext x y. funext p q. apply (_ : isSet (x = y)). Defined.
Hint Extern 2 (isProp (isSet _)) => eapply @isProp_isSet : typeclass_instances.

Definition isProp_prod A B {HA:isProp A} {HB:isProp B} : isProp (A × B).
Proof. intros x y. apply pair⁼. split; apply (_ : isProp _). Defined.
Hint Extern 2 (isProp (_ × _)) => eapply @isProp_prod : typeclass_instances.

Definition isProp_Pi {WF:Funext} `(B:A → 𝓤) {H:Π x, isProp (B x)} : isProp (Π x, B x).
Proof. intros f g. funext x. apply H. Defined.
Hint Extern 2 (isProp (Π x, _)) => eapply @isProp_Pi : typeclass_instances.
Hint Extern 2 (isProp (¬ _)) => eapply @isProp_Pi : typeclass_instances.

(* Lemma 3.5.1 *)
Definition subtype_eq `{P:A → 𝓤} {H:Π a, isProp (P a)} (x y : sig P) : x.1 = y.1 → x = y
:= λ p, sig⁼ (p; H _ _ _).

Module Export PropTrunc.
  Private Inductive merely (A:𝓤) : 𝓤 := hexists : A → merely A.
  Arguments hexists {A} _.
  Axiom merely_isprop : Π A, isProp (merely A).

  Definition rec_merely {A} `{H:isProp B} (f:A → B) : merely A → B
  := λ x, match x with hexists a => λ _, f a end H.
End PropTrunc.

Existing Class merely.

Hint Extern 2 (isProp (merely _)) => eapply @merely_isprop : typeclass_instances.

Delimit Scope merely_scope with merely.
Bind Scope merely_scope with merely.
Notation "| x |" := (hexists x) (at level 10, format "| x |") : merely_scope.
Notation "‖ x ‖" := (merely x) (at level 10, format "‖ x ‖") : type_scope.

(* Lemma 3.9.1 *)
Definition prop_equiv_merely P `{!isProp P} : P ≃ ‖P‖
:= prop_equiv hexists (rec_merely id).

Definition unique_choice `(P:A → 𝓤) {H1:Π x, isProp (P x)} {H2:Π x, ‖P x‖}
  : Π x, P x
:= λ x, rec_merely id (H2 x).

(* Section 3.11: Contractibility *)
Definition isContr A := Σ (a:A), Π x, a = x.
Existing Class isContr.

(* Lemma 3.11.3 (i) ⇒ (ii) *)
Definition contr_is_prop A : isContr A → isProp A.
Proof. intros [a contr] x y. exact ((contr x)⁻¹ · (contr y)). Defined.
Hint Extern 8 (isProp _) => eapply @contr_is_prop : typeclass_instances.

(* Lemma 3.11.3 (ii) ⇒ (i) *)
Definition contr_prop `{H:isProp A} (a:A) : isContr A := (a; H a).

(* Lemma 3.11.3 (i) ⇒ (iii) *)
Definition contr_equiv_1 A {H:isContr A} : A ≃ 𝟏
:= inh_prop_equiv_1 H.1 .

(* Lemma 3.11.3 (iii) ⇒ (i) *)
Definition equiv_1_contr A : A ≃ 𝟏 → isContr A.
Proof. intros f. exists (inv_fun f ★). intros x.
  exact (ap (inv_fun f) unit⁼ · equiv_linv_hom f x).
Defined.

(* Lemma 3.11.4 *)
Definition isProp_isContr `{!Funext} A : isProp (isContr A).
Proof. intros c c'. pose proof (_:isContr A).
  apply sig_eq_intro. destruct c as [a p], c' as [a' p']. simpl.
  exists (p a'). apply (_ : isProp (Π x, a' = x) ).
Defined.
Hint Extern 2 (isProp (isContr _)) => eapply @isProp_isContr : typeclass_instances.

(* Corollary 3.11.5 *)
Definition isContr_isContr `{!Funext} A : isContr A → isContr (isContr A)
:= λ x, contr_prop x.
Hint Extern 2 (isContr (isContr _)) => eapply @isContr_isContr : typeclass_instances.

Definition isContr_unit : isContr 𝟏 := (★; λ x, unit⁼).
Hint Extern 2 (isContr 𝟏) => eapply isContr_unit : typeclass_instances.

Definition isContr_prod A B : isContr A → isContr B → isContr (A × B).
Proof. intros x y. exists (x.1, y.1). intro p. apply pair⁼; simpl. exact (x.2 _, y.2 _). Defined.
Hint Extern 2 (isContr (_ × _)) => eapply isContr_prod : typeclass_instances.

(* Lemma 3.11.6 *)
Definition isContr_Pi `{!Funext} `(P:A → 𝓤) : (Π a, isContr (P a)) → isContr (Π a, P a)
:= λ f, contr_prop (λ a, (f a).1).
Hint Extern 2 (isContr (Π x, _)) => eapply @isContr_Pi : typeclass_instances.

(* Lemma 3.11.7 *)
Definition isContr_retract `(r:A → B) (s:B → A) (ε: r ∘ s ~ id) : isContr A → isContr B.
Proof. intro H. exists (r (H.1)). intro b. exact (ap r (H.2 _) · ε b). Defined.

(* Lemma 3.11.8 *)
Definition isContr_based_paths `(a:A) : isContr (Σ x, a = x).
Proof. exists (a; refl). intros [x p].
  apply sig_eq_intro. exists p. simpl.
  exact (transport_Id_ax a p 1 · concat_1p _).
Defined.

(* Lemma 3.11.9 (i) *)
Definition sig_contr_pr1_isequiv `(P:A → 𝓤) : (Π x, isContr (P x)) → isequiv (pr₁ (P:=P)).
Proof. intros f. apply qinv_to_isequiv. exists (λ a, (a; (f a).1)). split.
+ intros a. exact refl.
+ intros x. unfold compose, id. apply sig_eq_intro. exists refl. exact ((f x.1).2 _).
Defined.
Hint Extern 2 (isequiv pr₁) => eapply @sig_contr_pr1_isequiv : typeclass_instances.

Definition transport_contr_loop `(P:A → 𝓤) {H:isSet A} `(p:a = a) (y:P a) : p # y = y
:= ap (λ q, q # y) (H a a p 1).

(* Lemma 3.11.9 (ii) *)
Definition sig_contr_index `(P:A → 𝓤) {H:isProp A} a : sig P ≃ P a.
Proof.
  set (f := λ (p: sig P), H p.1 a # p.2).
  set (g := λ (y: P a), (a; y)).
  apply (Equiv_from_qinv_alt f g).
+ intro y. exact (transport_contr_loop P _ _).
+ intros [a' y]. apply sig_eq_intro. unfold f; simpl.
  exists (H a a'). exact ((transport_pp P _ _ _)⁻¹ · transport_contr_loop P _ _).
Defined.

(* Lemma 3.11.10 *)
Definition isProp_alt A : (Π x y, isContr (x = y :> A)) → isProp A
:= λ f x y, (f x y).1 .

Definition isProp_isContr_eq A : isProp A → Π x y, isContr (x = y :> A).
Proof. intros f x y. exists (f x y). apply (_ : isSet A). Defined.
Hint Extern 2 (isContr (_ = _)) => eapply @isProp_isContr_eq : typeclass_instances.


(*|
##########################################
How can I generalise Coq proofs of an iff?
##########################################

:Link: https://stackoverflow.com/q/65588333
|*)

(*|
Question
********

A common kind of proof I have to make is something like
|*)

Context (T : Type) (Q : T -> T -> T -> Prop) (P : T -> T -> Prop).
Lemma my_lemma : forall y,
    (forall x x', Q x x' y) -> (forall x x', P x y <-> P x' y).
Proof.
  intros y Q_y.
  split.
  - (* some proof using Q *) admit. (* .none *)

  - (* the same proof using Q, but x and x' are swapped *) admit. (* .none *)
Abort. (* .none *)

(*|
where ``Q`` is itself some kind of iff-shaped predicate.

My problem is that the proofs of ``P x y -> P x' y`` and ``P x' y -> P
x y`` are often basically identical, with the only difference between
that the roles of ``x`` and ``x'`` are swapped between them. Can I ask
Coq to transform the goal into

.. code-block:: coq

    forall x x', P x y -> P x' y

which then generalises to the iff case, so that I don't need to repeat
myself in the proof?

I had a look through the standard library, the tactic index, and some
SO questions, but nothing told me how to do this.
|*)

(*|
Answer
******

In mathematics, one often can make "assumptions" "*without loss of
generality*" (WLOG) to simplify proofs of this kind. In your example,
you could say "assume *without loss of generality* that ``P x y``
holds. To prove ``P x y <-> P x' y`` it is sufficient to prove ``P x'
y``."

If you are using ``ssreflect``, you have the `wlog tactic
<https://coq.inria.fr/refman/proof-engine/ssreflect-proof-language.html#variants-the-suff-and-wlog-tactics>`__.

You essentially ``cut`` in another goal which can easily solve your
goal. You can also do it with standard tactics like ``assert`` or
``enough`` (which is like ``assert`` but the proof obligations are in
the other order).

An example to show what I mean: below I just want to show the
implication in one direction, because it can easily solve the
implication in the other direction (with ``firstorder``).
|*)

Goal forall x y, P x y <-> P y x.
  enough (forall x y, P x y -> P y x) by firstorder.

(*|
Now I just have to show the goal in one direction, because it implies
the real goal's both directions.

For more about WLOG see for instance `1
<https://www.cl.cam.ac.uk/~jrh13/papers/wlog.pdf>`__
|*)