(*
 * Copyright (c) 2020 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
(** remove printing -> *)

(**
This tutorial assumes basic understanding of functional programming and logic.
A good way to revise these concepts is to read the first 5 chapters
(Preface,..., Polymorphism and Higher order functions) of the
#Software Foundations# book

Just like that book, this tutorial is produced from Coq .v files, which can be found in _cpp2v/doc_.
If you want to play with the Coq code in this tutorial, you may want to open the .v source file
in a Coq editor, instead of opening the html output in a web brower.
In the html, identifiers are hyperlinked to their definition.
Your Coq editor may also provide a facility to jump to definition (M-. in emacs (company-coq mode))
*)
Require Import bedrock.lang.cpp.
Import cQp_compat.

Section with_Sigma.
Context `{Sigma: cpp_logic} {CU:genv}.
Import primitives.

Variable x:ptr.
Variable y:ptr.
Variable r:Rep.
Variable q:Qp.

(** * |->
*)

(**
Separation logic assertions are of type [mpred].
The main assertion is of the form:
 *)
Example ex: mpred := x |-> r.

(**
As declared above, [x] is a pointer (memory location)
and [r] is a memory representation. [ex] asserts that x is a valid location and that location contains
the memory representation r.

As an example, [ex2] below asserts that the memory location [x] contains
the long value 2. [ex2] also asserts ownership fraction q
 ownership over the memory location [x].
*)
Example ex2 : mpred := x |-> (longR q 2).

(** the right hand side of [_ |-> _] has type [Rep] which stands for
memory representations. *)
Definition ex3 : Rep :=  longR 1 2.

(**
[q] of type [Qp] is a positive rational number.
In our context, it must be in range (0,1].
[1] implies full ownership, which can be used to update or delete
the memory location. lesser ownership can be used to read the location. *)

Example eFrac1 : Qp := 1.
Example eFrac2 : Qp := 2/4.

Variable z:Z.
(**
There are similar primitives for other primitive types as well: *)
Example e_schar : Rep := scharR q z. (** similarly, [ucharR] for unsigned *)
Example e_int : Rep := intR q z. (** similarly, [sintR] and [uingR] *)
Example e_short : Rep := shortR q z. (** similarly, [ushortR] and [sshortR] *)
Example e_long : Rep := longR q z. (** similarly, [ulongR] and [slongR] *)
Example e_longlong : Rep := longlongR q z. (** similarly, [ulonglongR] and [slonglongR] *)
Example e_i8 : Rep  := i8R q z. (** similarly, [int16], [int32], [uint64]. Prefix 'u' for the unsigned variants *)

(** Character types work a little bit differently because they are represented
    in an architecture-indepenent way as *unsigned* numbers *)
Example e_char : Rep := charR q 10.
Example e_wchar : Rep := wcharR q 10.
Example e_char32 : Rep := char32R q 10.
Example e_char16 : Rep := char16R q 10.
Example e_char8 : Rep := char8R q 10.

Variable b: bool.
Example e11: bool:=true.
Example e10 : Rep := boolR (cQp.m (1/2)) b.

(**
Some locations (e.g. the "next" field of linked list) store pointers.
[ptrR] can be used to describe the memory representation of pointers.
 *)
Variable ctype:type.
Variable p:ptr.
Example eptr : Rep := ptrR<ctype> q p.

(**
[ctype] is the C++ type of the pointer.
Click at [type] to see the current definition of C++ types.
For example, below, we are saying that the pointer is of type
signed 64 bit (long * ) *)
Example eptr2 : Rep := ptrR<Ti64> q p.

(**
To refer to (named) struct types, use the [Tnamed] constructor,
which takes as argument the mangled name of the class/struct.
We can use the notations defined in the names file to write
unmangled names. More about this in the next chapters.
*)
Example eptr3 : Rep := ptrR<Tnamed "listZ5"> q p.

(** * Separation
*)
Variable pl: mpred.
Variable pr: mpred.

(** Any two [mpred]s can be combined together using the infix operator [**]
to get an [mpred]:
*)
Example e12: mpred := pl ** pr.
(** [e12] asserts that [pl] and [pr] hold *separately*, meaning that their ownership
of resources is disjoint. For example, the following assertion is invalid because
both the left side and the right side talk about the same (1) ownership of [x].
*)
Example e13 : mpred := x |-> (intR 1 4) ** x |-> (intR 1 4).

(** We can prove that [e13] implies [False] ([_ |-- _] should be read as "entails" ("implies")):*)
Lemma l1: e13 |-- [| False |].
Abort.

(** However, the following is fine: *)
Example e14 : mpred := x |-> intR ((cQp.m (1/2))) 4 ** x |-> intR ((cQp.m (1/2))) 4.

(** if [x] and [y] are different locations, the following is also fine *)
Example e15 : mpred := x |-> intR 1 4 ** y |-> intR (cQp.m (1/2)) 4.

(** This separateness part of the [**] (instead of vanilla conjunction) gives the main modularity properties of separation logic.
For example, if a thread [t1] has precondition [P1] and postcondition [Q2],
and a thread [t2] has precondition [P2] and postcondition [Q2],
the thread [t1 || t2] ([t1] and [t2] running in parallel) has precondition
[P1**P2] and postcondition [Q1**Q2].
Also, separation logic has the frame property: if we can prove a precondition [P] and postcondition [Q] for a function [f],
then for any assertion [H] separate from [P] and [Q], the [P**H] and [Q**H]
are also valid pre- and post- conditions respectively.
*)

(** * Structured Reps
*)

(**
In the examples above (e.g. [ex]), in the [x |-> r] notation, the LHS ([x]) must be an *absolute* location,
RHS is a [Rep] and the whole term ([x |-> r]) has type [mpred].
We have also overloaded the same notation to the case where [x] is *relative* location, e.g. an offset
defined by a field or an array index and type (size of elements) of array.
*)

Variable struct_field struct_field2 : field.

Example structRep1 : Rep := _field struct_field |-> r.

(**
Note that in this case, the whole term [structRep] has type [Rep] (memory representation) instead of [mpred].
Such [Rep]s typically describe the memory representation of some (yet to be plugged in) *absolute* location holding structured data, e.g. structs, arrays, classes.

Note that a [Rep] is like "Even", it isn't meaningful to say "Even is true",
it is only meaningful to say "Even n" is true. Similarly, it isn't meaningful
to say that a [Rep] holds, until you say what location it holds on.
 *)

Variable this:ptr.

Example e17 : mpred := this |-> structRep1.

(** we can also unfold [structRep1] above and write *)

Example e18 : mpred := this |-> (_field struct_field |-> r).

(**
Because the notation [_ |-> _] is declared right associative, we can drop the parens: *)

Example e19 : mpred := this |-> _field struct_field |-> r.

(**
Note that the [**] notation is overloaded to work on [Rep]s as well as [mpred]s;
however, the meaning is intuitively the same. That is, the following [Rep]
states that the relative locations are disjoint (i.e. for any *single* absolute
location [l], [l ., struct_field |-> r ** l ., struct_field2 |-> r]).
*)

Example e20 : Rep := (_field struct_field |-> r) ** (_field struct_field2 |-> r).

(** More examples in the next two chapters. Parentheses are optional above because
the precedence between [_ ** _] and [_ |-> _] has been defined appropriately. *)

(** * Magic Wand *)

(**
The following assertion asserts that
you have the resources
of [pr] "minus" the resources in [pl].
*)

Example wand1 : mpred := pl -* pr.

(**
The main reasoning rule for this construct is the following, which says that once you separately get the missing piece, you get the whole thing back.:
*)

Check @bi.wand_elim_r mpredI.

(**  * Pure Assertions
*)

(**
Some assertions are pure in the sense that they
are not asserting anything about the current state
of memory or devices. Examples:
*)

Example pure1 : Prop := 1=1.

(** the following is a false assertion, but a valid assertion nevertheless *)
Example pure2 : Prop := 1=2.

(** In Coq, pure assertions have type [Prop]. However, in function specs, pre and post conditions have type [mpred]. To convert an [Prop] to an [mpred], we put them inside [| _ |] *)

Definition pureMpred : mpred := [| 1=1 |].

(*
TO Add:

Exists

Forall

Best practices:
think about finiteness of words
pattern match on return value

*)
End with_Sigma.


From Hammer Require Import Hammer.

From Fermat4 Require Export Diophantus20.

Lemma fermat4_weak:
~ exists x : Z, exists y : Z, exists z : Z,
0 < x /\ 0 < y /\ 0 < z /\ rel_prime y z /\ distinct_parity y z /\
x * x * x * x + y * y * y * y = z * z * z * z.
Proof. hammer_hook "Fermat4" "Fermat4.fermat4_weak".
intro; elim_hyps; rename x0 into y; rename x1 into z;
cut ((z * z + y * y) * (z * z - y * y) = x * x * (x * x)).
intro; elim (diophantus20_equiv y z); auto with zarith.
generalize (Zmult_lt_0_compat _ _ H H); intro;
generalize (Zmult_lt_0_compat _ _ H6 H6); clear H6; intro;
rewrite <- H5 in H6; generalize (Z.lt_gt _ _ H0); intro;
cut (z * z + y * y > 0); auto with zarith; intro;
generalize (Z.lt_gt _ _ H6); intro; generalize (Zmult_gt_0_reg_l _ _ H8 H9);
intro; generalize (Z.gt_lt _ _ H10); intro; cut (y < z); auto with zarith.
split;
[ rewrite H5; apply Z.ge_le; apply sqr_pos
| exists (x * x); intuition ].
replace ((z * z + y * y) * (z * z - y * y)) with
(z * z * z * z - y * y * y * y); try solve [ ring ]; rewrite <- H4; ring.
Qed.

Lemma fermat4:
~(exists x : Z, exists y : Z, exists z : Z,
0 < x /\ 0 < y /\ 0 < z /\
x * x * x * x + y * y * y * y = z * z * z * z).
Proof. hammer_hook "Fermat4" "Fermat4.fermat4".
intro; elim_hyps; rename x0 into y; rename x1 into z;
elim (Zgcd_spec y z); intros; elim_hyps; elim (gcd_rel_prime _ _ _ H3);
intros; elim_hyps; rewrite H5 in H2; rewrite H6 in H2;
cut (x * x * x * x = ((x0 * x0 * x0 * x0) * (x2 * x2 * x2 * x2 -
x1 * x1 * x1 * x1)));
[ intro; rewrite (Zmult_comm (x0 * x0 * x0 * x0)) in H8;
generalize (Zdivide_intro _ _ _ H8); intro;
generalize (divide_4 _ _ H9); clear H9; intro; destruct H9 as (q,H9);
rewrite H9 in H8; rewrite H9 in H; rewrite H5 in H0;
rewrite H6 in H1; generalize H4; clear H4; intro;
elim (Zle_lt_or_eq _ _ H4); clear H4; intro; try (rewrite <- H4 in H;
auto with zarith); rewrite Zmult_comm in H0; rewrite Zmult_comm in H1;
generalize (Zmult_lt_0_reg_r _ _ H4 H); clear H; intro;
generalize (Zmult_lt_0_reg_r _ _ H4 H0); clear H0; intro;
generalize (Zmult_lt_0_reg_r _ _ H4 H1); clear H1; intro;
cut (q * q * q * q + x1 * x1 * x1 * x1 = x2 * x2 * x2 * x2);
[ clear x y z x0 H3 H5 H6 H2 H9 H8 H4; intro
| replace (q * x0 * (q * x0) * (q * x0) * (q * x0)) with
(q * q * q * q * (x0 * x0 * x0 * x0)) in H8; try solve [ ring ];
cut (x0 * x0 * x0 * x0 > 0);
[ intro; apply Zcompare_Eq_eq; rewrite (Zmult_compare_compat_r
(q * q * q * q + x1 * x1 * x1 * x1) (x2 * x2 * x2 * x2) _ H10);
elim (Zcompare_Eq_iff_eq ((q * q * q * q + x1 * x1 * x1 * x1) *
(x0 * x0 * x0 * x0)) (x2 * x2 * x2 * x2 * (x0 * x0 * x0 * x0)));
intros; apply H12; replace ((q * q * q * q + x1 * x1 * x1 * x1) *
(x0 * x0 * x0 * x0)) with (q * q * q * q * (x0 * x0 * x0 * x0) +
x1 * x1 * x1 * x1 * (x0 * x0 * x0 * x0)); try solve [ ring ];
rewrite H8; ring
| auto with zarith ] ]
| replace (x0 * x0 * x0 * x0 * (x2 * x2 * x2 * x2 - x1 * x1 * x1 * x1))
with (x0 * x2 * (x0 * x2) * (x0 * x2) * (x0 * x2) -
x0 * x1 * (x0 * x1) * (x0 * x1) * (x0 * x1)); auto with zarith; ring ].
elim (relp_parity _ _ H7); intro;
[ apply fermat4_weak; exists q; exists x1; exists x2; intuition
| unfold both_odd in H3; elim_hyps;
rewrite <- (Zmult_assoc (q * q) q q) in H2;
rewrite <- (Zmult_assoc (x1 * x1) x1 x1) in H2;
rewrite <- (Zmult_assoc (x2 * x2) x2 x2) in H2;
cut (is_pytha (q * q) (x1 * x1) (x2 * x2));
try (unfold is_pytha, pos_triple; solve [ intuition ]); intro;
elim (pytha_thm1 _ _ _ H5); clear H5; intros; elim_hyps;
[ rewrite <- Zmult_assoc in H10; generalize (Zeven_def2 _ (ex_intro
(fun x => x1 * x1 = 2 * x) (x3 * (x * x0)) H10)); clear H10; intro;
generalize (Zeven_sqr2 _ H10); clear H10; intro;
generalize (Zeven_not_Zodd _ H10); auto
| unfold cond_pq, cond_pqb in H9; elim_hyps;
cut (Zeven q); try (apply Zeven_sqr2; apply Zeven_def2;
exists (x3 * x * x0); rewrite H5; ring); intro;
cut (distinct_parity q x2); try (unfold distinct_parity; tauto);
intro; cut (rel_prime q x2);
[ intro; rewrite (Zmult_assoc (x2 * x2)) in H2; apply fermat4_weak;
exists x1; exists q; exists x2; intuition; rewrite <- H2; ring
| elim (Z.eq_dec x3 1); intro;
[ rewrite a in H5; rewrite a in H6; rewrite Zmult_1_r in H5;
rewrite Zmult_1_l in H6; rewrite Zmult_assoc in H5; apply prop3;
rewrite H5; rewrite H6; apply relp_pq2; assumption
| elimtype False; cut (x3 <> (-1)); auto with zarith; intro;
cut (x3 | x1 * x1); try (exists (x0 * x0 - x * x); rewrite H10;
ring); intro; cut (x3 | x2 * x2); try (exists (x * x + x0 * x0);
rewrite H6; ring); intro;
generalize (not_rel_prime2 _ _ _ H18 H19 b H17); intro;
generalize (prop2 _ _ H7); auto ] ] ] ].
Qed.


(*
Copyright 2017 IMDEA Software Institute
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)

From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq.
From fcsl Require Import pred ordtype pcm unionmap.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(******************************************************************************)
(* This file implementations of Canonical structure lemmas (a.k.a. overloaded *)
(* lemmas) for automating three tasks:                                        *)
(*                                                                            *)
(* 1. checking if implications of the form valid e1 -> valid e2 hold by       *)
(* deciding if the terms in e2 are all contained in e1                        *)
(*                                                                            *)
(* 2. checking if dom_eq e1 e2 holds by cancelling the common terms, to       *)
(*    obtain residuals rs1 and rs2, and then issuing a subgoal dom_eq rs1     *)
(*    rs2.                                                                    *)
(*                                                                            *)
(* 3. checking if the union e is undef, because it contains duplicate         *)
(*    pointers or an undef                                                    *)
(******************************************************************************)

(* For each task, we have two implementations: a naive and a                  *)
(* sophisticated one. The lemmas validO, domeqO, invalidO are the naive       *)
(* ones, and validX, domeqX, invalidX are the sophisticated ones. I keep      *)
(* both O/X versions for now, for experimentation purposes, but               *)
(* eventually should retain only validX and domeqX.                           *)

(* First, two general helper concepts for searching in sequences. They will   *)
(* be useful in syntactifying the expressions e1 and e2 for both tasks.       *)
(* The concepts are:                                                          *)
(*                                                                            *)
(* - onth: returns None to signal that an element is not found prefix:        *)
(* - will be used for growing interpretation contexts                         *)

Section Helpers.
Variable A : Type.

Fixpoint onth (s : seq A) n : option A :=
  if s is x::sx then if n is nx.+1 then onth sx nx else Some x else None.

Definition prefix s1 s2 :=
  forall n x, onth s1 n = some x -> onth s2 n = some x.

(* Lemmas *)

Lemma size_onth s n : n < size s -> exists x, onth s n = Some x.
Proof.
elim: s n=>[//|a s IH] [|n] /=; first by exists a.
by rewrite -(addn1 n) -(addn1 (size s)) ltn_add2r; apply: IH.
Qed.

Lemma onth_size s n x : onth s n = Some x -> n < size s.
Proof. by elim: s n=>[//|a s IH] [//|n]; apply: IH. Qed.

Lemma prefix_refl s : prefix s s.
Proof. by move=>n x <-. Qed.

Lemma prefix_trans s2 s1 s3 : prefix s1 s2 -> prefix s2 s3 -> prefix s1 s3.
Proof. by move=>H1 H2 n x E; apply: H2; apply: H1. Qed.

Lemma prefix_cons x s1 s2 : prefix (x :: s1) (x :: s2) <-> prefix s1 s2.
Proof. by split=>E n; [apply: (E n.+1) | case: n]. Qed.

Lemma prefix_cons' x y s1 s2 :
        prefix (x :: s1) (y :: s2) -> x = y /\ prefix s1 s2.
Proof. by move=>H; case: (H 0 x (erefl _)) (H)=>-> /prefix_cons. Qed.

Lemma prefix_size s1 s2 : prefix s1 s2 -> size s1 <= size s2.
Proof.
elim: s1 s2=>[//|a s1 IH] [|b s2] H; first by move: (H 0 a (erefl _)).
by rewrite ltnS; apply: (IH _ (proj2 (prefix_cons' H))).
Qed.

Lemma prefix_onth s t x : x < size s -> prefix s t -> onth s x = onth t x.
Proof.
elim:s t x =>[//|a s IH] [|b t] x H1 H2; first by move: (H2 0 a (erefl _)).
by case/prefix_cons': H2=><- H2; case: x H1=>[|n] //= H1; apply: IH.
Qed.

End Helpers.

Hint Resolve prefix_refl : core.

Lemma onth_mem (A : eqType) (s : seq A) n x : onth s n = Some x -> x \in s.
Proof.
by elim: s n=>//= a s IH [[->]|n /IH]; rewrite inE ?eq_refl // orbC => ->.
Qed.

(* Context structure for reflection of unionmap expressions.  We         *)
(* reflect the keys and the variables of the map expression.  (The       *)
(* variables are all expressions that are not recognized as a key, or as *)
(* a disjoint union).  We reflect disjoint union as a sequence.          *)
(*                                                                       *)
(* The context of keys is thus seq K. The context of vars is seq U.      *)

Section ReflectionContexts.
Variables (K : ordType) (T : Type) (U : union_map_class K T).

Structure ctx := Context {keyx : seq K; varx : seq U}.

Definition empx := Context [::] [::].

(* because contexts grow during computation, *)
(* we need a notion of sub-context *)

Definition sub_ctx i j := prefix (keyx i) (keyx j) /\ prefix (varx i) (varx j).

Lemma sc_refl i : sub_ctx i i.
Proof. by []. Qed.

Lemma sc_trans i j k : sub_ctx i j -> sub_ctx j k -> sub_ctx i k.
Proof.
by case=>K1 V1 [K2 V2]; split; [move: K2 | move: V2]; apply: prefix_trans.
Qed.

End ReflectionContexts.

(* Keys and map variables are syntactified as indices in the context.    *)
(* Disjoint union is syntactified as concatenation of lists.             *)
(*                                                                       *)
(* Pts n v : syntax for "key indexed the context under number n" \-> v   *)
(* Var n : syntax for "expression indexed in the context under number n" *)

(* In the cancellation algorithms, we iterate over the first              *)
(* expression e1 and remove each of its components from the second        *)
(* expression e2. But, typically, we want to remove only one occurrence   *)
(* of that component.                                                     *)
(*                                                                        *)
(* First, almost always, only one occurrence will exist, lest e2 be       *)
(* undefined. Thus, it's a waste of effort to traverse e2 in full once    *)
(* we've found an occurrence.                                             *)
(*                                                                        *)
(* Second, in some symmetric cancellation problems, e.g., dom_eq e1 e2,   *)
(* we *want* to remove only one occurrence from e2 for each component in  *)
(* e1. Otherwise, we will not produce a sound reduction. E.g.  dom (x \+  *)
(* x) (x \+ x) is valid, since both expressions are undef. However, after *)
(* removing x from the left side, and both x's from the right side, we    *)
(* get dom x Unit, which is not valid.                                    *)
(*                                                                        *)
(* Thus, as a matter of principle, we want a filter that removes just one *)
(* occurrence of a list element.                                          *)
(*                                                                        *)
(* We write it with p pulled out in a section in order to get it to       *)
(* simplify automatically.                                                *)

Section OneShotFilter.
Variables (A : Type) (p : pred A).

Fixpoint rfilter ts : seq A :=
  if ts is t :: ts' then if p t then ts' else t :: rfilter ts' else [::].
End OneShotFilter.

(* now for reflection *)

Section Reflection.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Type i : ctx U.

Inductive term := Pts of nat & T | Var of nat.

(* interpretation function for elements *)
Definition interp' i t :=
  match t with
    Pts n v => if onth (keyx i) n is Some k then pts k v else um_undef
  | Var n => if onth (varx i) n is Some f then f else um_undef
  end.

(* main interpretation function *)
Notation fx i := (fun t f => interp' i t \+ f).
Definition interp i ts := foldr (fx i) Unit ts.

Lemma fE i ts x  : foldr (fx i) x ts = x \+ interp i ts.
Proof. by elim: ts x=>[|t ts IH] x; rewrite /= ?unitR // IH joinCA. Qed.

Lemma interp_rev i ts : interp i (rev ts) = interp i ts.
Proof.
elim: ts=>[|t ts IH] //=; rewrite rev_cons -cats1.
by rewrite /interp foldr_cat fE /= unitR IH.
Qed.

(* we also need a pretty-printer, which works the same as interp *)
(* but removes trailing Unit's *)

Fixpoint pprint i ts :=
  if ts is t :: ts' then
    if ts' is [::] then interp' i t else interp' i t \+ pprint i ts'
  else Unit.

Lemma pp_interp i ts : pprint i ts = interp i ts.
Proof. by elim: ts=>[|t ts /= <-] //; case: ts=>//; rewrite unitR. Qed.

Definition key n t := if t is Pts m _ then n == m else false.
Definition var n t := if t is Var m then n == m else false.

Definition kfree n t := rfilter (key n) t.
Definition vfree n t := rfilter (var n) t.

Lemma keyN i n ts : ~~ has (key n) ts -> interp i (kfree n ts) = interp i ts.
Proof. by elim: ts=>[|t ts IH] //=; case: ifP=>//= _ /IH ->. Qed.

Lemma varN i n ts : ~~ has (var n) ts -> interp i (vfree n ts) = interp i ts.
Proof. by elim: ts=>[|t ts IH] //=; case: ifP=>//= _ /IH ->. Qed.

Lemma keyP i n k ts :
        has (key n) ts -> onth (keyx i) n = Some k ->
        exists v, interp i ts = pts k v \+ interp i (kfree n ts).
Proof.
elim: ts=>[|t ts IH] //=; case: ifP=>[|_ H].
- by case: t=>//= _ v /eqP <- _ ->; exists v.
by case/(IH H)=>v ->; exists v; rewrite joinCA.
Qed.

Lemma varP i n u ts :
        has (var n) ts -> onth (varx i) n = Some u ->
        interp i ts = u \+ interp i (vfree n ts).
Proof.
elim: ts=>[|t ts IH] //=; case: ifP=>[|_ H].
- by case: t=>//= _ /eqP <- _ ->.
by move/(IH H)=>->; rewrite joinCA.
Qed.

(* interpretation is invariant under context weakening *)
(* under assumption that the interpreted term is well-formed *)

Definition wf i t :=
  match t with
    Pts n _ => n < size (keyx i)
  | Var n => n < size (varx i)
  end.

Lemma sc_wf i j ts : sub_ctx i j -> all (wf i) ts -> all (wf j) ts.
Proof.
case=>/prefix_size H1 /prefix_size H2; elim: ts=>[|t ts IH] //=.
case/andP=>H /IH ->; rewrite andbT.
by case: t H=>[n v|v] H; apply: leq_trans H _.
Qed.

Lemma sc_interp i j ts :
        sub_ctx i j -> all (wf i) ts -> interp i ts = interp j ts.
Proof.
case=>H1 H2; elim: ts=>[|t ts IH] //= /andP [H] /IH ->.
by case: t H=>[n v|n] /= /prefix_onth <-.
Qed.

Lemma valid_wf i ts : valid (interp i ts) -> all (wf i) ts.
Proof.
elim: ts=>[|t ts IH] //= V; rewrite (IH (validR V)) andbT.
case: t {V IH} (validL V)=>[n v|n] /=;
by case X : (onth _ _)=>[a|]; rewrite ?(onth_size X) // valid_undef.
Qed.

Lemma wf_kfree i n ts : all (wf i) ts -> all (wf i) (kfree n ts).
Proof. by elim: ts=>//= t ts IH; case: ifP=>_ /andP [] //= -> /IH ->. Qed.

Lemma wf_vfree i n ts : all (wf i) ts -> all (wf i) (vfree n ts).
Proof. by elim: ts=>//= t ts IH; case: ifP=>_ /andP [] //= -> /IH ->. Qed.

(* sometimes we want to get keys in a list, not in a predicate *)

Definition getkeys :=
  foldr (fun t ks => if t is Pts k _ then k :: ks else ks) [::].

Lemma has_getkeys ts n : n \in getkeys ts = has (key n) ts.
Proof. by elim: ts=>//= t ts IH; case: t=>[m v|m] //; rewrite inE IH. Qed.

End Reflection.

(**************************************************************************)
(**************************************************************************)
(* Purely functional decision procedures for the three tasks. Further     *)
(* below, they will be embedded into the canonical programs validO/validX *)
(* and domeqO/domeqX and invalidO/invalidX respectively.                  *)
(**************************************************************************)
(**************************************************************************)

(* subterm is purely functional version of validO/validX *)

Section Subterm.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (i : ctx U) (ts : seq (term T)).

Fixpoint subterm ts1 ts2 :=
  match ts1 with
    Pts n _ :: tsx1 =>
      if has (key n) ts2 then subterm tsx1 (kfree n ts2) else false
  | Var n :: tsx1 =>
      if has (var n) ts2 then subterm tsx1 (vfree n ts2) else false
  | [::] => true
  end.

(* the procedure is sound for deciding wf subterms *)
Lemma subterm_sound i ts1 ts2 :
        all (wf i) ts1 -> all (wf i) ts2 -> subterm ts1 ts2 ->
        exists u, dom_eq (interp i ts1 \+ u) (interp i ts2).
Proof.
elim: ts1 ts2=>[|t ts1 IH] ts2 /= A1 A2.
- by exists (interp i ts2); rewrite unitL.
case/andP: A1; case: t=>[n v|n] /= /size_onth [k] X A1;
rewrite X; case: ifP=>Y //.
- case: (keyP Y X)=>w -> /(IH _ A1 (wf_kfree n A2)) [xs D].
  by exists xs; rewrite -joinA; apply: domeqUn D.
move: (varP Y X)=>-> /(IH _ A1 (wf_vfree n A2)) [xs D].
by exists xs; rewrite -joinA; apply: domeqUn D.
Qed.

End Subterm.

(* subtract is purely functional version of domeqO/domeqX *)

Section Subtract.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (i : ctx U) (ts : seq (term T)).

(* We need a subterm lemma that returns the uncancelled stuff from *)
(* both sides. xs accumulates uncancelled part of ts1, starting as nil *)

Fixpoint subtract ts1 ts2 xs :=
  match ts1 with
    Pts n v :: tsx1 =>
      if has (key n) ts2 then subtract tsx1 (kfree n ts2) xs
      else subtract tsx1 ts2 (Pts n v :: xs)
  | Var n :: tsx1 =>
      if has (var n) ts2 then subtract tsx1 (vfree n ts2) xs
      else subtract tsx1 ts2 (Var T n :: xs)
  | [::] => (xs, ts2)
  end.

(* below, the existentially quantified u is the cancelled part *)
Lemma subtract_sound i ts1 ts2 rs1 rs2 xs :
        all (wf i) ts1 -> all (wf i) ts2 ->
        subtract ts1 ts2 xs = (rs1, rs2) ->
        exists u, dom_eq (interp i ts1 \+ interp i xs) (interp i rs1 \+ u) /\
                  dom_eq (interp i ts2) (interp i rs2 \+ u).
Proof.
elim: ts1 ts2 xs=>[|t ts1 IH] ts2 xs /= A1 A2.
- by case=><-<-; exists Unit; rewrite unitL !unitR.
case/andP: A1; case: t=>[n v|n] /= /size_onth [x X] A1; rewrite X; case: ifP=>Y.
- case: (keyP Y X)=>w -> /(IH _ _ A1 (wf_kfree n A2)) [u][H1 H2].
  exists (pts x v \+ u); rewrite -joinA !(pull (pts x _)).
  by split=>//; apply: domeqUn.
- by case/(IH _ _ A1 A2)=>u [/= H1 H2]; rewrite X joinCA joinA in H1; exists u.
- move: (varP Y X)=>-> /(IH _ _ A1 (wf_vfree n A2)) [u][H1 H2].
  by exists (x \+ u); rewrite -joinA !(pull x); split=>//; apply: domeqUn.
by case/(IH _ _ A1 A2)=>u [/= H1 H2]; rewrite X joinCA joinA in H1; exists u.
Qed.

End Subtract.

(* invalid is a purely functional test of invalidO/invalidX *)

Section Invalid.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (i : ctx U) (t : term T) (ts : seq (term T)).

Definition undefx i t :=
  if t is Var n then
    if onth (varx i) n is Some x then undefb x else false
  else false.

Definition isundef i ts := ~~ uniq (getkeys ts) || has (undefx i) ts.

Lemma isundef_sound i ts :
        all (wf i) ts -> isundef i ts -> ~~ valid (interp i ts).
Proof.
elim: ts=>[|t ts IH] //= /andP [W A].
case: t W=>[n v|n] /= /size_onth [k] X; rewrite /isundef /= X; last first.
- rewrite orbCA=>H; case: validUn=>// V; rewrite (negbTE (IH A _)) //.
  by case/orP: H V=>// /undefbE ->; rewrite valid_undef.
rewrite negb_and negbK has_getkeys -orbA /=.
case/orP=>// V; last by rewrite validPtUn andbCA (negbTE (IH A _)).
by case: (keyP V X)=>u ->; rewrite joinA pts_undef join_undefL valid_undef.
Qed.

End Invalid.

(********************************)
(********************************)
(* Canonical structure programs *)
(********************************)
(********************************)

(* first a helper program for searching and inserting in a list *)

Section XFind.
Variable A : Type.

Structure tagged_elem := XTag {xuntag :> A}.

(* Local Coercion untag : tagged_elem >-> A. *)

Definition extend_tag := XTag.
Definition recurse_tag := extend_tag.
Canonical found_tag x := recurse_tag x.

(* Main structure:                                                  *)
(* - xs1 : input sequence                                           *)
(* - xs2 : output sequence; if pivot is found, then xs2 = xs1, else *)
(*   xs2 = pivot :: xs1                                             *)
(* - i : output index of pivot in xs2                               *)

Definition axiom xs1 xs2 i (pivot : tagged_elem) :=
  onth xs2 i = Some (xuntag pivot) /\ prefix xs1 xs2.
Structure xfind (xs1 xs2 : seq A) (i : nat) :=
  Form {pivot :> tagged_elem; _ : axiom xs1 xs2 i pivot}.

(* found the elements *)
Lemma found_pf x t : axiom (x :: t) (x :: t) 0 (found_tag x).
Proof. by []. Qed.
Canonical found_form x t := Form (@found_pf x t).

(* recurse *)
Lemma recurse_pf i x xs1 xs2 (f : xfind xs1 xs2 i) :
        axiom (x :: xs1) (x :: xs2) i.+1 (recurse_tag (xuntag f)).
Proof. by case: f=>pv [H1 H2]; split=>//; apply/prefix_cons. Qed.
Canonical recurse_form i x xs1 xs2 f := Form (@recurse_pf i x xs1 xs2 f).

(* failed to find; attach the element to output *)
Lemma extend_pf x : axiom [::] [:: x] 0 (extend_tag x).
Proof. by []. Qed.
Canonical extend_form x := Form (@extend_pf x).

End XFind.

(* Next, we syntactify a unionmap into a seq term as follows.                 *)
(*                                                                            *)
(* - if the map is f1 \+ f2, then recurse over both and concat. the results   *)
(* - if the map is the empty map, return [::]                                 *)
(* - if the map is k \-> v then add k to the context, and return [Pts x v],   *)
(*      where x is the index for l in the context                             *)
(*  if the map is whatever else, add the map to the context and return        *)
(*      [Var n], where n is the index for the map in the context              *)

Module Syntactify.
Section Syntactify.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (i : ctx U) (ts : seq (term T)).

(* a tagging structure to control the flow of computation *)
Structure tagged_map := Tag {untag : U}.

Local Coercion untag : tagged_map >-> UMC.sort.

(* in reversed order; first test for unions, then empty, pts and vars *)
Definition var_tag := Tag.
Definition key_tag := var_tag.
Definition empty_tag := key_tag.
Canonical Structure union_tag hc := empty_tag hc.

(* Main structure                                    *)
(* - i : input context                               *)
(* - j : output context                              *)
(* - ts : syntactification of map_of using context j *)

Definition axiom i j ts (pivot : tagged_map) :=
  [/\ interp j ts = pivot :> U, sub_ctx i j & all (wf j) ts].
Structure form i j ts := Form {pivot : tagged_map; _ : axiom i j ts pivot}.

Local Coercion pivot : form >-> tagged_map.

(* check for union *)

Lemma union_pf i j k ts1 ts2 (f1 : form i j ts1) (f2 : form j k ts2) :
        axiom i k (ts1 ++ ts2) (union_tag (untag f1 \+ untag f2)).
Proof.
case: f1 f2=>_ [<- S1 W1][_][<- S2 W2]; split.
- by rewrite /interp foldr_cat fE joinC -(sc_interp S2 W1).
- by apply: sc_trans S1 S2.
by rewrite all_cat (sc_wf S2 W1) W2.
Qed.

Canonical union_form i j k ts1 ts2 f1 f2 :=
  Form (@union_pf i j k ts1 ts2 f1 f2).

(* check if reached empty *)

Lemma empty_pf i : axiom i i [::] (empty_tag Unit).
Proof. by []. Qed.

Canonical empty_form i := Form (@empty_pf i).

(* check for pts k v *)

Lemma pts_pf vars keys1 keys2 k v (f : xfind keys1 keys2 k):
        axiom (Context keys1 vars) (Context keys2 vars)
              [:: Pts k v] (key_tag (pts (xuntag f) v)).
Proof. by case: f=>p [E H]; split=>//=; rewrite ?E ?unitR // (onth_size E). Qed.

Canonical pts_form vars keys1 keys2 k v f :=
  Form (@pts_pf vars keys1 keys2 k v f).

(* check for var *)

Lemma var_pf keys vars1 vars2 n (f : xfind vars1 vars2 n) :
        axiom (Context keys vars1) (Context keys vars2)
              [:: Var T n] (var_tag (xuntag f)).
Proof. by case: f=>p [E H]; split=>//=; rewrite ?E ?unitR // (onth_size E). Qed.

Canonical var_form keys vars1 vars2 v f := Form (@var_pf keys vars1 vars2 v f).

End Syntactify.

Module Exports.
Coercion untag : tagged_map >-> UMC.sort.
Coercion pivot : form >-> tagged_map.
Canonical union_tag.
Canonical union_form.
Canonical empty_form.
Canonical pts_form.
Canonical var_form.
End Exports.
End Syntactify.

Export Syntactify.Exports.

(****************************)
(* Automating validO/validX *)
(****************************)

(* validO is a naive lemma that automates subterm checking *)
(* it leaves a goal of the form subterm ts2 ts1 *)
(* this one evaluates to a boolean, so it's easy to discharge *)
(* but it takes the space for the lemma's argument *)
(* which, thus, can't be picked from the goal *)

Section ValidO.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (i : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

Lemma validO j k ts1 ts2 (f1 : form (@empx K T U) j ts1)
                               (f2 : form j k ts2) :
        valid (untag f1) -> subterm ts2 ts1 -> valid (untag f2).
Proof.
case: f1 f2=>f1 [<- _ A1][f2][<- S2 A2] /= V; rewrite (sc_interp S2 A1) in V.
by case/(subterm_sound A2 (sc_wf S2 A1))=>xs /domeqP []; rewrite V=>/validL ->.
Qed.

End ValidO.

Arguments validO [K T U j k ts1 ts2 f1 f2] _ _.

Example ex0 (x y z : nat) (v1 v2 : nat) h:
          valid (Unit \+ y \\-> v1 \+ h \+ x \\-> v1) ->
          valid (x \\-> v2 \+ Unit).
Proof. by move=>V; rewrite (validO V). Abort.

(* validX is a more refined lemma for subterm checking which *)
(* automatically discharges the spurious argument from above *)

Module ValidX.
Section ValidX.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (j : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

(* The rform structure has two important components:                      *)
(*                                                                        *)
(* -- a packed/hoisted map m, which will be reified into the ts2 argument *)
(*    of subterm ts2 ts1                                                  *)
(*                                                                        *)
(* -- a boolean b, which will be instantiated with true in the validX     *)
(*    lemma, and will be unified with subterm ts2 ts1 in the start        *)
(*    instance                                                            *)
(*                                                                        *)
(* The other components of rform are j ts1 and pivot, which are forced by *)
(* needing to compose the proofs, but behave plainly in unification.      *)

Structure packed_map (m : U) := Pack {unpack : U}.
Canonical equate (m : U) := Pack m m.

Definition raxiom j ts1 m (b : bool) (pivot : packed_map m) :=
  all (wf j) ts1 -> valid (interp j ts1) -> b -> valid (unpack pivot).

Structure rform j ts1 m b :=
  RForm {pivot :> packed_map m; _ : raxiom j ts1 b pivot}.

(* start instance: note how subterm ts2 ts1 is unified with *)
(* the boolean component of rform *)

Lemma start_pf j k ts1 ts2 (f2 : form j k ts2) :
        @raxiom j ts1 (untag f2) (subterm ts2 ts1) (equate f2).
Proof.
case: f2=>f2 [<- S A2] A1; rewrite (sc_interp S A1)=>V.
case/(subterm_sound A2 (sc_wf S A1))=>xs.
by case/domeqP; rewrite V=>/validL ->.
Qed.

Canonical start j k ts1 ts2 f2 := RForm (@start_pf j k ts1 ts2 f2).

End ValidX.

Module Exports.
Canonical equate.
Canonical start.

Section Exports.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (j : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

(* the main lemma; note how the boolean component of rform is set to true *)

Lemma validX m j ts1 (f1 : form (empx U) j ts1) (g: rform j ts1 m true) :
        valid (untag f1) -> valid (unpack (pivot g)).
Proof. by case: g f1; case=>pivot H [f1][<- Sc A] /(H A); apply. Qed.

End Exports.

Arguments validX [K T U m j ts1 f1 g] _.

Example ex0 (x y z : nat) (v1 v2 : nat) h:
          valid (Unit \+ y \\-> v1 \+ h \+ x \\-> v1) ->
          valid (x \\-> v2 \+ Unit).
Proof. apply: validX. Abort.

End Exports.
End ValidX.

Export ValidX.Exports.

(****************************)
(* Automating domeqO/domeqX *)
(****************************)

(* naive lemma first *)

Section DomeqO.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (j : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

Lemma domeqO j k rs1 rs2 ts1 ts2
         (f1 : form (empx U) j ts1) (f2 : form j k ts2) :
         subtract ts1 ts2 [::] = (rs1, rs2) ->
         dom_eq (pprint k (rev rs1)) (pprint k rs2) ->
         dom_eq (untag f1) (untag f2).
Proof.
case: f1 f2=>f1 [<- _ A1][f2][<- S A2].
case/(subtract_sound (sc_wf S A1) A2)=>// ys [/= D1 D2].
rewrite unitR in D1; rewrite (sc_interp S A1).
rewrite !pp_interp interp_rev => D; apply: domeq_trans D1 _.
rewrite domeq_sym; apply: domeq_trans D2 _.
by rewrite domeq_sym; apply: domeqUn.
Qed.

End DomeqO.

Example ex0 (x y z : nat) (v1 v2 : nat) h:
          dom_eq (Unit \+ y \\-> v1 \+ h \+ x \\-> v1) (x \\-> v2 \+ Unit).
Proof. apply: domeqO=>//=. Abort.

Module DomeqX.
Section DomeqX.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (j : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

Structure packed_map (m : U) := Pack {unpack : U}.
Canonical equate (m : U) := Pack m m.

(* b is the pair of residual terms *)
Definition raxiom j k ts1 m b (pivot : packed_map m) :=
  all (wf j) ts1 -> sub_ctx j k /\
  (dom_eq (interp k b.1) (interp k b.2) ->
   dom_eq (interp k ts1) (unpack pivot)).

Structure rform j k ts1 m b :=
  RForm {pivot :> packed_map m; _ : raxiom j k ts1 b pivot}.

(* start instance: note how subtract ts1 ts2 [::] is unified with *)
(* the b component of rform thus passing the residual terms *)

Lemma start_pf j k ts1 ts2 (f2 : form j k ts2) :
        @raxiom j k ts1 (untag f2) (subtract ts1 ts2 [::]) (equate f2).
Proof.
case: f2=>f2 [<- S A2]; case E : (subtract _ _ _)=>[rs1 rs2] A1; split=>//.
case/(subtract_sound (sc_wf S A1) A2): E=>ys [/= D1 D2 D].
rewrite unitR in D1; apply: domeq_trans D1 _.
rewrite domeq_sym; apply: domeq_trans D2 _.
by rewrite domeq_sym; apply: domeqUn.
Qed.

Canonical start j k ts1 ts2 f2 := RForm (@start_pf j k ts1 ts2 f2).

End DomeqX.

Module Exports.
Canonical equate.
Canonical start.

Section Exports.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (j : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

(* the main lemma; notice how residuals rs1, rs2 are passed to g to compute *)

Lemma domeqX m j k rs1 rs2 ts1 (f1 : form (empx U) j ts1)
                               (g : rform j k ts1 m (rs1, rs2)) :
        dom_eq (pprint k (rev rs1)) (pprint k rs2) ->
        dom_eq (untag f1) (unpack (pivot g)).
Proof.
case: g f1; case=>pivot R [f1][<- _ A1] /=; case/(_ A1): R=>S D.
by rewrite !pp_interp interp_rev (sc_interp S A1).
Qed.

End Exports.

Arguments domeqX [K T U m j k rs1 rs2 ts1 f1 g] _.

Example ex0 (x y z : nat) (v1 v2 : nat) h:
          dom_eq (Unit \+ y \\-> v1 \+ h \+ x \\-> v1) (x \\-> v2 \+ Unit).
Proof. apply: domeqX=>/=. Abort.

End Exports.
End DomeqX.

Export DomeqX.Exports.

(********************************)
(* Automating invalidO/invalidX *)
(********************************)

(* naive lemma first *)

Section InvalidO.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (i : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

Lemma undefO i ts (f : form (empx U) i ts) :
        isundef i ts -> untag f = um_undef.
Proof. by case: f=>f [<- _ A] /(isundef_sound A)/invalidE. Qed.

Lemma invalidO i ts (f : form (empx U) i ts) :
        isundef i ts -> valid (untag f) = false.
Proof. by move/undefO=>->; rewrite valid_undef. Qed.

End InvalidO.

Example ex0 (x y z : nat) (v1 v2 : nat) h:
          (Unit \+ y \\-> v1 \+ h \+ y \\-> v1) = um_undef.
Proof. by apply: undefO. Abort.

(* now the sophisticated one *)

Module InvalidX.
Section InvalidX.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (i : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

Structure packed_map (m : U) := Pack {unpack : U}.
Canonical equate (m : U) := Pack m m.

(* b is the boolean that we want to get out of isundef *)
Definition raxiom i ts m b (pivot : packed_map m) :=
  b -> valid (unpack pivot) = false.

Structure rform i ts m b :=
  RForm {pivot :> packed_map m; _ : raxiom i ts b pivot}.

(* start instance: note how isundef i ts is unified with *)
(* the b component of rform, which will be set to true by lemma statements *)

Lemma start_pf i ts (f : form (empx U) i ts) :
        @raxiom i ts (untag f) (isundef i ts) (equate f).
Proof. by case: f=>f [<- S A] /(isundef_sound A) /negbTE. Qed.

Canonical start i ts f := RForm (@start_pf i ts f).

End InvalidX.

Module Exports.
Canonical equate.
Canonical start.

Section Exports.
Variables (K : ordType) (T : Type) (U : union_map_class K T).
Implicit Types (i : ctx U) (ts : seq (term T)).
Notation form := Syntactify.form.
Notation untag := Syntactify.untag.

(* the main lemmas *)

Lemma undefX m i ts (g : rform i ts m true) : unpack (pivot g) = um_undef.
Proof. by case: g; case=>pivot /= /(_ (erefl _))/negbT/invalidE. Qed.

Lemma invalidX m i ts (g : rform i ts m true) :
        valid (unpack (pivot g)) = false.
Proof. by rewrite undefX valid_undef. Qed.

End Exports.

Arguments invalidX [K T U m i ts g].

Example ex0 (x y z : nat) (v1 v2 : nat) h:
          valid (Unit \+ y \\-> v1 \+ h \+ y \\-> v1).
Proof. rewrite invalidX. Abort.

End Exports.
End InvalidX.

Export InvalidX.Exports.


From Tweetnacl Require Import Libs.LibTactics.
From Tweetnacl Require Import Libs.LibTactics_SF.
Require Import mathcomp.ssreflect.ssreflect.
Require Import stdpp.list.

Section nth_f.
Context {I} {O} (f:I -> O) (v:I).

Fixpoint nth_f (n:nat) (x:list I) {struct x} : O := match n,x with
  | _, [] => f v
  | 0 , h :: q => f h
  | S n, h :: q => nth_f n q
end.

Lemma nth_f_ext: forall n x,
  f (nth n x v) = nth_f n x.
Proof.
  move=> n l; gen n ; induction l ; destruct n ; simpl ; auto.
Qed.
End nth_f.

Lemma ListSame : forall A (h1 h2: A) (q1 q2:list A), h1 :: q1 = h2 :: q2 <-> h1 = h2 /\ q1 = q2.
Proof. boum. Qed.

Lemma nth_drop : forall A (n:nat) (l:list A) (d: A), n < length l -> drop n l = nth n l d :: drop (S n) l.
Proof. induction n ; destr_boum l. Qed.
Arguments nth_drop [A] _ _ _ _.

Lemma take_drop_length: forall A (n:nat) (l l':list A),
  length l = length l' -> length (take n l ++ drop n l') = length l.
Proof. move => A n l l' Hll'.
have H: n < length l \/ length l <= n by omega.
destruct H ; rewrite app_length drop_length -Hll' ; [rewrite take_length_le|rewrite take_length_ge] ; omega.
Qed.
Arguments take_drop_length [A] _ _ _.

Lemma take_drop_Zlength: forall A (n:nat) (l l':list A),
  Zlength l = Zlength l' -> Zlength (take n l ++ drop n l') = Zlength l.
Proof. convert_length_to_Zlength take_drop_length. Qed.
Arguments take_drop_Zlength [A] _ _ _.

Lemma nth_take: forall A (n:nat) (l l':list A) d,
  n <= length l -> nth n ((take n l) ++ l') d = nth 0 l' d.
Proof. induction n ; destr_boum l. Qed.
Arguments nth_take [A] _ _ _ _ _.

Lemma nth_take_full: forall A (n m:nat) (l:list A) d,
  n < m -> nth n (take m l) d = nth n l d.
Proof. induction n ; destruct m; destr_boum l. Qed.
Arguments nth_take_full [A] _ _ _ _.

Lemma take_cons: forall A (n:nat) (l:list A) d,
  n < length l -> (take n l) ++ nth n l d :: nil = take (S n) l.
Proof. induction n ; destr_boum l ; simpl in * ; f_equal ; apply IHn ; omega. Qed.
Arguments take_cons [A] _ _ _ _.

Lemma nth_drop_2 : forall A (n:nat) (l:list A) (d:A), n <= length l -> nth n l d = nth 0 (drop n l) d.
Proof. induction n ; destr_boum l. Qed.
Arguments nth_drop [A] _ _ _.

Fixpoint upd_nth {A} (n:nat) (l:list A) (v:A) := match l with
  | [] => match n with
    | 0%nat => v :: []
    | S p => v :: []
    end
  | h :: q => match n with
    | 0%nat => v :: q
    | S p => h :: (upd_nth p q v)
    end
  end.

Lemma upd_nth_cons:
  forall (A : Type) (i : nat) (l : list A) (h v : A),
  upd_nth (S i) (h::l) v = h :: upd_nth i l v.
Proof. go. Qed.

Lemma upd_nth_cons_sub:
  forall (A : Type) (i : nat) (l : list A) (h v : A),
  0 < i ->
  upd_nth i (h::l) v = h :: upd_nth (i - 1) l v.
Proof. intros. destruct i. omega.
rewrite upd_nth_cons. f_equal. f_equal.
omega. Qed.

Lemma upd_nth_length:
  forall (A : Type) (i : nat) (l : list A) (v : A),
  0 <= i < length l -> length (upd_nth i l v) = length l.
Proof. induction i ; destruct l; simpl ;
  repeat match goal with
  | _ => progress intros
  | _ => reflexivity
  | _ => omega
  | [ H : _ < 0 |- _ ] => inversion H
  | [ H : _ ≤ _ ∧ _ < _ |- _] => inv H
  | [ |- S _ = S _ ] => f_equal ; apply IHi
  | [ H : S _ < S _ |-  _] => inv H
  end.
Qed.

Lemma upd_nth_map:
  forall (A B : Type) (f : A -> B) (i : nat) (l : list A) (v : A),
  upd_nth i (map f l) (f v) = map f (upd_nth i l v).
Proof. induction i ; destruct l; simpl ; intros ;
repeat match goal with
  | _ => progress intros
  | _ => reflexivity
  | _ => omega
  | _ => rewrite IHi
  end.
Qed.

Lemma upd_nth_lookup:
  forall (K : nat) (A : Type) (l : list A),
  length l = K ->
  forall (i j : nat) (d v : A),
  0 <= i < K ->
  0 <= j < K ->
  i = j /\ nth i (upd_nth j l v) d = v \/
  i <> j /\ nth i (upd_nth j l v) d = nth i l d.
Proof.
  move => K A l; move: K. induction l; intros [] HSl i j d v HSi HSj;
  simpl in HSl ; try omega.
  inversion HSl as [Hl].
  destruct i, j ; [left | right | right| ] ; go =>  /=.
  have Hi : 0 ≤ i ∧ i < n by omega.
  have Hj : 0 ≤ j ∧ j < n by omega.
  clear HSi HSj HSl.
  apply (IHl n Hl i j d v) in Hj.
  2: assumption.
  destruct Hj as [Hj|Hj]; [left|right]; destruct Hj ; go.
Qed.

Lemma upd_nth_lookup':
  forall (K : nat) (A : Type) (l : list A),
  length l = K ->
  forall (i : nat),
  0 <= i < K ->
  forall (j : nat),
  0 <= j < K ->
  forall d v : A,
  nth i (upd_nth j l v) d = (if beq_nat i j then v else nth i l d).
Proof.
  move => K A l Hl i Hi j H d v.
  apply (upd_nth_lookup K A l Hl i j d v Hi) in H.
  destruct H as [H|H];
  destruct H as [Hij Hnth].
  subst i;
  flatten.
  apply beq_nat_false in Eq; tryfalse.
  flatten.
  apply beq_nat_true in Eq ; tryfalse.
Qed.

Lemma upd_nth_same:
  forall (A : Type) (i : nat) (l : list A) (u d : A),
  0 <= i < length l -> nth i (upd_nth i l u) d = u.
Proof.
induction i ; destruct l; simpl  ; intros ;
repeat match goal with
  | _ => progress intros
  | _ => reflexivity
  | _ => omega
  | _ => rewrite IHi
  end.
Qed.

Lemma upd_nth_diff:
  forall (A : Type) (i j : nat) (l : list A) (u d : A),
  0 <= i < length l ->
  0 <= j < length l -> i <> j -> nth i (upd_nth j l u) d = nth i l d.
Proof.
  intros A i j l; gen i j ; induction l ; intros [] [] d v HSi HSj Hij;
  simpl in * ; go.
Qed.

Lemma upd_nth_app1:
  forall (A : Type) (i : nat) (l1 l2 : list A),
  0 <= i < length l1 ->
  forall v : A, upd_nth i (l1 ++ l2) v = upd_nth i l1 v ++ l2.
Proof.
  intros A i l1; gen i; induction l1 ; intros [] l2 HSi v;
  simpl in * ; go.
  f_equal ; go.
Qed.

Lemma upd_nth_app2:
  forall (A : Type) (l1 l2 : list A) (i : nat) (v : A),
  length l1 <= i <= length l1 + length l2 ->
  upd_nth i (l1 ++ l2) v = l1 ++ upd_nth (i - length l1) l2 v.
Proof.
  induction l1 ; intros l2 [] v Hl1 ; simpl in * ; try reflexivity.
  omega.
  have Hl1': length l1 ≤ n ∧ n ≤ length l1 + length l2 by omega.
  apply (IHl1 l2 n v) in Hl1'.
  go.
Qed.

Lemma upd_nth0:
  forall (A : Type) (l : list A) (h v : A),
  upd_nth 0 (h::l) v = v :: l.
Proof. reflexivity. Qed.

Lemma upd_nth_take_small:
  forall (A : Type) (n m:nat) (l : list A) (v : A),
  n < length l ->
  n <= m ->
  take n (upd_nth m l v) = take n l.
Proof.
   induction n ; intros [|m] [|h l] v Hnl Hnm ; simpl in Hnl ; try reflexivity ; try omega.
   simpl.
   fequals.
   apply IHn ; omega.
Qed.

Lemma upd_nth_drop_small:
  forall (A : Type) (n m:nat) (l : list A) (v : A),
  n < length l ->
  m < n ->
  drop n (upd_nth m l v) = drop n l.
Proof.
   induction n ; intros [|m] [|h l] v Hnl Hnm ; simpl in Hnl ; try reflexivity ; try omega.
   simpl ; apply IHn ; omega.
Qed.

Lemma upd_nth_app':
  forall (A : Type) (n : nat) (l1 : list A) (v : A) (l2 : list A) (w : A),
  length l1 = n -> upd_nth n (l1 ++ v :: l2) w = l1 ++ w :: l2.
Proof.
  intros.
  rewrite upd_nth_app2.
  2: by omega.
  by oreplace (n - length l1) 0.
Qed.

Lemma upd_nth_list_alter: forall A (f : A -> A) i (v:A) (l: list A), f = (fun x => v) ->
i < length l -> upd_nth i l v = list_alter f i l.
Proof.
intros A f; induction i as [| i IHi]; intros v l Hf H.
intros. destruct l. simpl in H. omega.
unfold upd_nth.
simpl.
rewrite Hf.
reflexivity.
destruct l ; simpl in H.
inversion H.
change (a::l) with ([a] ++ l).
rewrite upd_nth_app2 ; simpl.
rewrite -minus_n_O.
f_equal.
go.
omega.
Qed.

Lemma upd_nth_alter: forall A (f : A -> A) (i: nat) (v:A) (l: list A), 0 <= i -> f = (fun x => v) ->
i < length l -> upd_nth i l v = alter f i l.
Proof.  intros ; unfold base.alter ; apply upd_nth_list_alter ; auto. Qed.

Lemma upd_nth_app_step:
  forall i (a r:list Z) d,
    0 <= i ->
    i < length r ->
    i < length a ->
    firstn (S i) a ++ skipn (S i) r =
    upd_nth i (firstn i a ++ skipn i r) (nth i a d).
Proof.
  intros.
  rewrite (nth_drop i r 0).
  rewrite cons_middle app_assoc upd_nth_app1.
  2: rewrite app_length firstn_length_le ; go.
  rewrite upd_nth_app2.
  2: rewrite firstn_length_le ; simpl; omega.
  replace (i - length (firstn i a)) with 0.
  2: rewrite firstn_length_le; omega.
  rewrite upd_nth0.
  f_equal_fixed.
  rewrite -(take_drop i a).
  oreplace (S i) (i + 1)%nat.
  rewrite take_plus_app.
  rewrite (take_drop i a).
  2: (rewrite firstn_length_le; omega).
  f_equal.
  clear H0 r.
  gen i.
  induction a ; intros [] Hi Hl ; go.
  done.
Qed.

Definition list_ind_by_2 :
    forall A (P : list A → Prop),
    P [] →
    (forall a, P [a]) →
    (forall (a b:A) (l : list A), P l → P (a :: b :: l)) →
    forall (l : list A), P l :=
       fun A => fun P => fun P0 => fun P1 => fun PSS =>
          fix f (l : list A) := match l with
                             [] => P0
                           | [a] => P1 a
                           | a :: b :: l => PSS a b l (f l)
                          end.

Lemma upd_nth_comm: forall A i j (l:list A) ni nj, i < length l -> j < length l -> i <> j ->  upd_nth i (upd_nth j l nj) ni = upd_nth j (upd_nth i l ni) nj.
Proof.
  induction i.
  destruct j; intros.
  tryfalse.
  destruct l.
  simpl in H0 ; omega.
  reflexivity.
  intros.
  destruct l.
  simpl in H ; omega.
  destruct j.
  reflexivity.
  simpl.
  f_equal_fixed.
  apply IHi.
  move: H ; simpl; apply lt_S_n.
  move: H0 ; simpl; apply lt_S_n.
  intros H'.
  apply H1; subst; trivial.
Qed.

Lemma upd_nth_upd_nth: forall A i (l:list A) ni nj, i < length l -> upd_nth i (upd_nth i l nj) ni = upd_nth i l ni.
Proof.
  induction i; intros.
  destruct l.
  simpl in H ; omega.
  reflexivity.
  destruct l.
  simpl in H ; omega.
  simpl.
  f_equal.
  apply IHi.
  move: H ; simpl; apply lt_S_n.
Qed.

Lemma length_pos : forall (A:Type) (l:list A), 0 <= length l.
Proof. boum. Qed.

Lemma map_drop : forall A B (f: A -> B) (l:list A) n, map f (drop n l) = drop n (map f l).
Proof. intros A B f ; induction l ; destruct n ; go. Qed.

Open Scope Z.

Lemma Zlength_pos: forall {A : Type} (l:list A), 0 <= Zlength l.
Proof. intros ; rewrite Zlength_correct ; go. Qed.

Lemma app_Zlength: forall {A : Type} (l l' : list A), Zlength (l ++ l') = Zlength l + Zlength l'.
Proof. intros; by rewrite !Zlength_correct -Nat2Z.inj_add app_length. Qed.

Lemma Zlength_cons' : forall {A : Type} (x : A) (l : list A), Zlength (x :: l) = (Zlength l) + 1.
Proof. intros ; by rewrite Zlength_cons. Qed.

Lemma Zlength_map: forall A B (f: A -> B) l, Zlength (map f l) = Zlength l.
Proof. intros; induction l ; auto ; rewrite map_cons !Zlength_cons ; go. Qed.

Lemma upd_nth_Zlength:
  forall (A : Type) (i : nat) (l : list A) (v : A),
  0 <= i < Zlength l -> Zlength (upd_nth i l v) = Zlength l.
Proof. convert_length_to_Zlength upd_nth_length. Qed.

Lemma upd_nth_same_Zlength:
  forall (A : Type) (i : nat) (l : list A) (u d : A),
  0 <= i < Zlength l -> nth i (upd_nth i l u) d = u.
Proof. convert_length_to_Zlength upd_nth_same. Qed.

Lemma upd_nth_diff_Zlength:
  forall (A : Type) (i j : nat) (l : list A) (u d : A),
  0 <= i < Zlength l ->
  0 <= j < Zlength l -> i <> j -> nth i (upd_nth j l u) d = nth i l d.
Proof. convert_length_to_Zlength upd_nth_diff. Qed.

Lemma upd_nth_upd_nth_Zlength : forall A (i:nat) (l:list A) ni nj, i < Zlength l -> upd_nth i (upd_nth i l nj) ni = upd_nth i l ni.
Proof. convert_length_to_Zlength upd_nth_upd_nth. Qed.

Lemma upd_nth_comm_Zlength : forall A (i j:nat) (l:list A) ni nj, i < Zlength l -> j < Zlength l -> i <> j ->  upd_nth i (upd_nth j l nj) ni = upd_nth j (upd_nth i l ni) nj.
Proof. convert_length_to_Zlength upd_nth_comm. Qed.

Lemma upd_nth_take_small_Zlength:
  forall (A : Type) (n m:nat) (l : list A) (v : A),
  n < Zlength l ->
  n <= m ->
  take n (upd_nth m l v) = take n l.
Proof. convert_length_to_Zlength upd_nth_take_small. Qed.

Lemma take_cons_Zlength: forall A n (l:list A) d,
  0 <= n < Zlength l -> (take (Z.to_nat n) l) ++ nth (Z.to_nat n) l d :: nil = take (Z.to_nat (n + 1)) l.
Proof. intros. replace (Z.to_nat (n + 1)) with (S (Z.to_nat n)).
rapply take_cons.
(* apply take_cons. *)
rewrite Zlength_correct in H.
apply Nat2Z.inj_lt.
rewrite Z2Nat.id ; omega.
rewrite Z2Nat.inj_add.
change (Z.to_nat 1) with 1%nat.
all: omega.
Qed.
Arguments take_cons_Zlength [A] _ _ _ _.

Lemma upd_nth_list_alter_Zlength: forall A (f : A -> A) (i:nat) (v:A) (l: list A), f = (fun x => v) ->
i < Zlength l -> upd_nth i l v = list_alter f i l.
Proof. convert_length_to_Zlength upd_nth_list_alter. Qed.

Lemma upd_nth_alter_Zlength: forall A (f : A -> A) (i: nat) (v:A) (l: list A), 0 <= i -> f = (fun x => v) ->
i < Zlength l -> upd_nth i l v = alter f i l.
Proof. convert_length_to_Zlength upd_nth_alter. Qed.

Close Scope Z.


Require Import Coq.FSets.FMapPositive.
Require Import Crypto.Compilers.Named.FMapContext.

Module PositiveContext := FMapContext PositiveMap.
Notation PositiveContext := PositiveContext.FMapContext.
Notation PositiveContext_nd := PositiveContext.FMapContext_nd.
Definition PositiveContextOk := PositiveContext.FMapContextOk (fun x y pf => pf).
Global Existing Instance PositiveContextOk.


(*
I hereby assign copyright in my past and future contributions
to the Software Foundations project to the Author of Record of
each volume or component, to be licensed under the same terms
as the rest of Software Foundations. I understand that, at present,
the Authors of Record are as follows: For Volumes 1 and 2, known
until 2016 as "Software Foundations" and from 2016 as (respectively)
"Logical Foundations" and "Programming Foundations," and for Volume 4,
"QuickChick: Property-Based Testing in Coq," the Author of Record is
Benjamin C. Pierce. For Volume 3, "Verified Functional Algorithms",
the Author of Record is Andrew W. Appel. For components outside of
designated volumes (e.g., typesetting and grading tools and other
software infrastructure), the Author of Record is Benjamin Pierce.
*)

From LF Require Export Lists.

Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> boollist.

Inductive bool2natlist : Type :=
  | b2n_nil : bool2natlist
  | b2n_cons: (bool -> nat) -> bool2natlist -> bool2natlist.

Inductive booloption : Type :=
  | Some_bool : bool -> booloption
  | None_bool : booloption.

Inductive bool2natoption: Type :=
  | Some_b2n : (bool -> nat) -> bool2natoption
  | None_b2n : bool2natoption.

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Check list.
Check (cons (bool-> bool)).

Check (nil nat).
(* ===> nil nat : list nat *)

Check (cons nat 3 (nil nat)).
(* ===> cons nat 3 (nil nat) : list nat *)

Check nil.
(* ===> nil : forall X : Type, list X *)

Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)

Check (cons nat 2 (cons nat 1 (nil nat))).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Check repeat.

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity.  Qed.

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity.  Qed.

Module MumbleGrumble.

(*Exercise1*)
Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?
      - [d (b a 5)]
      - [d mumble (b a 5)]
      - [d bool (b a 5)]
      - [e bool true]
      - [e mumble (b c 0)]
      - [e bool (b c 0)]
      - [c]  *)

Check d mumble (b a 5).
Check d bool (b a 5).
Check e bool true.
Check e mumble (b c 0).
Check c.

End MumbleGrumble.

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Check repeat'.
(* ===> forall X : Type, X -> nat -> list X *)
Check repeat.
(* ===> forall X : Type, X -> nat -> list X *)

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

Inductive list' {X:Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Check nil.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity.  Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity.  Qed.

Fail Definition mynil := nil.

Definition mynil : list nat := nil.

Check @nil.

Definition mynil' := @nil nat.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Definition list123''' := [1; 2; 3].

(*Exercise 2*)
Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros. induction l as [|l' l'' IHl'].
  - reflexivity.
  - simpl. rewrite IHl'. reflexivity.
Qed.

(*Exercise 3*)
Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros. induction l as [|l' l'' IHl'].
  - reflexivity.
  - simpl. rewrite IHl'. reflexivity.
Qed.

(*Exercise 4*)
Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros. induction l1 as [| l' l'' IHl'].
  - reflexivity.
  - simpl. rewrite <- IHl'. reflexivity.
Qed.

(*Exercise 5*)
Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros. induction l1 as [|l' l'' IHl'].
  - simpl. rewrite app_nil_r. reflexivity.
  - simpl. rewrite IHl'. rewrite app_assoc. reflexivity.
Qed.

(*Exercise 6*)
Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros. induction l as [|l' l'' IHl'].
  - reflexivity.
  - simpl. rewrite rev_app_distr. rewrite IHl'. reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
| pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

(*Exercise 7*)
(** The function [split] is the right inverse of [combine]: it takes a
    list of pairs and returns a pair of lists.  In many functional
    languages, it is called [unzip].

    Fill in the definition of [split] below.  Make sure it passes the
    given unit test. *)

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
   match l with
  | nil => ([], [])
  | (x, y) :: t => ( x :: (fst (split t)), y :: (snd (split t)))
end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. reflexivity. Qed.

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

Arguments Some {X} _.
Arguments None {X}.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if eqb n O then Some a else nth_error l' (pred n)
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

(*Exercise 8*)
Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | nil => None
  | h :: t => Some h
end.

Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
 Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
 Proof. reflexivity. Qed.

(*Exercise 9*)
(*Define polymorphic binary trees data structure*)

Inductive poly_b_tree {T: Type}: Type:=
  |emp_tree : poly_b_tree
  |node: T -> poly_b_tree -> poly_b_tree -> poly_b_tree.

(*Exercise 10:
Define a function that receives a polymorphic binary tree and returns
the number of nodes within that tree.
*)

Fixpoint Exc_10 {T : Type} (x : @poly_b_tree T): nat :=
  match x with
  | emp_tree => O
  | node x y z => S(Exc_10 y) + (Exc_10 z)
end.

(*Exercise 11:
Define a function that returns the height of the input polymorphic
binary tree.
*)
Fixpoint Exc_11 {T : Type} (x : @poly_b_tree T) : nat :=
    match x with
    | emp_tree => 0
    | node x y z => 1 + max (Exc_11 y) (Exc_11 z)
    end.

(*Exercise 12:
Define a function that decides whether a polymorphic binary is a leaf.
*)
Definition Exc_12 {T : Type} (x : @poly_b_tree T) : bool :=
    match x with
    | node v emp_tree emp_tree => true
    | _ => false
    end.


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

Declare ML Module "quote_plugin".

(***********************************************************************
  The "abstract" type index is defined to represent variables.

  index : Set
  index_eq : index -> bool
  index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m
  index_lt : index -> bool
  varmap : Type -> Type.
  varmap_find : (A:Type)A -> index -> (varmap A) -> A.

  The first arg. of varmap_find is the default value to take
  if the object is not found in the varmap.

  index_lt defines a total well-founded order, but we don't prove that.

***********************************************************************)

Set Implicit Arguments.

Section variables_map.

Variable A : Type.

Inductive varmap : Type :=
  | Empty_vm : varmap
  | Node_vm : A -> varmap -> varmap -> varmap.

Inductive index : Set :=
  | Left_idx : index -> index
  | Right_idx : index -> index
  | End_idx : index.

Fixpoint varmap_find (default_value:A) (i:index) (v:varmap) {struct v} : A :=
  match i, v with
  | End_idx, Node_vm x _ _ => x
  | Right_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v2
  | Left_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v1
  | _, _ => default_value
  end.

Fixpoint index_eq (n m:index) {struct m} : bool :=
  match n, m with
  | End_idx, End_idx => true
  | Left_idx n', Left_idx m' => index_eq n' m'
  | Right_idx n', Right_idx m' => index_eq n' m'
  | _, _ => false
  end.

Fixpoint index_lt (n m:index) {struct m} : bool :=
  match n, m with
  | End_idx, Left_idx _ => true
  | End_idx, Right_idx _ => true
  | Left_idx n', Right_idx m' => true
  | Right_idx n', Right_idx m' => index_lt n' m'
  | Left_idx n', Left_idx m' => index_lt n' m'
  | _, _ => false
  end.

Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m.
  simple induction n; simple induction m; simpl; intros.
  rewrite (H i0 H1); reflexivity.
  discriminate.
  discriminate.
  discriminate.
  rewrite (H i0 H1); reflexivity.
  discriminate.
  discriminate.
  discriminate.
  reflexivity.
Qed.

End variables_map.

Unset Implicit Arguments.


  Inductive Het : Type :=
  |HetConstr : forall A, A -> Het.

  Inductive hlist : Type :=
  | HNil : hlist
  | HCons : forall {A},  A -> hlist -> hlist.

  Notation "{ x ; .. ; y }" := (HCons x .. (HCons y HNil) ..) : hetlist_scope.
  Open Scope hetlist_scope.

  (*Hack for generalize dependent of multiple parameters*)
  Ltac genDeps xs :=
    match xs with
      |HCons ?x ?xs => generalize dependent x; genDeps xs
      |HNil => idtac
    end.


(**
    Lightweight Linear F
    Steve Zdancewic and Karl Mazurak
*)

Require Export Metatheory.

(* ********************************************************************** *)
(** * ## Syntax (pre-terms) *)

Inductive kn : Set :=
  | kn_lin
  | kn_nonlin
.

Inductive typ : Set :=
  | typ_bvar : nat -> typ
  | typ_fvar : atom -> typ
  | typ_arrow : kn -> typ -> typ -> typ
  | typ_all : kn -> typ -> typ
.

Inductive exp : Set :=
  | exp_bvar : nat -> exp
  | exp_fvar : atom -> exp
  | exp_abs : kn -> typ -> exp -> exp
  | exp_app : exp -> exp -> exp
  | exp_tabs : kn -> exp -> exp
  | exp_tapp : exp -> typ -> exp
.

(** We declare the constructors for indices and variables to be
    coercions.  For example, if Coq sees a [nat] where it expects an
    [exp], it will implicitly insert an application of [exp_bvar];
    similar behavior happens for [atom]s.  Thus, we may write
    [(exp_abs typ_top (exp_app 0 x))] instead of [(exp_abs typ_top
    (exp_app (exp_bvar 0) (exp_fvar x)))]. *)

Coercion typ_bvar : nat >-> typ.
Coercion typ_fvar : atom >-> typ.
Coercion exp_bvar : nat >-> exp.
Coercion exp_fvar : atom >-> exp.

(* ********************************************************************** *)
(** * ## Opening terms *)

(** Opening replaces an index with a term.  This operation is required
    if we wish to work only with locally closed terms when going under
    binders (e.g., the typing rule for [exp_abs]).  It also
    corresponds to informal substitution for a bound variable, which
    occurs in the rule for beta reduction.

    We need to define three functions for opening due the syntax of
    Fsub, and we name them according to the following convention.
      - [tt]: Denotes an operation involving types appearing in types.
      - [te]: Denotes an operation involving types appearing in
        expressions.
      - [ee]: Denotes an operation involving expressions appearing in
        expressions.

    The notation used below for decidable equality on atoms and
    natural numbers (e.g., [K === J]) is defined in the [Metatheory]
    library.  The order of arguments to each "open" function is the
    same.  For example, [(open_tt_rec K U T)] can be read as
    "substitute [U] for index [K] in [T]."

    Note that we assume that [U] is locally closed (and similarly for
    the other opening functions).  This assumption simplifies the
    implementations of opening by letting us avoid shifting.  Since
    bound variables are indices, there is no need to rename variables
    to avoid capture.  Finally, we assume that these functions are
    initially called with index zero and that zero is the only unbound
    index in the term.  This eliminates the need to possibly subtract
    one in the case of indices. *)

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ)  {struct T} : typ :=
  match T with
  | typ_bvar J => if K === J then U else (typ_bvar J)
  | typ_fvar X => typ_fvar X
  | typ_arrow k T1 T2 => typ_arrow k (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_all k T2 => typ_all k (open_tt_rec (S K) U T2)
  end.

Fixpoint open_te_rec (K : nat) (U : typ) (e : exp) {struct e} : exp :=
  match e with
  | exp_bvar i => exp_bvar i
  | exp_fvar x => exp_fvar x
  | exp_abs k V e1 => exp_abs  k (open_tt_rec K U V)  (open_te_rec K U e1)
  | exp_app e1 e2 => exp_app  (open_te_rec K U e1) (open_te_rec K U e2)
  | exp_tabs k e1 => exp_tabs k  (open_te_rec (S K) U e1)
  | exp_tapp e1 V => exp_tapp (open_te_rec K U e1) (open_tt_rec K U V)
  end.

Fixpoint open_ee_rec (k : nat) (f : exp) (e : exp)  {struct e} : exp :=
  match e with
  | exp_bvar i => if k === i then f else (exp_bvar i)
  | exp_fvar x => exp_fvar x
  | exp_abs K V e1 => exp_abs K V (open_ee_rec (S k) f e1)
  | exp_app e1 e2 => exp_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  | exp_tabs K e1 => exp_tabs K (open_ee_rec k f e1)
  | exp_tapp e1 V => exp_tapp (open_ee_rec k f e1) V
  end.

(** Many common applications of opening replace index zero with an
    expression or variable.  The following definitions provide
    convenient shorthands for such uses.  Note that the order of
    arguments is switched relative to the definitions above.  For
    example, [(open_tt T X)] can be read as "substitute the variable
    [X] for index [0] in [T]" and "open [T] with the variable [X]."
    Recall that the coercions above let us write [X] in place of
    [(typ_fvar X)], assuming that [X] is an [atom]. *)

Definition open_tt T U := open_tt_rec 0 U T.
Definition open_te e U := open_te_rec 0 U e.
Definition open_ee e1 e2 := open_ee_rec 0 e2 e1.

(* ********************************************************************** *)
(** * ## Local closure *)

(** Recall that [typ] and [exp] define pre-terms; these datatypes
    admit terms that contain unbound indices.  A term is locally
    closed, or syntactically well-formed, when no indices appearing in
    it are unbound.  The proposition [(type T)] holds when a type [T]
    is locally closed, and [(expr e)] holds when an expression [e] is
    locally closed.

    The inductive definitions below formalize local closure such that
    the resulting induction principles serve as structural induction
    principles over (locally closed) types and (locally closed)
    expressions.  In particular, unlike the situation with pre-terms,
    there are no cases for indices.  Thus, these induction principles
    correspond more closely to informal practice than the ones arising
    from the definitions of pre-terms.

    The interesting cases in the inductive definitions below are those
    that involve binding constructs, e.g., [typ_all].  Intuitively, to
    check if the pre-term [(typ_all T1 T2)] is locally closed we much
    check that [T1] is locally closed, and that [T2] is locally closed
    when opened with a variable.  However, there is a choice as to how
    many variables to quantify over.  One possibility is to quantify
    over only one variable ("existential" quantification), as in
<<
  type_all : forall X T1 T2,
      type T1 ->
      type (open_tt T2 X) ->
      type (typ_all T1 T2)
>>  or we could quantify over as many variables as possible ("universal"
    quantification), as in
<<
  type_all : forall T1 T2,
      type T1 ->
      (forall X : atom, type (open_tt T2 X)) ->
      type (typ_all T1 T2)
>>  It is possible to show that the resulting relations are equivalent.
    The former makes it easy to build derivations, while the latter
    provides a strong induction principle.  McKinna and Pollack used
    both forms of this relation in their work on formalizing Pure Type
    Systems.

    We take a different approach here and use "cofinite
    quantification": we quantify over all but finitely many variables.
    This approach provides a convenient middle ground: we can build
    derivations reasonably easily and get reasonably strong induction
    principles.  With some work, one can show that the definitions
    below are equivalent to ones that use existential, and hence also
    universal, quantification. *)

Inductive type : typ -> Prop :=
  | type_var : forall X,
      type (typ_fvar X)
  | type_arrow : forall K T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow K T1 T2)
  | type_all : forall L K T2,
      (forall X : atom, X `notin` L -> type (open_tt T2 X)) ->
      type (typ_all K T2)
.

Inductive expr : exp -> Prop :=
  | expr_var : forall x,
      expr (exp_fvar x)
  | expr_abs : forall L K T e1,
      type T ->
      (forall x : atom, x `notin` L -> expr (open_ee e1 x)) ->
      expr (exp_abs K T e1)
  | expr_app : forall e1 e2,
      expr e1 ->
      expr e2 ->
      expr (exp_app e1 e2)
  | expr_tabs : forall L K e1,
      (forall X : atom, X `notin` L -> expr (open_te e1 X)) ->
      expr (exp_tabs K e1)
  | expr_tapp : forall e1 V,
      expr e1 ->
      type V ->
      expr (exp_tapp e1 V)
.

(* ********************************************************************** *)
(** * ## Environments *)

(** In our presentation of System F with subtyping, we use a single
    environment for both typing and subtyping assumptions.  We
    formalize environments by representing them as association lists
    (lists of pairs of keys and values) whose keys are atoms.

    The [Metatheory] and [Environment] libraries provide functions,
    predicates, tactics, notations and lemmas that simplify working
    with environments.  The [Environment] library treats environments
    as lists of type [list (atom * A)].

    Since environments map [atom]s, the type [A] should encode whether
    a particular binding is a typing or subtyping assumption.  Thus,
    we instantiate [A] with the type [binding], defined below. *)

Inductive binding : Set :=
  | bind_kn :  kn -> binding
  | bind_typ : typ -> binding.

Notation env := (list (atom * binding)).
Notation empty := (@nil (atom * binding)).

(** We also define a notation that makes it convenient to write one
    element lists.  This notation is useful because of our convention
    for building environments; see the examples below. *)

Notation "[ x ]" := (x :: nil).

(* ********************************************************************** *)
(** * ## Well-formedness *)

(** A type [T] is well-formed with respect to an environment [E],
    denoted [(wf_typ E T)], when [T] is locally-closed and its free
    variables are bound in [E].  We need this relation in order to
    restrict the subtyping and typing relations, defined below, to
    contain only well-formed types.  (This relation is missing in the
    original statement of the POPLmark Challenge.)

    Note: It is tempting to define the premise of [wf_typ_var] as [(X
    `in` dom E)], since that makes the rule easier to apply (no need
    to guess an instantiation for [U]).  Unfortunately, this is
    incorrect.  We need to check that [X] is bound as a type-variable,
    not an expression-variable; [(dom E)] does not distinguish between
    the two kinds of bindings. *)

Inductive wf_typ : env -> typ -> kn -> Prop :=
  | wf_typ_var : forall K E (X : atom),
      ok E ->
      binds X (bind_kn K) E ->
      wf_typ E (typ_fvar X) K
  | wf_typ_arrow : forall E K1 K2 K T1 T2,
      wf_typ E T1 K1 ->
      wf_typ E T2 K2 ->
      wf_typ E (typ_arrow K T1 T2) K
  | wf_typ_all : forall L E K1 K2 T2,
      (forall X : atom, X `notin` L ->
        wf_typ ([(X, bind_kn K1)] ++ E) (open_tt T2 X) K2) ->
      wf_typ E (typ_all K1 T2) K2
  | wf_typ_sub : forall E T,
      wf_typ E T kn_nonlin ->
      wf_typ E T kn_lin
.

(** An environment E is well-formed, denoted [(wf_env E)], if each
    atom is bound at most at once and if each binding is to a
    well-formed type.  This is a stronger relation than the [ok]
    relation defined in the [Environment] library.  We need this
    relation in order to restrict the subtyping and typing relations,
    defined below, to contain only well-formed environments.  (This
    relation is missing in the original statement of the POPLmark
    Challenge.)  *)

Inductive wf_env : env -> Prop :=
  | wf_env_empty :
      wf_env empty
  | wf_env_kn : forall (E : env) (X : atom) (K : kn),
      wf_env E ->
      X `notin` dom E ->
      wf_env ([(X, bind_kn K)] ++ E)
  | wf_env_typ : forall (E : env) (x : atom) (T : typ) (K : kn),
      wf_env E ->
      wf_typ E T K->
      x `notin` dom E ->
      wf_env ([(x, bind_typ T)] ++ E).

Inductive env_below_kn : env -> env -> kn -> Prop :=
  | env_below_empty : forall E K,
      wf_env E ->
      env_below_kn E empty K
  | env_below_bind_kn   : forall E G X K1 K,
      env_below_kn E G K ->
      wf_env ([(X, bind_kn K1)] ++ G ++ E) ->
      env_below_kn E ([(X, bind_kn K1)]++G) K
  | env_below_bind_typ  : forall E G x T K,
      env_below_kn E G K ->
      wf_env ([(x, bind_typ T)] ++ G ++ E) ->
      wf_typ (G ++ E) T K ->
      env_below_kn E ([(x, bind_typ T)] ++ G) K
.

(* env_split E1 E2 E3 G  ==  G |- E1 \join E2 = E3 *)
Inductive env_split : env -> env -> env -> env -> Prop :=
  | env_split_empty:  forall G, wf_env G -> env_split empty empty empty G
  | env_split_kn:  forall E1 E2 E3 X K G,
       env_split E1 E2 E3 G ->
       X `notin` dom E3 -> X `notin` dom G ->
       env_split ([(X, bind_kn K)]++E1) ([(X, bind_kn K)]++E2) ([(X, bind_kn K)]++E3) G
  | env_split_nonlin:  forall E1 E2 E3 T x G,
       env_split E1 E2 E3 G -> wf_typ (E3 ++ G) T kn_nonlin ->
       x `notin` dom E3 -> x `notin` dom G ->
       env_split ([(x, bind_typ T)]++E1) ([(x, bind_typ T)]++E2) ([(x, bind_typ T)]++E3) G
  | env_split_lin_left: forall E1 E2 E3 T x G,
       env_split E1 E2 E3 G -> wf_typ (E3 ++ G) T kn_lin ->
       x `notin` dom E2 -> x `notin` dom E3 -> x `notin` dom G ->
       env_split ([(x, bind_typ T)]++E1) E2 ([(x, bind_typ T)]++E3) G
  | env_split_lin_right: forall E1 E2 E3 T x G,
       env_split E1 E2 E3 G -> wf_typ (E3 ++ G) T kn_lin ->
       x `notin` dom E1 -> x `notin` dom E3 -> x `notin` dom G ->
       env_split E1 ([(x, bind_typ T)]++E2) ([(x, bind_typ T)]++E3) G
.

(* ********************************************************************** *)
(** * ## Values *)

Inductive value : exp -> Prop :=
  | value_abs : forall K T e1,
      expr (exp_abs K T e1) ->
      value (exp_abs K T e1)
  | value_tabs : forall K e1,
      expr (exp_tabs K e1) ->
      value (exp_tabs K e1)
.

(* ********************************************************************** *)
(** * ## Typing *)

Inductive typing : env -> exp -> typ -> Prop :=
  | typing_var : forall E1 E2 x T,
      wf_env (E2 ++ ([(x, bind_typ T)] ++ E1)) ->
      env_below_kn empty (E2 ++ E1) kn_nonlin ->
      typing (E2 ++ ([(x, bind_typ T)] ++ E1)) (exp_fvar x) T
  | typing_abs : forall L K E V e1 T1 K1,
      env_below_kn empty E K ->
      wf_typ E V K1 ->
      (forall x : atom, x `notin` L ->
        typing ([(x, bind_typ V)] ++ E) (open_ee e1 x) T1) ->
      typing E (exp_abs K V e1) (typ_arrow K V T1)
  | typing_app : forall T1 K E1 E2 E3 e1 e2 T2,
      typing E1 e1 (typ_arrow K T1 T2) ->
      typing E2 e2 T1 ->
      env_split E1 E2 E3 empty ->
      typing E3 (exp_app e1 e2) T2
  | typing_tabs : forall L E K e1 T1,
      value e1 ->
      (forall X : atom, X `notin` L ->
        typing ([(X, bind_kn K)] ++ E) (open_te e1 X) (open_tt T1 X)) ->
      typing E (exp_tabs K e1) (typ_all K T1)
  | typing_tapp : forall K E e1 T T2,
      typing E e1 (typ_all K T2) ->
      wf_typ E T K ->
      typing E (exp_tapp e1 T) (open_tt T2 T)
.

(* ********************************************************************** *)
(** * ## Reduction *)

Inductive red : exp -> exp -> Prop :=
  | red_app_1 : forall e1 e1' e2,
      expr e2 ->
      red e1 e1' ->
      red (exp_app e1 e2) (exp_app e1' e2)
  | red_app_2 : forall e1 e2 e2',
      value e1 ->
      red e2 e2' ->
      red (exp_app e1 e2) (exp_app e1 e2')
  | red_tapp : forall e1 e1' V,
      type V ->
      red e1 e1' ->
      red (exp_tapp e1 V) (exp_tapp e1' V)
  | red_abs : forall K T e1 v2,
      expr (exp_abs K T e1) ->
      value v2 ->
      red (exp_app (exp_abs K T e1) v2) (open_ee e1 v2)
  | red_tabs : forall K e1 T,
      expr (exp_tabs K e1) ->
      type T ->
      red (exp_tapp (exp_tabs K e1) T) (open_te e1 T)
.

(* ********************************************************************** *)
(** * ## Automation *)

(** We declare most constructors as [Hint]s to be used by the [auto]
    and [eauto] tactics.  We exclude constructors from the subtyping
    and typing relations that use cofinite quantification.  It is
    unlikely that [eauto] will find an instantiation for the finite
    set [L], and in those cases, [eauto] can take some time to fail.
    (A priori, this is not obvious.  In practice, one adds as hints
    all constructors and then later removes some constructors when
    they cause proof search to take too long.) *)

Hint Constructors type expr wf_typ wf_env value red.
Hint Resolve typing_var typing_app typing_tapp.