(** * Tutorial for QuickChick *)

(** QuickChick is a clone of Haskell's QuickCheck, slightly on
    steroids.  This tutorial explores basic aspects of random
    property-based testing and details the majority of features of
    QuickChick. *)

(* begin hide *)
From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Set Warnings "-extraction-opaque-accessed,-extraction".

Require Import List ZArith.
Import ListNotations.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

(* end hide *)

(** ** Introduction *)

(** It is not uncommon during a verification effort to spend many
    hours attempting to prove a slightly false theorem, only to result
    in frustration when the mistake is realized and one needs to start
    over. Other theorem provers have testing tools to quickly raise
    one's confidence before embarking on the body of the proof;
    Isabelle has its own QuickCheck clone, as well as Nitpick,
    Sledgehammer and a variety of other tools; ACL2 has gone a step
    further using random testing to facilitate its
    automation. QuickChick is meant to fill this void for Coq.

    Consider the following short function [remove] that takes a
    natural number [x] and a list of nats [l] and proceeds to remove
    [x] from the list. While one might be tempted to pose the question
    "Is there a bug in this definition?", such a question has little
    meaning without an explicit specification. Here, [removeP]
    requires that after removing [x] from [l], the resulting list does
    not contain any occurences of [x]. *)

Fixpoint remove (x : nat) (l : list nat) : list nat :=
  match l with
    | []   => []
    | h::t => if beq_nat h x then t else h :: remove x t
  end.

Definition removeP (x : nat) (l : list nat) :=
  (~~ (existsb (fun y => beq_nat y x) (remove x l))).

(** For this simple example, it is not hard to "spot" the bug by
    inspection. We will use QuickChick to find out what is wrong.

    QuickChick provides a toplevel command [QuickChick] that receives
    as input an executable property and attempts to falsify it. *)

QuickChick removeP.

(** Internally, the code is extracted to OCaml, compiled and ran to
obtain the output:
<<
    0

    [ 0, 0 ]

    Failed! After 17 tests and 12 shrinks
>>
    The output signifies that if we use an input where [x] is [0] and
    [l] is the two element list containing two zeros, then our
    property fails. Indeed, we can now identify that the [then] branch
    of [remove] fails to make a recursive call, which means that only
    one occurence of each element will be deleted. The last line of
    the output states that it took 17 tests to identify some fault
    inducing input and 12 shrinks to reduce it to a minimal
    counterexample.

    Before we begin to explain exactly how QuickChick magically comes
    up with this result, it is important to point out the first (and
    arguably most important) limitation of this tool: it requires an
    *executable* specification. QuickChick needs to be able to "run" a
    property and decide whether it is true or not; a definition like
    [remove_spec] can't be QuickChecked! *)

Definition remove_spec :=
  forall x l, ~ In x (remove x l).

(** QuickChick requires either a functional spec (like [removeP]) or a
    decidability procedure for an inductive spec. *)

(** ** Property Based Random Testing Ingredients

    There are four basic ingredients in property based random testing:

    - An executable property, as discussed above
    - A printer, to report counterexamples found
    - A generator, to produce random inputs
    - A shrinker, to reduce counterexamples.

    We will now review the latter three in order. *)

(** *** Printing

    For printing, QuickChick uses a [Show] typeclass, like Haskell. *)

Print Show.
(**  ==> Record Show (A : Type) : Type
            := Build_Show { show : A -> String.string }   *)

(** The [Show] typeclass contains a single function [show] from some
    type [A] to Coq's [string]. QuickChick provides default instances
    for [string]s (the identity function), [nat], [bool], [Z],
    etc. (via extraction to appropriate OCaml functions for
    efficiency), as well as some common compound datatypes: lists,
    pairs and options.

    Writing your own show instance is easy! Let's define a simple
    [Color] datatype. *)

Inductive Color := Red | Green | Blue | Yellow.

(** After ensuring we have opened the [string] scope, we can declare
    an instance of [Show Color] by encoding [show] as a simple pattern
    matching on colors. *)

Require Import String. Open Scope string.
Instance show_color : Show Color :=
  {| show c :=
       match c with
         | Red    => "Red"
         | Green  => "Green"
         | Blue   => "Blue"
         | Yellow => "Yellow"
       end
  |}.

Eval compute in (show Green).
(** ==> "Green" : string *)

(** While writing show instances is relatively straightforward, it can
    get tedious.  The QuickChick provides a lot of automation, which
    will be discussed at the end of this Tutorial. *)

(** *** Generators *)

(** **** The [G] Monad *)

(** The heart of property based random testing is the random
    generation of inputs.  In QuickChick, a generator for elements of
    some type [A] is a monadic object with type [G A]. The monad [G]
    serves as an abstraction over random seed plumbing. Consider
    writing a program that given a random seed generates many
    integers: one needs to use the given seed to produce an integer
    while at the same time obtain a new, altered seed to use for
    future draws. This [State]-monad like behavior is hidden behind
    [G].

    Standard monadic functions have the [Gen] suffix. *)

Check bindGen.
(** ==> bindGen : G ?A -> (?A -> G ?B) -> G ?B *)

Check returnGen.
(** ==> returnGen : ?A -> G ?A *)

(** For those familiar with Haskell's monadic interface, QuickChick
    also provides variants of [liftM] (as [liftGen]) with arities 1 to
    5, [sequence] (as [sequenceGen]) and [foldM] (as [foldGen]). *)

(** **** Primitive generators *)

(** Primitive generators for booleans, natural numbers and integers
    are provided via extraction to OCaml. They can be accessed via the
    [choose] combinator.
 *)

Check choose.
(** ==> choose : Z * Z -> G Z *)

(** While here [choose] is monomorphised to [Z], it actually takes an
    interval of any type [A] that satisfies a [ChoosableFromInterval]
    typeclass (with default standard numeric instances) and produces
    an object of type [A] within that interval.

    We can see that in action using [Sample]. This is another toplevel
    command by QuickChick that runs a generator a number of times and
    prints whatever was generated in the form of a list. *)

Sample (choose(0, 10)).
(** ==> [ 1, 2, 1, 9, 8, 1, 3, 6, 2, 1, 8, 0, 1, 1, 3, 5, 4, 10, 4, 6 ] *)

(** **** Lists *)

(** Due to being the most commonly used compound datatype, lists have
    special combinators in Haskell's QuickCheck. The same is true in
    QuickChick; there are two combinators, [listOf] and [vectorOf]. *)

Check listOf.
(** ==> listOf : G ?A -> G (list ?A) *)

(** [listOf] takes as input a generator for elements of type [A] and returns a
    generator for lists of the same type. *)

Sample (listOf (choose (0,4))).
(** ==> [ [ 0, 3, 2, 0 ],
         [ 1, 3, 4, 1, 0, 3, 0, 2, 2, 3, 2, 2, 2, 0, 4, 2, 3, 0, 1 ],
         [ 3, 4, 3, 1, 2, 4, 4, 1, 0, 3, 4, 3, 2, 2, 4, 4, 1 ],
         [ 0 ],
         [ 4, 2, 3 ],
         [ 3, 3, 4, 0, 1, 4, 3, 2, 4, 1 ],
         [ 0, 4 ],
         [  ],
         [ 1, 0, 1, 3, 1 ],
         [ 0, 0 ],
         [ 1, 4 ],
         [ 4, 3, 2, 0, 2, 2, 4, 0 ],
         [ 1, 1, 0, 0, 1, 4 ],
         [ 2, 0, 2, 1, 3, 3 ],
         [ 4, 3, 3, 0, 1 ],
         [ 3, 3, 3 ],
         [ 3, 2, 4 ],
         [ 1, 2 ],
         [  ],
         [  ]
       ]
*)

(** The second combinator, [vectorOf], receives an additional numeric
    argument [n], the length of the list to be generated. *)

Check vectorOf.
(** ==> vectorOf : nat -> G ?A -> G (list ?A) *)

(** This raises a question: how does [listOf] decide how big of a list
    to generate? The answer is hidden inside the [G] monad.

    In addition to handling random seed plumbing, the [G] monad also
    provides a [Reader]-like environment with size information: a
    natural number [n] that nominally serves as the upper bound on the
    depth of the generated objects.  QuickChick progressively tries
    larger and larger values for [n], in order to explore larger and
    deeper part of the search space. Note that each generator can
    choose to interpret this input size however it wants and there is
    no guarantee that all generators comply to this standard - it is
    more of a "good practice" when writing one to respect this
    bound. *)

(** **** Custom Datatypes *)

(** Naturally, a lot of the time one needs to write generators involving
    user-defined datatypes. Let's revisit our color datatype; to generate a
    color, we only need to pick one of its four constructors, [Red], [Green],
    [Blue] and [Yellow]. This is done using [elements]. *)

Check elements.
(** ==> elements : ?A -> list ?A -> G ?A *)

(** This is the first place where the totality checker of Coq raises a
    design question. While Haskell's QuickCheck can simply fail
    raising an [error] whenever the input list is empty, Coq does not
    allow that behavior. Instead of increasing the burden to the user
    by requiring a proof that the list is not empty or by making the
    return type an option, QuickChick requires an additional element
    of type [A] as input to serve as a "default" object.  If the list
    is not empty, [elements] returns a generator that picks an element
    of that list; otherwise the generator always returns the default
    object.

    Moreover, QuickChick provides convenient notation to hide this
    default if it is apparent from the structure. *)

(*
Notation            Scope
" 'elems' [ x ] " := elements x (cons x nil)
                      : qc_scope
                      (default interpretation)
" 'elems' [ x ; y ] " := elements x (cons x (cons y nil))
                      : qc_scope
                      (default interpretation)
" 'elems' [ x ; y ; .. ; z ] " := elements x
                                    (cons x (cons y .. (cons z nil) ..))
                      : qc_scope
                      (default interpretation)
" 'elems' ( x ;; l ) " := elements x (cons x l)
                      : qc_scope
                      (default interpretation)
*)

(** Armed with [elems], we can write the following simple [Color]
    generator. *)

Definition genColor : G Color :=
  elems [ Red ; Green ; Blue ; Yellow ].

Sample genColor.
(** ==> [ Blue, Red, Yellow, Red, Blue, Yellow, Yellow, Blue, Green, Red, Green,
         Blue, Blue, Red, Yellow, Blue, Red, Blue, Blue, Red ] *)

(** For more complicated ADTs, QuickChick provides more
    combinators. We will showcase them using everyone's favorite
    datatype: Trees!

    Our trees are standard binary trees; either [Leaf]s or [Node]s
    containing some payload of type [A] and two subtrees. *)

Inductive Tree A :=
| Leaf : Tree A
| Node : A -> Tree A -> Tree A -> Tree A.

Arguments Leaf {A}.
Arguments Node {A} _ _ _.

(** Before getting to generators for trees, we give a simple [Show]
    instance.  The rather inconvenient need for a local [let fix]
    declaration stems from the fact that Coq's typeclasses (unlike
    Haskell's) are not automatically recursive. *)

Instance showTree {A} `{_ : Show A} : Show (Tree A) :=
  {| show :=
       let fix aux t :=
         match t with
           | Leaf => "Leaf"
           | Node x l r => "Node (" ++ show x ++ ") (" ++ aux l ++ ") (" ++ aux r ++ ")"
         end
       in aux
  |}.

(** The first combinator that actually combines different generators
    is [oneof]. *)

Check oneof.
(** ==> oneof : G ?A -> list (G ?A) -> G ?A *)

(** [oneof] takes a default generator and a list of generators, and
    picks one of the generators from the list uniformly at random, as
    long as the list is not empty.  Just like before, QuickChick
    introduces the notation [oneOf] to hide this default element.

    At this point, Coq's termination checker saves us from shooting
    ourselves in the foot. The "obvious" first generator that one
    might write is the following [genTree]: either generate a [Leaf]
    or a [Node] whose subtrees are generated recursively and whose
    payload is produced by a generator for elements of type [A].*)

(*
Fixpoint genTree {A} (g : G A) : G (Tree A) :=
  oneOf [ returnGen Leaf ;
          liftGen3 Node  g (genTree g) (genTree g) ].*)

(** Of course, this fixpoint will not pass Coq's termination
    check. Attempting to justify this fixpoint to oneself, one might
    say that at some point the random generation will pick a [Leaf] so
    it will eventually terminate. Sadly, in this case the expected
    size of the generated Tree is infinite...

    The solution is the standard "fuel" solution Coq users are so
    familiar with: we add an additional natural number [sz] as a
    parameter; when that parameter is [O] we only generate
    non-recursive branches, while we decrease this size in each
    recursive call. Thus, [sz] serves as a bound on the depth of the
    tree.

 *)

Fixpoint genTreeSized {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => returnGen Leaf
    | S sz' => oneOf [ returnGen Leaf ;
                       liftGen3  Node g (genTreeSized sz' g) (genTreeSized sz' g)
                     ]
  end.

Sample (genTreeSized 3 (choose(0,3))).
(** ==> [ Leaf,
         Leaf,
         Node (3) (Node (0) (Leaf) (Leaf)) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))),
         Leaf,
         Leaf,
         Leaf,
         Node (1) (Leaf) (Node (1) (Leaf) (Node (0) (Leaf) (Leaf))),
         Leaf,
         Node (3) (Leaf) (Leaf),
         Node (1) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Node (0) (Leaf) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (0) (Node (2) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
         Node (0) (Leaf) (Leaf),
         Leaf,
         Leaf,
         Leaf,
         Leaf,
         Leaf ]
*)

(** While this generator succesfully generated trees, just by
    observing [Sample] above there is a problem: [genTreeSized]
    produces way too many [Leaf]s! That is to be expected, 50% of the
    time we generate a [Leaf]. The solution is to skew the
    distribution towards [Node]s, using the most expressive QuickChick
    combinator, [frequency] and its associated default-lifting
    notation [freq].
 *)
Check frequency.
(** ==> frequency : G ?A -> seq (nat * G ?A) -> G ?A *)

(** [freq] takes a list of generators, each one tagged with a natural
    number that serves as the weight of that generator. In the
    following example, a [Leaf] will be generated 1 / (sz + 1) of the
    time, while a [Node] the remaining sz / (sz + 1) of the time.*)

Fixpoint genTreeSized' {A} (sz : nat) (g : G A) : G (Tree A) :=
  match sz with
    | O => returnGen Leaf
    | S sz' => freq [ (1,  returnGen Leaf) ;
                      (sz, liftGen3  Node g (genTreeSized' sz' g) (genTreeSized' sz' g))
                    ]
  end.

Sample (genTreeSized' 3 (choose(0,3))).
(** ==> [ Node (3) (Node (1) (Node (3) (Leaf) (Leaf)) (Leaf)) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))),
         Leaf,
         Node (2) (Node (1) (Leaf) (Leaf)) (Leaf),
         Node (0) (Leaf) (Node (0) (Node (2) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))),
         Node (1) (Node (2) (Leaf) (Node (0) (Leaf) (Leaf))) (Leaf),
         Node (0) (Node (0) (Leaf) (Node (3) (Leaf) (Leaf))) (Node (2) (Leaf) (Leaf)),
         Node (1) (Node (3) (Node (2) (Leaf) (Leaf)) (Node (3) (Leaf) (Leaf))) (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (0) (Node (0) (Node (0) (Leaf) (Leaf)) (Node (1) (Leaf) (Leaf))) (Node (2) (Node (3) (Leaf) (Leaf)) (Node (0) (Leaf) (Leaf))),
         Node (2) (Node (2) (Leaf) (Leaf)) (Node (1) (Node (2) (Leaf) (Leaf)) (Node (2) (Leaf) (Leaf))),
         Node (2) (Node (3) (Node (2) (Leaf) (Leaf)) (Leaf)) (Node (0) (Node (2) (Leaf) (Leaf)) (Leaf)),
         Leaf,
         Node (2) (Node (3) (Node (3) (Leaf) (Leaf)) (Leaf)) (Leaf),
         Leaf,
         Node (1) (Leaf) (Leaf),
         Leaf,
         Node (1) (Node (2) (Leaf) (Node (3) (Leaf) (Leaf))) (Node (0) (Leaf) (Node (1) (Leaf) (Leaf))),
         Leaf,
         Node (3) (Node (0) (Node (0) (Leaf) (Leaf)) (Leaf)) (Node (0) (Leaf) (Node (2) (Leaf) (Leaf))),
         Node (2) (Node (2) (Node (0) (Leaf) (Leaf)) (Leaf)) (Node (1) (Leaf) (Node (2) (Leaf) (Leaf))),
         Leaf ]
 *)

(** To showcase this generator, we will use the notion of mirroring a
    tree: swapping its left and right subtrees recursively. *)

Fixpoint mirror {A : Type} (t : Tree A) : Tree A :=
  match t with
    | Leaf => Leaf
    | Node x l r => Node x (mirror r) (mirror l)
  end.

(** We also need a simple structural equality on trees *)
Fixpoint eq_tree (t1 t2 : Tree nat) : bool :=
  match t1, t2 with
    | Leaf, Leaf => true
    | Node x1 l1 r1, Node x2 l2 r2 =>
      beq_nat x1 x2 && eq_tree l1 l2 && eq_tree r1 r2
    | _, _ => false
  end.

(** One expects that [mirror] should be unipotent; mirroring a tree
    twice yields the original tree.  *)

Definition mirrorP (t : Tree nat) := eq_tree (mirror (mirror t)) t.

(** To test this assumption, we can use the [forAll] property
    combinator that receives a generator [g] for elements of type [A]
    and an executable property with argument [A] and tests the
    property on random inputs of [g]. *)

QuickChick (forAll (genTreeSized' 5 (choose (0,5))) mirrorP).

(** QuickChick quickly responds that this property passed 10000 tests,
    so we gain some confidence in its truth. But what would happend if
    we had the *wrong* property? *)

Definition faultyMirrorP (t : Tree nat) := eq_tree (mirror t) t.

QuickChick (forAll (genTreeSized' 5 (choose (0,5))) faultyMirrorP).
(** ==> Node (3) (Node (0) (Leaf) (Node (0) (Node (1) (Leaf) (Leaf)) (Leaf)))
(Node (5) (Node (0) (Node (1) (Leaf) (Node (4) (Leaf) (Leaf))) (Node (4) (Leaf)
(Node (0) (Leaf) (Leaf)))) (Node (5) (Node (4) (Node (0) (Leaf) (Leaf)) (Leaf))
(Node (3) (Leaf) (Leaf))))

*** Failed! After 1 tests and 0 shrinks
*)

(** The bug is found immediately and reported. However, is this counterexample
    really helpful? What is the important part of it? The reported bug is too
    big and noisy to identify the root cause of the problem. That is where
    shrinking comes in. *)

(** **** Shrinking *)

(** Shrinking, also known as delta debugging, is a greedy process by
    which we can find a smaller counterexample given a relatively
    large one. Given a shrinking function [s] of type [A -> list A]
    and a counterexample [x] of type [A] that is known to falsify some
    property [p], QuickChick (lazily) tries [p] on all members of [s
    x] until it finds another counterexample; then it repeats this
    process.

    This greedy algorithm can only work if all elements of [s x] are
    strictly "smaller" that [x] for all [x]. Most of the time, a
    shrinking function for some type only returns elements that are
    "one step" smaller. For example, consider the default shrinking
    function for lists provided by QuickChick. *)

Print shrinkList.
(** ==> shrinkList =
     fix shrinkList (A : Type) (shr : A -> seq A) (l : seq A) {struct l} :
       seq (seq A) :=
       match l with
       | [::] => [::]
       | x :: xs =>
           ((xs :: List.map (fun xs' : seq A => x :: xs') (shrinkList A shr xs))%SEQ ++
            List.map (fun x' : A => (x' :: xs)%SEQ) (shr x))%list
       end
          : forall A : Type, (A -> seq A) -> seq A -> seq (seq A)
*)

(** An empty list can not be shrunk - there is no smaller list.  A
    cons cell can be shrunk in three ways: by returning the tail of
    the list, by shrinking the tail of the list and consing the head,
    or by shrinking the head and consing its tail. By induction, this
    process can generate all smaller lists.

    Writing a shrinking instance for trees is equally straightforward:
    we don't shrink [Leaf]s while for [Node]s we can return the left
    or right subtrees, shrink the payload or one of the subtrees.*)

Open Scope list.
Fixpoint shrinkTree {A} (s : A -> list A) (t : Tree A) : seq (Tree A) :=
  match t with
    | Leaf => []
    | Node x l r => [l] ++ [r] ++
                    map (fun x' => Node x' l r) (s x) ++
                    map (fun l' => Node x l' r) (shrinkTree s l) ++
                    map (fun r' => Node x l r') (shrinkTree s r)
  end.

(** Armed with [shrinkTree], we use the [forAllShrink] property
    combinator that takes an additional argument, a shrinker *)

QuickChick (forAllShrink (genTreeSized' 5 (choose (0,5))) (shrinkTree shrink) faultyMirrorP).

(** ==> Node (0) (Leaf) (Node (0) (Leaf) (Leaf))

*** Failed! After 1 tests and 8 shrinks *)

(** We now got a much simpler counterexample (in fact, this is one of
    the two minimal ones) and can tell that the real problem occurs
    when the subtrees of a [Node] are different. *)

(** **** Putting it all Together *)

(** QuickChick, just like QuickCheck, provides an [Arbitrary]
    typeclass parameterized over some type [A] with two objects:
    [arbitrary] and [shrink].

    The [arbitrary] object is a generator for elements of type [A]. If
    we were to encode an [Arbitrary] instance for trees we would like
    to use [genTreeSized']; however that generator takes an additional
    size argument.  The [G] monad will provide that argument through
    the combinator [sized].*)

Check sized.
(** ==> sized : (nat -> G ?A) -> G ?A *)

(** [sized] receives a function that given a number produces a
    generator, just like [genTreeSized'], and returns a generator that
    uses the size information inside the [G] monad.

    The [shrink] function is simply a shrinker like [shrinkTree]. *)

Instance genTree {A} `{Gen A} : GenSized (Tree A) :=
  {| arbitrarySized n := genTreeSized n arbitrary |}.

Instance shrTree {A} `{Shrink A} : Shrink (Tree A) :=
  {| shrink x := shrinkTree shrink x |}.

(** With this [Arbitrary] instance we can once again use the toplevel
    [QuickChick] command with just the property.  *)

QuickChick faultyMirrorP.

(** [QuickChick] internally calls the function [quickCheck] with type
    [forall prop. Checkable prop => prop -> Result]. But what _is_
    [Checkable]? It is easy to see how a boolean is [Checkable]; we
    can always tell if it is true or not and then return a [Result],
    [Success]/[Failure] as appropriate.

    To see how executable properties are [Checkable], consider a
    single argument function [p : A -> Bool] that returns a
    boolean. If we know that [A] has [Show] and [Arbitrary] instances,
    we can just call [forAllShrink] with [arbitrary] and
    [shrink]. Going a step further, the result type doesn't really
    need to be [Bool], it can be a [Checkable]! Thus, we can provide a
    [Checkable] instance for arbitrary functions.*)

Print testFun.

(** **** Collecting Statistics *)

(** Earlier in this tutorial we claimed that [genTreeSized] produced
    "too many" [Leaf]s. But how can we justify that? Just looking at
    the result of [Sample] gives us an idea that something is going
    wrong but just observing a handful of samples cannot realistically
    provide statistical guarantees. That is where [collect], another
    property combinator, comes in. In Haskell notation, [collect]
    would have the type [collect : Show A, Checkable prop => A -> prop
    -> prop]; it takes some value of type [A] that can be shown and a
    property, and returns the property itself. Whenever the resulting
    property is exercised, the [A] object is captured and statistics
    are collected.

    For example, consider a [size] function on [Tree]s.
 *)

Fixpoint size {A} (t : Tree A) : nat :=
  match t with
    | Leaf => O
    | Node _ l r => 1 + size l + size r
  end.

(** If we were to write a dummy property to check our generators and
    measure the size of generated trees, we could use [treeProp]
    below. *)

Definition treeProp (g : nat -> G nat -> G (Tree nat)) n :=
  forAll (g n (choose (0,n))) (fun t =>
  collect (size t) true).

QuickChick (treeProp genTreeSized  5).

(** ==>
4947 : 0
1258 : 1
673 : 2
464 : 6
427 : 5
393 : 3
361 : 7
302 : 4
296 : 8
220 : 9
181 : 10
127 : 11
104 : 12
83 : 13
64 : 14
32 : 15
25 : 16
16 : 17
13 : 18
6 : 19
5 : 20
2 : 21
1 : 23
+++ OK, passed 10000 tests

We see that 62.5% of the tests are either [Leaf]s or empty [Nodes], while too
few tests have larger sizes. Compare that with [genTreeSized'] below.  *)

QuickChick (treeProp genTreeSized' 5).
(** ==>
1624 : 0
571 : 10
564 : 12
562 : 11
559 : 9
545 : 8
539 : 14
534 : 13
487 : 7
487 : 15
437 : 16
413 : 6
390 : 17
337 : 5
334 : 1
332 : 18
286 : 19
185 : 4
179 : 20
179 : 2
138 : 21
132 : 3
87 : 22
62 : 23
19 : 24
10 : 25
6 : 26
2 : 27
+++ OK, passed 10000 tests

A lot fewer terms have small sizes, allowing us to explore larger terms*)

(** ** Avoiding Work  :) *)

(** While a lot of time putting a bit of time and effort in a
    generator and a shrinker, the examples shown here are fairly
    straightforward. After writing a couple of [Show] and [Arbitrary]
    instances, it can get tedious and boring. That is precisely why
    [QuickChick] provides some automation in deriving such instances
    for _plain_ datatypes automatically. *)

Derive Arbitrary for Tree.
(* GenSizedTree is defined *)
(* ShrinkTree is defined *)
Print GenSizedTree.
Print ShrinkTree.

Derive Show for Tree.
(* ShowTree is defined *)
Print ShowTree.


(** This file extends the HeapLang program logic with some derived laws (not
using the lifting lemmas) about arrays and prophecies.

For utility functions on arrays (e.g., freeing/copying an array), see
[heap_lang.lib.array].  *)

From stdpp Require Import fin_maps.
From iris.bi Require Import lib.fractional.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Export primitive_laws.
From iris.heap_lang Require Import tactics notation.
From iris Require Import options.

(** The [array] connective is a version of [mapsto] that works
with lists of values. *)

Definition array `{!heapG Σ} (l : loc) (q : Qp) (vs : list val) : iProp Σ :=
  ([∗ list] i ↦ v ∈ vs, (l +ₗ i) ↦{q} v)%I.
Notation "l ↦∗{ q } vs" := (array l q vs)
  (at level 20, q at level 50, format "l  ↦∗{ q }  vs") : bi_scope.
Notation "l ↦∗ vs" := (array l 1 vs)
  (at level 20, format "l  ↦∗  vs") : bi_scope.

(** We have [FromSep] and [IntoSep] instances to split the fraction (via the
[AsFractional] instance below), but not for splitting the list, as that would
lead to overlapping instances. *)

Section lifting.
Context `{!heapG Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val → iProp Σ.
Implicit Types σ : state.
Implicit Types v : val.
Implicit Types vs : list val.
Implicit Types q : Qp.
Implicit Types l : loc.
Implicit Types sz off : nat.

Global Instance array_timeless l q vs : Timeless (array l q vs) := _.

Global Instance array_fractional l vs : Fractional (λ q, l ↦∗{q} vs)%I := _.
Global Instance array_as_fractional l q vs :
  AsFractional (l ↦∗{q} vs) (λ q, l ↦∗{q} vs)%I q.
Proof. split; done || apply _. Qed.

Lemma array_nil l q : l ↦∗{q} [] ⊣⊢ emp.
Proof. by rewrite /array. Qed.

Lemma array_singleton l q v : l ↦∗{q} [v] ⊣⊢ l ↦{q} v.
Proof. by rewrite /array /= right_id loc_add_0. Qed.

Lemma array_app l q vs ws :
  l ↦∗{q} (vs ++ ws) ⊣⊢ l ↦∗{q} vs ∗ (l +ₗ length vs) ↦∗{q} ws.
Proof.
  rewrite /array big_sepL_app.
  setoid_rewrite Nat2Z.inj_add.
  by setoid_rewrite loc_add_assoc.
Qed.

Lemma array_cons l q v vs : l ↦∗{q} (v :: vs) ⊣⊢ l ↦{q} v ∗ (l +ₗ 1) ↦∗{q} vs.
Proof.
  rewrite /array big_sepL_cons loc_add_0.
  setoid_rewrite loc_add_assoc.
  setoid_rewrite Nat2Z.inj_succ.
  by setoid_rewrite Z.add_1_l.
Qed.

Global Instance array_cons_frame l q v vs R Q :
  Frame false R (l ↦{q} v ∗ (l +ₗ 1) ↦∗{q} vs) Q →
  Frame false R (l ↦∗{q} (v :: vs)) Q.
Proof. by rewrite /Frame array_cons. Qed.

Lemma update_array l q vs off v :
  vs !! off = Some v →
  ⊢ l ↦∗{q} vs -∗ ((l +ₗ off) ↦{q} v ∗ ∀ v', (l +ₗ off) ↦{q} v' -∗ l ↦∗{q} <[off:=v']>vs).
Proof.
  iIntros (Hlookup) "Hl".
  rewrite -[X in (l ↦∗{_} X)%I](take_drop_middle _ off v); last done.
  iDestruct (array_app with "Hl") as "[Hl1 Hl]".
  iDestruct (array_cons with "Hl") as "[Hl2 Hl3]".
  assert (off < length vs) as H by (apply lookup_lt_is_Some; by eexists).
  rewrite take_length min_l; last by lia. iFrame "Hl2".
  iIntros (w) "Hl2".
  clear Hlookup. assert (<[off:=w]> vs !! off = Some w) as Hlookup.
  { apply list_lookup_insert. lia. }
  rewrite -[in (l ↦∗{_} <[off:=w]> vs)%I](take_drop_middle (<[off:=w]> vs) off w Hlookup).
  iApply array_app. rewrite take_insert; last by lia. iFrame.
  iApply array_cons. rewrite take_length min_l; last by lia. iFrame.
  rewrite drop_insert_gt; last by lia. done.
Qed.

(** * Rules for allocation *)
Lemma mapsto_seq_array l q v n :
  ([∗ list] i ∈ seq 0 n, (l +ₗ (i : nat)) ↦{q} v) -∗
  l ↦∗{q} replicate n v.
Proof.
  rewrite /array. iInduction n as [|n'] "IH" forall (l); simpl.
  { done. }
  iIntros "[$ Hl]". rewrite -fmap_S_seq big_sepL_fmap.
  setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l.
  setoid_rewrite <-loc_add_assoc. iApply "IH". done.
Qed.

Lemma twp_allocN s E v n :
  (0 < n)%Z →
  [[{ True }]] AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  [[{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }]].
Proof.
  iIntros (Hzs Φ) "_ HΦ". iApply twp_allocN_seq; [done..|].
  iIntros (l) "Hlm". iApply "HΦ".
  iDestruct (big_sepL_sep with "Hlm") as "[Hl $]".
  by iApply mapsto_seq_array.
Qed.
Lemma wp_allocN s E v n :
  (0 < n)%Z →
  {{{ True }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  {{{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
Proof.
  iIntros (? Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_allocN; [auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_allocN_vec s E v n :
  (0 < n)%Z →
  [[{ True }]]
    AllocN #n v @ s ; E
  [[{ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }]].
Proof.
  iIntros (Hzs Φ) "_ HΦ". iApply twp_allocN; [ lia | done | .. ].
  iIntros (l) "[Hl Hm]". iApply "HΦ". rewrite vec_to_list_replicate. iFrame.
Qed.
Lemma wp_allocN_vec s E v n :
  (0 < n)%Z →
  {{{ True }}}
    AllocN #n v @ s ; E
  {{{ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
Proof.
  iIntros (? Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_allocN_vec; [auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

(** * Rules for accessing array elements *)
Lemma twp_load_offset s E l q off vs v :
  vs !! off = Some v →
  [[{ l ↦∗{q} vs }]] ! #(l +ₗ off) @ s; E [[{ RET v; l ↦∗{q} vs }]].
Proof.
  iIntros (Hlookup Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_load with "Hl1"). iIntros "Hl1". iApply "HΦ".
  iDestruct ("Hl2" $! v) as "Hl2". rewrite list_insert_id; last done.
  iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_load_offset s E l q off vs v :
  vs !! off = Some v →
  {{{ ▷ l ↦∗{q} vs }}} ! #(l +ₗ off) @ s; E {{{ RET v; l ↦∗{q} vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_load_offset with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_load_offset_vec s E l q sz (off : fin sz) (vs : vec val sz) :
  [[{ l ↦∗{q} vs }]] ! #(l +ₗ off) @ s; E [[{ RET vs !!! off; l ↦∗{q} vs }]].
Proof. apply twp_load_offset. by apply vlookup_lookup. Qed.
Lemma wp_load_offset_vec s E l q sz (off : fin sz) (vs : vec val sz) :
  {{{ ▷ l ↦∗{q} vs }}} ! #(l +ₗ off) @ s; E {{{ RET vs !!! off; l ↦∗{q} vs }}}.
Proof. apply wp_load_offset. by apply vlookup_lookup. Qed.

Lemma twp_store_offset s E l off vs v :
  is_Some (vs !! off) →
  [[{ l ↦∗ vs }]] #(l +ₗ off) <- v @ s; E [[{ RET #(); l ↦∗ <[off:=v]> vs }]].
Proof.
  iIntros ([w Hlookup] Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_store with "Hl1"). iIntros "Hl1".
  iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_store_offset s E l off vs v :
  is_Some (vs !! off) →
  {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ <[off:=v]> vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_store_offset with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
  [[{ l ↦∗ vs }]] #(l +ₗ off) <- v @ s; E [[{ RET #(); l ↦∗ vinsert off v vs }]].
Proof.
  setoid_rewrite vec_to_list_insert. apply twp_store_offset.
  eexists. by apply vlookup_lookup.
Qed.
Lemma wp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
  {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ vinsert off v vs }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_store_offset_vec with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
  vs !! off = Some v' →
  v' = v1 →
  vals_compare_safe v' v1 →
  [[{ l ↦∗ vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (v', #true); l ↦∗ <[off:=v2]> vs }]].
Proof.
  iIntros (Hlookup ?? Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_cmpxchg_suc with "Hl1"); [done..|].
  iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
  vs !! off = Some v' →
  v' = v1 →
  vals_compare_safe v' v1 →
  {{{ ▷ l ↦∗ vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (v', #true); l ↦∗ <[off:=v2]> vs }}}.
Proof.
  iIntros (??? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_suc_offset with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off = v1 →
  vals_compare_safe (vs !!! off) v1 →
  [[{ l ↦∗ vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs }]].
Proof.
  intros. setoid_rewrite vec_to_list_insert. eapply twp_cmpxchg_suc_offset=> //.
  by apply vlookup_lookup.
Qed.
Lemma wp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off = v1 →
  vals_compare_safe (vs !!! off) v1 →
  {{{ ▷ l ↦∗ vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs }}}.
Proof.
  iIntros (?? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_suc_offset_vec with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_fail_offset s E l q off vs v0 v1 v2 :
  vs !! off = Some v0 →
  v0 ≠ v1 →
  vals_compare_safe v0 v1 →
  [[{ l ↦∗{q} vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (v0, #false); l ↦∗{q} vs }]].
Proof.
  iIntros (Hlookup HNEq Hcmp Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_cmpxchg_fail with "Hl1"); first done.
  { destruct Hcmp; by [ left | right ]. }
  iIntros "Hl1". iApply "HΦ". iDestruct ("Hl2" $! v0) as "Hl2".
  rewrite list_insert_id; last done. iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_cmpxchg_fail_offset s E l q off vs v0 v1 v2 :
  vs !! off = Some v0 →
  v0 ≠ v1 →
  vals_compare_safe v0 v1 →
  {{{ ▷ l ↦∗{q} vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (v0, #false); l ↦∗{q} vs }}}.
Proof.
  iIntros (??? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_fail_offset with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_fail_offset_vec s E l q sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off ≠ v1 →
  vals_compare_safe (vs !!! off) v1 →
  [[{ l ↦∗{q} vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (vs !!! off, #false); l ↦∗{q} vs }]].
Proof. intros. eapply twp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.
Lemma wp_cmpxchg_fail_offset_vec s E l q sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off ≠ v1 →
  vals_compare_safe (vs !!! off) v1 →
  {{{ ▷ l ↦∗{q} vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (vs !!! off, #false); l ↦∗{q} vs }}}.
Proof. intros. eapply wp_cmpxchg_fail_offset=> //. by apply vlookup_lookup. Qed.

Lemma twp_faa_offset s E l off vs (i1 i2 : Z) :
  vs !! off = Some #i1 →
  [[{ l ↦∗ vs }]] FAA #(l +ₗ off) #i2 @ s; E
  [[{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }]].
Proof.
  iIntros (Hlookup Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_faa with "Hl1").
  iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_faa_offset s E l off vs (i1 i2 : Z) :
  vs !! off = Some #i1 →
  {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 @ s; E
  {{{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_faa_offset with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
  vs !!! off = #i1 →
  [[{ l ↦∗ vs }]] FAA #(l +ₗ off) #i2 @ s; E
  [[{ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs }]].
Proof.
  intros. setoid_rewrite vec_to_list_insert. apply twp_faa_offset=> //.
  by apply vlookup_lookup.
Qed.
Lemma wp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
  vs !!! off = #i1 →
  {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 @ s; E
  {{{ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_faa_offset_vec with "H"); [eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

(** Derived prophecy laws *)

(** Lemmas for some particular expression inside the [Resolve]. *)
Lemma wp_resolve_proph s E (p : proph_id) (pvs : list (val * val)) v :
  {{{ proph p pvs }}}
    ResolveProph (Val $ LitV $ LitProphecy p) (Val v) @ s; E
  {{{ pvs', RET (LitV LitUnit); ⌜pvs = (LitV LitUnit, v)::pvs'⌝ ∗ proph p pvs' }}}.
Proof.
  iIntros (Φ) "Hp HΦ". iApply (wp_resolve with "Hp"); first done.
  iApply lifting.wp_pure_step_later=> //=. iApply wp_value.
  iIntros "!>" (vs') "HEq Hp". iApply "HΦ". iFrame.
Qed.

Lemma wp_resolve_cmpxchg_suc s E l (p : proph_id) (pvs : list (val * val)) v1 v2 v :
  vals_compare_safe v1 v1 →
  {{{ proph p pvs ∗ ▷ l ↦ v1 }}}
    Resolve (CmpXchg #l v1 v2) #p v @ s; E
  {{{ RET (v1, #true) ; ∃ pvs', ⌜pvs = ((v1, #true)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦ v2 }}}.
Proof.
  iIntros (Hcmp Φ) "[Hp Hl] HΦ".
  iApply (wp_resolve with "Hp"); first done.
  assert (val_is_unboxed v1) as Hv1; first by destruct Hcmp.
  iApply (wp_cmpxchg_suc with "Hl"); [done..|]. iIntros "!> Hl".
  iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
Qed.

Lemma wp_resolve_cmpxchg_fail s E l (p : proph_id) (pvs : list (val * val)) q v' v1 v2 v :
  v' ≠ v1 → vals_compare_safe v' v1 →
  {{{ proph p pvs ∗ ▷ l ↦{q} v' }}}
    Resolve (CmpXchg #l v1 v2) #p v @ s; E
  {{{ RET (v', #false) ; ∃ pvs', ⌜pvs = ((v', #false)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦{q} v' }}}.
Proof.
  iIntros (NEq Hcmp Φ) "[Hp Hl] HΦ".
  iApply (wp_resolve with "Hp"); first done.
  iApply (wp_cmpxchg_fail with "Hl"); [done..|]. iIntros "!> Hl".
  iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
Qed.

End lifting.

Typeclasses Opaque array.


Set Implicit Arguments.
Require Import Lia.
Require Import Arith.
Require Export Coq.Program.Equality.
From Dblib Require Import DblibTactics DeBruijn Environments.

(* ---------------------------------------------------------------------------- *)

(* The syntax of untyped terms. *)

Inductive term :=
  | TVar: nat -> term
  | TAbs: term -> term
  | TApp: term -> term -> term.

(* ---------------------------------------------------------------------------- *)

(* The binding structure of terms. *)

Instance Var_term : Var term := {
  var := TVar (* avoid eta-expansion *)
}.

Fixpoint traverse_term (f : nat -> nat -> term) l t :=
  match t with
  | TVar x =>
      f l x
  | TAbs t =>
      TAbs (traverse_term f (1 + l) t)
  | TApp t1 t2 =>
      TApp (traverse_term f l t1) (traverse_term f l t2)
  end.

Instance Traverse_term : Traverse term term := {
  traverse := traverse_term
}.

Instance TraverseVarInjective_term : @TraverseVarInjective term _ term _.
Proof.
  constructor. prove_traverse_var_injective.
Qed.

Instance TraverseFunctorial_term : @TraverseFunctorial term _ term _.
Proof.
  constructor. prove_traverse_functorial.
Qed.

Instance TraverseRelative_term : @TraverseRelative term term _.
Proof.
  constructor. prove_traverse_relative.
Qed.

Instance TraverseIdentifiesVar_term : @TraverseIdentifiesVar term _ _.
Proof.
  constructor. prove_traverse_identifies_var.
Qed.

Instance TraverseVarIsIdentity_term : @TraverseVarIsIdentity term _ term _.
Proof.
  constructor. prove_traverse_var_is_identity.
Qed.

(* ---------------------------------------------------------------------------- *)

(* Reduction semantics. *)

Inductive red : term -> term -> Prop :=
  | RedBeta:
      forall t1 t2,
      red (TApp (TAbs t1) t2)
          (subst t2 0 t1)
  | RedContextTAbs:
      forall t1 t2,
      red t1 t2 ->
      red (TAbs t1) (TAbs t2)
  | RedContextTAppLeft:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t1 t) (TApp t2 t)
  | RedContextTAppRight:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t t1) (TApp t t2).

(* ---------------------------------------------------------------------------- *)

(* The syntax of System F types. *)

Inductive ty :=
  | TyVar: nat -> ty
  | TyArrow: ty -> ty -> ty
  | TyForall: ty -> ty.

(* ---------------------------------------------------------------------------- *)

(* The binding structure of types. *)

Instance Var_ty : Var ty := {
  var := TyVar (* avoid eta-expansion *)
}.

Fixpoint traverse_ty (f : nat -> nat -> ty) l T :=
  match T with
  | TyVar x =>
      f l x
  | TyArrow T1 T2 =>
      TyArrow (traverse_ty f l T1) (traverse_ty f l T2)
  | TyForall T =>
      TyForall (traverse_ty f (1 + l) T)
  end.

Instance Traverse_ty : Traverse ty ty := {
  traverse := traverse_ty
}.

Instance TraverseVarInjective_ty : @TraverseVarInjective ty _ ty _.
Proof.
  constructor. prove_traverse_var_injective.
Qed.

Instance TraverseFunctorial_ty : @TraverseFunctorial ty _ ty _.
Proof.
  constructor. prove_traverse_functorial.
Qed.

Instance TraverseRelative_ty : @TraverseRelative ty ty _.
Proof.
  constructor. prove_traverse_relative.
Qed.

Instance TraverseIdentifiesVar_ty : @TraverseIdentifiesVar ty _ _.
Proof.
  constructor. prove_traverse_identifies_var.
Qed.

Instance TraverseVarIsIdentity_ty : @TraverseVarIsIdentity ty _ ty _.
Proof.
  constructor. prove_traverse_var_is_identity.
Qed.

(* ---------------------------------------------------------------------------- *)

(* The tactic [introq] introduces all of the universal quantifiers that appear
   at the head of the goal. *)

Ltac introq :=
  match goal with
  | |- ?P -> ?Q =>
      idtac
  | |- forall _, _ =>
      intro; introq
  | |- _ =>
      idtac
  end.

(* ---------------------------------------------------------------------------- *)

(* The typing judgement of System F. *)

(* The judgement is indexed by the height of the type derivation. Only the
   non-syntax-directed destruction rules found at the root count towards the
   height. *)

Inductive j : nat -> env ty -> term -> ty -> Prop :=
  | JVar:
      forall n E x T,
      lookup x E = Some T ->
      j n E (TVar x) T
  | JAbs:
      forall m n E t T1 T2,
      j m (insert 0 T1 E) t T2 ->
      j n E (TAbs t) (TyArrow T1 T2)
  | JApp:
      forall n m1 m2 E t1 t2 T1 T2,
      j m1 E t1 (TyArrow T1 T2) ->
      j m2 E t2 T1 ->
      j n E (TApp t1 t2) T2
  | JTyAbs:
      forall n E t T,
      j n (map (shift 0) E) t T ->
      j n E t (TyForall T)
  | JTyApp:
      forall n m E t T U U',
      j m E t (TyForall T) ->
      m < n ->
      (* an explicit equality facilitates the use of this axiom by [eauto] *)
      subst U 0 T = U' ->
      j n E t U'.

Hint Constructors j : j.

(* ---------------------------------------------------------------------------- *)

(* Monotonicity of indices. *)

Lemma j_index_monotonic:
  forall n E t T,
  j n E t T ->
  forall m,
  m >= n ->
  j m E t T.
Proof.
  induction 1; eauto with j lia.
Qed.

(* ---------------------------------------------------------------------------- *)

(* Type preservation. *)

Lemma term_weakening:
  forall n E t T,
  j n E t T ->
  forall x U E',
  insert x U E = E' ->
  j n E' (shift x t) T.
Proof.
  induction 1; intros; subst; simpl_lift_goal; econstructor;
  eauto with lookup_insert insert_insert map_insert.
Qed.

Lemma type_weakening:
  forall n E t T,
  j n E t T ->
  forall x E' T',
  map (shift x) E = E' ->
  shift x T = T' ->
  j n E' t T'.
Proof.
  induction 1; intros; subst; simpl_lift_goal;
  econstructor;
  eauto using lookup_map_some, map_map_exchange
  with simpl_lift_goal lift_lift lift_subst map_insert.
Qed.

Lemma term_substitution:
  forall n E2 t2 T2,
  j n E2 t2 T2 ->
  forall x T1 E,
  E2 = insert x T1 E ->
  forall m t1,
  (* The derivation that is plugged in is usually canonical, i.e.,
     [m] is zero, but we do not require this. *)
  j m E t1 T1 ->
  forall k,
  (* In the worst case, the height of the new derivation is the sum
     of the heights of the original derivations, due to the way the
     derivations are plugged in at variables. *)
  k >= m + n ->
  j k E (subst t1 x t2) T2.
Proof.
  induction 1; intros; subst; simpl_subst_goal;
  try solve [
    econstructor;
    eauto using term_weakening, type_weakening with insert_insert map_insert lia
  ].
  (* JVar. *)
  unfold subst_idx. dblib_by_cases; lookup_insert_all;
  eauto using j_index_monotonic with j lia.
Qed.

Lemma type_substitution:
  forall n E t T,
  j n E t T ->
  forall U x E' T',
  map (subst U x) E = E' ->
  subst U x T = T' ->
  j n E' t T'.
Proof.
  induction 1; intros; subst; simpl_subst_goal;
  econstructor;
  eauto using lookup_map_some, map_map_exchange
  with simpl_subst_goal lift_subst subst_subst map_insert.
Qed.

Lemma inversion_JAbs:
  forall E t T1 T2,
  j 0 E (TAbs t) (TyArrow T1 T2) ->
  exists m,
  j m (insert 0 T1 E) t T2.
Proof.
  introq. intro h. dependent destruction h; try solve [ lia ].
  (* JAbs *)
  eexists. eassumption.
Qed.

Lemma inversion_JTyAbs:
  forall E t T,
  j 0 E (TAbs t) (TyForall T) ->
  (* We require a lambda-abstraction, so as to eliminate the cases where
     we have a variable or an application, which we cannot deal with. *)
  j 0 (map (shift 0) E) (TAbs t) T.
Proof.
  introq. intro h. dependent destruction h; try solve [ lia ].
  (* JTyAbs *)
  assumption.
Qed.

(* The following lemma looks like an inversion of [JTyAbs], but it
   is not truly one, because it is proved by applying weakening and
   [JTyApp], hence increasing the height of the derivation by one. *)

Goal (* phony_inversion_JTyAbs: *)
  forall n E t T,
  j n E t (TyForall T) ->
  j (S n) (map (shift 0) E) t T.
Proof.
  intros.
  generalize (pun_2 T 0). simpl. intro h. rewrite <- h. clear h.
  eapply JTyApp; [ | eauto | eauto ].
  eapply type_weakening; [ eauto | eauto | ].
  simpl_lift_goal. eauto.
Qed.

Lemma canonicalization:
  forall n E t T,
  j n E (TAbs t) T ->
  j 0 E (TAbs t) T.
Proof.
  (* Well-founded induction on [n]. *)
  intro n. pattern n. apply (well_founded_ind lt_wf). clear n. intros n ih.
  (* Analysis of the typing judgement. Inner structural induction,
     in order to go through [JTyAbs], which does not cause a decrease
     in [n]. *)
  introq. intro h. dependent induction h; eauto with j.
  (* JTyApp *)
  (* This is the reduction of a type-level beta-redex. *)
  eapply type_substitution; [ | | eauto ].
  eapply inversion_JTyAbs. eauto.
  eapply map_map_vanish. apply subst_lift.
Qed.

Lemma type_preservation:
  forall m E t1 T,
  j m E t1 T ->
  forall t2,
  red t1 t2 ->
  exists n,
  j n E t2 T.
(* A local tactic to recognize and apply the induction hypothesis. *)
Ltac tp_ih :=
  match goal with ih: forall _, red _ _ -> _, hr: red _ _ |- _ =>
    generalize (ih _ hr); intros [ ? ? ]
  end.
Proof.
  (* By induction on the type derivation. *)
  induction 1; intros ? hred.
  (* JVar *)
  dependent destruction hred.
  (* JAbs *)
  dependent destruction hred.
  tp_ih. eauto using (JAbs 0).
  (* JApp *)
  dependent destruction hred.
  (* Sub-case: beta-reduction. *)
  match goal with h: j _ _ (TAbs _) (TyArrow _ _) |- _ =>
    generalize (inversion_JAbs (canonicalization h)); intros [ ? ? ]
  end.
  solve [ eauto using term_substitution ].
  (* Sub-cases: reduction under a context. *)
  tp_ih. eauto using (JApp 0).
  tp_ih. eauto using (JApp 0).
  (* JTyAbs *)
  tp_ih. eauto with j.
  (* JTyApp *)
  tp_ih. eauto with j.
Qed.


Require Export Omega.
Require Export List.
Export ListNotations.
Require Export Setoid.
Require Export Morphisms.
Require Export Relation_Definitions.
Require Export Ring.
Require Export Basics.  (* for composition *)

Require Export SmolkaUtilities.
Require Export Utilities.
Require Export TermsUtilities.
Require Export Substitutions.

(** * Evaluating (ground) terms *)

(** When t is ground, evaluates t to T0 or to T1.
    Not complete when t is not ground *)

Fixpoint eval_ground (t: term) : term :=
  match t with
  | T0 => T0
  | T1 =>  T1
  | (V _) => t
  | A u v => match (eval_ground u) , (eval_ground  v) with
             | T0 , T0 => T0
             | T0 , T1 => T1
             | T1 , T0 => T1
             | T1 , T1 => T0
             | _ , _   => t
             end
  | M u v => match (eval_ground u) , (eval_ground v) with
             | T0 , T0 => T0
             | T0 , T1 => T0
             | T1 , T0 => T0
             | T1 , T1 => T1
             | _ , _     => t
             end
  end.

(** ** eqv is a congruence wrt eval_ground *)

Lemma eval_ground_eqv t :
  eval_ground t == t.
Proof.
  induction t as [ | | v | t1 IH1 t2 IH2| t1 IH1 t2 IH2]; simpl; auto;
    destruct (eval_ground t1); destruct (eval_ground t2);
      rewrite <- IH1;  rewrite  <- IH2; auto.
Qed.

Lemma eval_ground_compat t1 t2 :
  eqv t1 t2 -> eqv (eval_ground t1) (eval_ground t2).
Proof.
  intros H.
  assert (a1:= eval_ground_eqv t1).
  assert (a2:= eval_ground_eqv t2).
  apply eqv_trans with t1. easy.
  apply eqv_trans with t2. easy. easy.
Qed.

Add Parametric Morphism : eval_ground with
      signature eqv ==> eqv as eval_ground_mor.
  exact eval_ground_compat.
Qed.

Lemma eval_ground_complete (t: term) :
  (ground_term t = true) ->
  (eval_ground t = T0) \/ (eval_ground t = T1).
Proof.
  intros H.
  induction t as [| | v | t1 IH1 t2 IH2 |  t1 IH1 t2 IH2]; simpl; auto.
  - inversion H.
  - apply ground_term_A_elim in H; destruct H;
      assert (a:= IH1 H);
      assert (b:= IH2 H0);
      destruct a;
      destruct b;
      rewrite H1;
      rewrite H2;
      firstorder.
  - apply ground_term_M_elim in H; destruct H;
      assert (a:= IH1 H);
      assert (b:= IH2 H0);
      destruct a;
      destruct b;
      rewrite H1;
      rewrite H2;
      firstorder.
Qed.

Lemma eval_Ground_complete (t: term) :
  Ground_term t ->
  (eval_ground t = T0) \/ (eval_ground t = T1).
Proof.
  intros H.
  apply Ground_is_ground in H.
  now apply eval_ground_complete.
Qed.

Lemma Ground_T0_or_T1 (t: term) :
  Ground_term t ->
  (t == T0) \/ ( t == T1).
Proof.
  intros H.
  assert (A:= eval_Ground_complete t H).
  assert (B:=  (eval_ground_eqv t)).
  destruct A as [l | r].
  - left.
    rewrite l in B.
    now apply eqv_sym.
  - right.
    rewrite r in B.
    now apply eqv_sym.
Qed.

Lemma eval_ground_exact_T0 t :
  eval_ground t = T0 ->
  t == T0.
Proof.
  intros H0.
  rewrite <- H0.
  symmetry; apply eval_ground_eqv.
Qed.

Lemma eval_ground_exact_T1 t :
  eval_ground t = T1 ->
  t == T1.
Proof.
  intros H1.
  rewrite <- H1.
  symmetry; apply eval_ground_eqv.
Qed.

Lemma eval_ground_eqv_T0 t :
  Ground_term t ->
  t == T0 ->
  eval_ground t = T0 .
Proof.
  intros H0 H1.
  assert (H2 := Ground_is_ground t H0).
  assert (H3 := eval_ground_complete t H2).
  inversion H3.
  - easy.
  - assert (H4 := eval_ground_exact_T1 t H).
    rewrite H1 in H4.
    symmetry in H4.
    now apply T1_neqv_T0 in H4.
Qed.

Lemma eval_ground_eqv_T1 t :
  Ground_term t ->
  t == T1 ->
  eval_ground t = T1 .
Proof.
  intros H0 H1.
  assert (H2 := Ground_is_ground t H0).
  assert (H3 := eval_ground_complete t H2).
  inversion H3.
  - assert (H4 := eval_ground_exact_T0 t H).
    rewrite H1 in H4.
    symmetry in H4.
    now apply T0_neqv_T1 in H4.
  - easy.
Qed.

  Lemma ground_T0_iff t :
  Ground_term t ->
  t == T0 <-> ~ t == T1.
Proof.
  intros H1.  split.
  - intros H2 H3.
    rewrite H2 in H3. auto.
  - intros H4.
    assert (A:= eval_Ground_complete t H1).
    destruct A as [L | R].
    + now apply eval_ground_exact_T0.
    + rewrite (eval_ground_exact_T1 t R) in H4.
      assert (A:= eqv_ref T1).
      tauto.
Qed.

(** Once again: conceptually jut use ground_T0_iff for t +' 1.  But
more trouble to prove it that way than to just cut-and-paste that
proof with obvious changes *)

Lemma ground_T1_iff t :
  Ground_term t ->
  t == T1 <-> ~ t == T0.
Proof.
  intros H1.  split.
  - intros H2 H3.
    rewrite H2 in H3. auto.
  - intros H4.
    assert (A:= eval_Ground_complete t H1).
    destruct A as [L | R].
    + rewrite (eval_ground_exact_T0 t L) in H4.
      assert (A:= eqv_ref T0).
      tauto.
    + now apply eval_ground_exact_T1.
Qed.


Require Import FiatFormal.Data.List.Base.
Require Import FiatFormal.Tactics.
Require Import Coq.Program.Basics.

(********************************************************************)
(** Lemmas: map *)

Lemma map_rewind
 :  forall {A B: Type} (f: A -> B) (e: list A) x
 ,  map f e :> f x
 =  map f (e :> x).
Proof. auto. Qed.

Lemma map_snoc
 :  forall A B (f: A -> B) x xs
 ,  map f (snoc x xs) = snoc (f x) (map f xs).
Proof.
 intros.
 induction xs.
  simpl. auto.
  simpl. rewrite IHxs. auto.
Qed.
Hint Rewrite map_snoc : global.

(* Applying a function to all the elements of a list and getting
   one of the results is the same as getting the original value
   and applying the function to just that value. *)
Lemma get_map
 : forall {A B: Type} (f: A -> B) (xx: list A) x n
 ,  get n xx         = Some x
 -> get n (map f xx) = Some (f x).
Proof.
 intros. gen n.
 induction xx; intros.
  false.
  simpl. destruct n.
   simpl in H. inverts H. trivial.
   auto.
Qed.
Hint Resolve get_map.

Lemma get_map_exists
 :  forall {A B} n (f : A -> B) (xx : list A) fx
 ,  get n (map f xx) = Some fx
 -> exists x, get n xx = Some x /\ fx = f x.
Proof.
 intros. gen n.
 induction xx; intros.
 - nope.
 - destruct n.
   + simpl.
     exists a. rip.
     simpl in H. congruence.
   + simpl in H.
     simpl.
     eapply IHxx in H. auto.
Qed.
Hint Resolve get_map_exists.

Lemma map_app
 :  forall A B (f: A -> B) xx yy
 ,  map f (xx ++ yy)
 =  map f xx ++ map f yy.
Proof.
 intros.
 induction xx.
  auto.
  simpl. rewrite IHxx. auto.
Qed.
Hint Resolve map_app.
Hint Rewrite map_app : global.

(* Applying two functions to all the elements of a list one after
   the other is the same as applying their composition. *)
Lemma map_map
 :  forall {A B C: Type} (f: B -> C) (g: A -> B) xx
 ,  map f (map g xx)
 =  map (compose f g) xx.
Proof.
 induction xx.
  auto.
  simpl. rewrite IHxx. auto.
Qed.

Lemma map_impl
 :  forall {A B} (f: A -> B) {g: A -> B} xs
 ,  (forall x, f x = g x)
 -> map f xs = map g xs.
Proof.
 intros.
 induction xs.
  auto.
  repeat rewritess.
Qed.

(* Extensional equality with map.
   If two functions return equal results for all elements in a list,
   then using one or the other in a map gives the same result. *)
Lemma map_ext_in
 : forall {A B : Type}
          (f g : A -> B)
          (xs  : list A)
 , (forall x, In x xs -> f x = g x)
 -> map f xs = map g xs.
Proof.
 intros.
 induction xs.
  auto.
  simpl. rewrite IHxs. rewrite H.
   auto. simpl. auto.
   intros. apply H.
   simpl. auto.
Qed.

(* If some element is in the list resulting from a map,
   then we can find the un-transformed element in the original list. *)
Lemma map_in_exists
  :  forall (A B: Type) (f: A -> B) x ys
  ,  In x (map f ys)
  -> (exists y, f y = x /\ In y ys).
Proof.
 intros.
 induction ys.
  simpl in H. false.
  simpl in H.
   inverts H.
   simpl. exists a. eauto.
   apply IHys in H0.
   destruct H0.
   exists x0. inverts H.
   split; auto.
Qed.
Hint Resolve map_in_exists.

(* When we transform a list with a map, then we can find the element
   in the result corresponding to any element in the source. *)
Lemma map_exists_in
  :  forall (A B: Type) (f: A -> B) x ys
  ,  (exists y, f y = x /\ In y ys)
  -> In x (map f ys).
Proof.
 intros.
 induction ys.
  destruct H.
   simpl in H. inverts H. false.
   simpl in H.
   destruct H.
   inverts H.
   simpl.
   inverts H1. auto.
   right. eauto.
Qed.
Hint Resolve map_exists_in.

Lemma map_get_some_some
 :  forall {A} t1 t2 ix us (f: A -> A)
 ,  Some t1 = get ix us
 -> Some t2 = get ix (map f us)
 -> f t1 = t2.
Proof.
 intros. gen ix t1 t2.
 induction us; intros.
  false.
  destruct ix.
   simpl in H. simpl in H0.
   inverts H.  inverts H0. auto.

   simpl in H. simpl in H0; eauto.
Qed.

Lemma in_mapped
 :  forall {A B} (x : A) (xs : list A) (f : A -> B)
 ,  In x xs -> In (f x) (map f xs).
Proof.
 intros. gen x f.
 induction xs; intros.
  simpl. auto.
  simpl. simpl in H.
   inverts H.
    left.  auto.
    right. auto.
Qed.
Hint Resolve in_mapped.


Set Printing Universes.

Section Types.

  Polymorphic Definition TNat: Type := nat.

  Polymorphic Definition TMem L U: Type :=
    sigT (fun a:Type => prod (L -> a) (a -> U)).

  Polymorphic Definition TSel {L U} (t: TMem L U): Type :=
    projT1 t.

  Polymorphic Definition TTop: Type := sigT (fun a: Type => a).

  Polymorphic Definition TBot: Type := forall x: Type, x.

  Polymorphic Definition TAll (A : Type) (B: A -> Type): Type := forall x:A, (B x).

  Polymorphic Definition TAnd (A: Type) (B: Type): Type := A * B. (* TODO: not sure *)

  (* TODO: TBind, use coinduction? *)

  Check (TAll (TMem TBot TTop) (fun x => TAll (TSel x) (fun _ => (TSel x)))).

End Types.

Section Terms.

  Polymorphic Definition tzro: TNat :=
  0.

  Polymorphic Definition ttyp T: TMem T T :=
  existT (fun a => prod (T -> a) (a -> T)) T (pair (fun (a:T) => a) (fun (a:T) => a)).

  Polymorphic Definition tabs {A: Type} {B: A -> Type} (f: forall x:A, B x): TAll A B := f.

  Polymorphic Definition tapp {A: Type} {B: A -> Type} (f: TAll A B) (x: A): (B x) := f x.

  Check tabs.

  (* TODO: unpack *)

End Terms.

Section Typing.

  (* Intro & elim forms *)
  Lemma tmem_intro: forall L U (x: TMem L U) (y: L), (TSel x).
  Proof.
    intros. destruct x. destruct p. simpl. apply x0. apply y.
  Qed.

  Lemma tmem_elim: forall L U (x: TMem L U) (y: TSel x), U.
  Proof.
    intros. destruct x. destruct p. simpl. apply u. apply y.
  Qed.

End Typing.

(* Verify impredicativity via universe polymorphism *)
Definition nest T: TMem (TMem T T) (TMem T T) :=
  ttyp (TMem T T).

Check nest.

Definition unnest T: TSel (nest T) :=
ttyp T.

Check unnest.

Section Subtyping.

  (* Subtyping could be translated as coercions *)

  Polymorphic Definition sub_any {A: Type} (t: A): TTop := existT (fun a: Type => a) A t.
  Polymorphic Definition sub_bot {A: Type} (t: TBot): A := t A.

  Polymorphic Definition tmem_any {L U: Type} (t: TMem L U): TTop := sub_any t.
  Polymorphic Definition bot_tmem {L U: Type} (t: TBot): (TMem L U) := sub_bot t.

End Subtyping.

Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import languages_o2.

Section D_meta.
Import D.

Lemma ty_wf_weaken: forall Gamma T U, ty_wf Gamma T -> ctx_wf (U :: Gamma) -> ty_wf (U :: Gamma) T.
Proof.
  Admitted.

Lemma wf_lookup: forall Gamma x T, ctx_wf Gamma -> indexr x Gamma = Some T -> ty_wf Gamma T.
Proof.
  intros.
  induction H; inversion H0.
  inversion H0.
  destruct (beq_nat x (length Gamma)).
  - injection H2. intros. subst.
    apply ty_wf_weaken. assumption. constructor. assumption. assumption.
  - apply IHctx_wf in H2. apply ty_wf_weaken. assumption. constructor. assumption. assumption.
Qed.

Lemma hcwf: forall {Gamma e T}, has_type Gamma e T -> ctx_wf Gamma
    with
    tcwf: forall {Gamma T}, ty_wf Gamma T -> ctx_wf Gamma.
Proof.
  - intros. induction H; eauto.
  - intros. induction H; eauto.
Qed.

Lemma extract1: forall Gamma T1 T2, ty_wf Gamma (TMem T1 T2) -> ty_wf Gamma T2.
Proof.
  intros. inversion H. eauto.
Qed.

Lemma extract2: forall Gamma T1 T2, ty_wf Gamma (TMem T1 T2) -> ty_wf Gamma T1.
Proof.
  intros. inversion H. eauto.
Qed.

Lemma ty_wf_open: forall Gamma e T1 T2,
    ty_wf (T1 :: Gamma) (open (varF (length Gamma)) T2) ->
    has_type Gamma e T1 ->
    ty_wf Gamma (open' e T2)
  with
    has_type_open: forall Gamma e1 e2 T1 T2,
      has_type (T1 :: Gamma) e2 T2 ->
      has_type Gamma e1 T1 ->
      has_type Gamma (open_tm' e1 e2) (open' e1 T2).
Proof.
  -  (* ty_wf_open *)
    intros.  unfold open in *. unfold open' in *. unfold open_tm' in *.
    generalize dependent Gamma. generalize dependent e. generalize dependent T1.
    induction T2; intros.
    (* TTop *)
    -- simpl. constructor. eapply hcwf. eauto.
    (* TBot *)
    -- simpl. constructor. eapply hcwf. eauto.
    (* TAll *)
    -- simpl in H. inversion H. subst. simpl. constructor.
       --- eapply IHT2_1; eauto.
       --- unfold open in *.
         admit. (* TODO messy *)
    (* TSel *)
    -- inversion H0; subst; eauto.
    (* TMem *)
    -- inversion H. subst. simpl. constructor.
       eapply IHT2_1. eauto. auto.
       eapply IHT2_2. eauto. auto.
    (* TBind *)
    -- inversion H.
    (* TAnd *)
    -- inversion H.

  (* has_type_open *)
  - intros. unfold open in *. unfold open' in *. unfold open_tm' in *.
    generalize dependent Gamma. generalize dependent e1. generalize dependent e2.
    generalize dependent T1.
    induction T2; intros; eauto.
Admitted. (*TODO: most of the cases are wrong, try avoiding eauto *)

Lemma htwf: forall {Gamma e T}, has_type Gamma e T -> ty_wf Gamma T.
Proof.
  intros. induction H; auto.
  - eapply wf_lookup; eauto.
  - apply wf_sel with (T1 := T1) (T2 := TTop); auto. constructor. eapply tcwf. eauto.
  - apply (extract1 _ _ _ IHhas_type2).
  - constructor; auto.
  - inversion IHhas_type1. subst. eapply ty_wf_open; eauto.
  - constructor; auto.
Qed.

End D_meta.

Section Term_Reflect.

  (* "term T" is the type of coq terms having type T, where T ranges over the shallow embedded types above.  *)
  Polymorphic Inductive term: Type -> Type :=
  | term_tnat: TNat -> term TNat (* TODO remove later *)
  | term_ttop: TTop -> term TTop
  | term_tbot: TTop -> term TBot
  | term_tmem: forall T, TMem T T -> term (TMem T T)
  | term_tsel: forall L U (t: TMem L U), @TSel L U t -> term (@TSel L U t)
  | term_tall: forall T U, TAll T U -> term (TAll T U)
  | term_tand: forall T U, TAnd T U -> term (TAnd T U)
  .

  (* ∃T.term T*)
  Polymorphic Definition TERM: Type := sigT (fun T: Type => term T).

  (* pack a term T into TERM *)
  Polymorphic Definition TERM_of {T} (t: term T): TERM :=
    existT term T t.

End Term_Reflect.

  (* The context encoding is somewhat inspired by
       "System F in Agda for Fun and Profit",
     by Chapman, Kireev, Nester, and Wadler (MPC'19). *)

  (* Translated typing contexts *)
  Polymorphic Inductive ty_env: Type :=
  | ty_nil: ty_env
  | ty_cons: Type -> ty_env -> ty_env
  .

  (* \lang \rang *)
  Notation "⟪ x ; .. ; y ⟫" := (ty_cons x .. (ty_cons y ty_nil) ..).
  Notation "⟪⟫" := ty_nil.
  Notation "T ;;⋆ Gamma" := (ty_cons T Gamma) (at level 70, right associativity).

  Local Definition ty_env_ex1: ty_env := ty_cons Type (ty_cons Prop (ty_cons Set (ty_cons TERM ty_nil))).
  Local Definition ty_env_ex2: ty_env := ⟪ Type ; Prop ; Set; TERM; ty_env ⟫.

  (* Morally, ty_env is a list of Coq types with heterogeneous universe
   levels However, we cannot just resolve to the standard list type,
   e.g.,

     Polymorphic Definition ty_env: Type = list Type.

   which results in an odd proof obligation

     Type@{coq.1760} = list Type@{coq.1762}.

   It seems doubtful that we can proceed here. *)

  Fixpoint ty_env_length (Gamma: ty_env): nat :=
    match Gamma with
    | ⟪⟫ => 0
    | _ ;;⋆ Gamma' => 1 + (ty_env_length Gamma')
    end.

  (* Term contexts are indexed by the typing context. *)
  Polymorphic Inductive tm_env: ty_env -> Type :=
  | tm_nil:  tm_env ⟪⟫
  | tm_cons: forall T Gamma, T -> tm_env Gamma -> tm_env (T ;;⋆ Gamma)
  .

  (* \lAngle \rAngle*)
  Notation "⟨ x ; .. ; y ⟩" := (tm_cons _ _ x .. (tm_cons _ _ y tm_nil) ..).
  Notation "⟨⟩" := tm_nil.
  Notation "v ;⋆ gamma" := (tm_cons _ _ v gamma) (at level 65, right associativity).

  Local Definition tm_env_ex1 := ⟨ 1; 2; False ⟩.
  Check tm_env_ex1.

  Polymorphic Definition tm_env_destruct {T Gamma} (c: tm_env (T ;;⋆ Gamma)): (T * (tm_env Gamma)) :=
    match c with
    | x ;⋆ xs => (x,xs)
    end.

  Polymorphic Definition tm_env_hd {T Gamma} (c: tm_env (T ;;⋆ Gamma)) := fst (tm_env_destruct c).
  Polymorphic Definition tm_env_tl {T Gamma} (c: tm_env (T ;;⋆ Gamma)) := snd (tm_env_destruct c).

  Fixpoint tm_env_length {Gamma} (gamma: tm_env Gamma): nat :=
    match gamma with
    | ⟨⟩ => 0
    | _ ;⋆ vs => 1 + (tm_env_length vs)
    end.

  Lemma env_length_eq: forall Gamma (gamma: tm_env Gamma), ty_env_length Gamma = tm_env_length gamma.
  Proof.
    intros.
    induction gamma; simpl; auto.
  Qed.

(*

how should this stuff behave?

t_all translation case:
  {{ Gamma }} = list of *terms* having *translated* types as prescribed by Gamma

  ty_wf Gamma T1     ⤳ T1' : {{ Gamma }} -> Type
  ty_wf T1::Gamma T2 ⤳ T2' : {{ T1::Gamma }} -> Type
  ty_wf Gamma (D.Tall T1 T2)

  ⤳ {{ Gamma }} ->  TAll (T1' {{ Gamma }},  λx:T1' {{ Gamma }}.  T2' (x :: {{ Gamma }}))

structural properties:

  ctx_cons [[T1]] {{ Gamma }} = {{ T1 :: Gamma }}

*)

Section Interp.

  Polymorphic Variable DUMMY_TERM: { U: Type & { Gamma': ty_env & tm_env Gamma' -> term U } }.
  Polymorphic Variable DUMMY_TYPE: { Gamma': ty_env & tm_env Gamma' -> Type }.

  Polymorphic Fixpoint tctx {Gamma} (wf: D.ctx_wf Gamma): ty_env :=
    match wf with
    | D.wf_empty => ⟪⟫
    | D.wf_cons Gamma T wf_Gamma_T wf_Gamma => (ttp wf_Gamma_T) ;;⋆ (tctx wf_Gamma)
    end
  with ttp {Gamma} {T} (ty_wf: D.ty_wf Gamma T): { Gamma : ty_env & tm_env Gamma -> Type}  :=
      match ty_wf with
        | _ => DUMMY_TYPE
    (* | D.wf_top _ => *)
    (*   TTop *)
    (* | D.wf_bot _ => *)
    (*   TBot *)
    (* | D.wf_all _ _ _ ty_wf_T1 ty_wf_T2 => *)
    (*   TBot (*TODO: requires denotation as context-dependent functions *) *)
    (* | D.wf_mem _ _ _ ty_wf_T1 ty_wf_T2 => *)
    (*   TMem (ttp ty_wf_T1) (ttp ty_wf_T2) *)
    (* | D.wf_sel _ _ _ _ _ _ has_type_e => *)
    (*   match ttm has_type_e with *)
    (*   | existT _ _ (term_tmem T t) => @TSel T T t *)
    (*   | _ => False *)
    (*   end *)
    end
  (*
    Problem: we cannot mention ttp in the return type of ttm! The idea is to
    construct a TERM = term U for some U s.t. U = ttp (htwf typing).
    reify is supposed to turn this intermediate term representation into a proper
    coq term having the type U.
   *)
  with ttm {Gamma} {t} {T} (typing: D.has_type Gamma t T): { U: Type & { Gamma': ty_env & tm_env Gamma' -> term U } } :=
      match typing with
      | _ => DUMMY_TERM
    (* | D.t_var v _ _ _ _ => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    (* | D.t_typ _ _ ty_wf_T1 => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    (* | D.t_seli _ _ _ _ has_type_a_T1 has_type_e_TM_T1_Top => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    (* | D.t_sele _ _ _ _ has_type_a_TSel_e has_type_e_TM_Bot_T1 => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    (* | D.t_app _ _ _ _ _ has_type_f_TAll_T1_T2 has_type_x_T1 => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    (* | D.t_abs _ _ _ _ ty_wf_T1 has_type_y_T2 => *)
    (*   TERM_of (term_tnat 0) (* TODO *) *)
    end.

  (* Certifies that term U indeed gives a U. *)
  Polymorphic Variable reify: forall U, term U -> U. (* TODO: define *)

  (* TODO: use type classes to make more readable *)
  Polymorphic Lemma ttm_yields_ttp: forall Gamma t T (typing: D.has_type Gamma t T), (projT1 (ttm typing)) = (ttp (htwf typing)).
  Proof.
  Admitted.

  Unset Printing Universes.
  (* type preservation  *)
  Polymorphic Theorem type_preservation: forall Gamma t T (typing: D.has_type Gamma t T), (ttp (htwf typing)).
  Proof.
    intros.
    rewrite <- ttm_yields_ttp.
    destruct (ttm typing).
    simpl.
    apply reify.
    assumption.
  Qed.

(* TODO: how to relate evaluation in D and in Coq?

   - State as axiom that "Coq terms normalize" (does Coq coq correct paper help here?)
   - Seems reasonable to prove: If a well-typed source term never yields a result for any
     amount of fuel, then the coq translation does not normalize => contradiction of axiom

*)

End Interp.


(*! Tutorial: Verifying a small combinational circuit !*)
Require Import Koika.Frontend.

(*|
============================================================
 A simple combinational module and its proof of correctness
============================================================

In this file we model a simple combinational block:

  input ---(the module)--> output

Unlike in ``combinational_proof_tutorial.v``, we are not concerned here with properties related to timing, and for maximum simplicity we consider a single-cycle, non-combinational proof design.

We will start by verifying a Kôika function, and then show how to extend the proof to a single-rule design.

All that follows is parameterized on a register size ``sz``, set here to 16 bits.
|*)

Definition sz := 16.

(*|
Model
=====

We start by defining our functional model.  We have a type of "instructions", which select the mode of operation of our module:
|*)

Inductive operation :=
| quadruple (** Quadruple the input **)
| rotate_half. (** Rotate the input left by half of its width **)

(*|
Note that this model does not specify the bit pattern to encode those two instructions.
And we have a model of each of these operations:
|*)

Definition model (op: operation) (input: bits sz) : bits sz :=
  match op with
  | quadruple => Bits.slice 0 sz (Bits.mul (Bits.of_nat sz 4) input)
  | rotate_half => Bits.rotate_l (sz / 2) input
  end.

(*|
We chose a relatively low-level model: an alternative would have been to phrase the model in terms on integers, not bitvectors.  For the purposes of this demo, however, a simple bitvector-based model is enough.

We can check that this model behaves as expected:
|*)

Compute Bits.to_nat (model quadruple (Bits.of_nat sz 7)). (* .unfold *)
Compute model rotate_half Ob~1~1~1~1~0~0~0~0~1~0~1~0~1~0~1~0. (* .unfold *)

(*|
Combinational implementation
============================

We then define the Kôika implementation.
Let's consider a machine working with 8-bits instruction words. The machine should identify which
of the two instructions to perform based on a subset of the 8-bits of being high.
So we start by fixing a bit pattern to recognize for each operation :
|*)

Definition ops :=
  {| enum_name := "operations";
     enum_members :=
       vect_of_list ["quadruple"; "rotate_half"];
     enum_bitpatterns :=
       vect_of_list [Ob~0~0~0~0~0~1~1~0; Ob~0~0~0~1~0~0~0~1] |}.

(*|
… and then we implement the design itself.  While the functional model was written for legibility, the design is written for performance.
For example here we replace the multiply-by-4 operation with bitvector operations (slice and append).

Since we are writing a combinational function, the design is parametric on the set of registers `reg_t`:
|*)

  Definition design reg_t : UInternalFunction reg_t empty_ext_fn_t := {{
    fun design (op: bits_t 8) (input: bits_t sz): bits_t sz =>
      match unpack(enum_t ops, op) with
      | enum ops { quadruple } => input[|4`d0|:+14] ++ Ob~0~0
      | enum ops { rotate_half } => input[|4`d0|:+8] ++ input[|4`d8|:+8]
      return default: |16`d0|
      end
  }}.

(*|
The program above is *untyped*; we want to typecheck it; again, since we do not look at registers, we leave `reg_t` and `R` as parameters:
|*)

  Definition tc_design reg_t R :=
    tc_function R empty_Sigma (design reg_t).

(*|
.. note::

   The result of typechecking a term is a bit gnarly.  For cases like this, where we are going to verify properties of a program and hence spend a lot of time looking at its code, Kôika has an experimental *typed* language, found on the `cpitclaudel_typed_parsing`.

Correctness proof
=================

To prove the correctness of our design, we first need to phrase a correctness property; and for that, we need to relate `operations` in the sense of the model and `ops` in the sense of the design:
|*)

  Definition encode_operation op :=
    match op with
    | quadruple => vect_hd ops.(enum_bitpatterns)
    | rotate_half => vect_hd (vect_tl ops.(enum_bitpatterns))
    end.

  Compute encode_operation quadruple. (* .unfold *)
  Compute encode_operation rotate_half. (* .unfold *)

(*|
This is all that's needed to state a theorem.  We'll use Coq's “section” mechanism to parameterize the theorem about all the stateful parts of Kôika's semantics:
|*)

  Section Correctness.
    Context {reg_t: Type} {reg_t_eq_dec: EqDec reg_t}.
    Context {R: reg_t -> type} {REnv: Env reg_t} (r: REnv.(env_t) R).
    Context (L l: CompactLogs.Log R REnv).

(*|
For readability, let's define an abbreviation of the `interp_action` function.
|*)

    Definition run_design op input :=
      let design_inputs :=
          #{ ("op", bits_t 8) => op;
             ("input", bits_t 16) => input }# in
      CompactSemantics.interp_action
        r empty_sigma design_inputs L l (tc_design reg_t R).

(*|
(This is a good point to run a quick sanity check to make sure that our design passes simple smoke tests:)
|*)

    Definition design_result op input :=
      match run_design op input with
      | Some (_, r, _) => Some r
      | None => None
      end.

    Compute Bits.to_nat (must (design_result Ob~0~0~0~0~0~1~1~0 (Bits.of_nat sz 7))). (* .unfold *)
    Compute must (design_result Ob~0~0~0~1~0~0~0~1 Ob~1~1~1~1~0~0~0~0~1~0~1~0~1~0~1~0) : bits_t _. (* .unfold *)

(*|
All good.  Now for the theorem:
|*)

    Theorem design_correct:
      forall op input, exists ctx',
          run_design (encode_operation op) input =
          Some (l, model op input, ctx').
    Proof.
(*|
There are four components to this equality:

- `Some …` means that the Kôika design did not reach a conflict or a dynamic failure.
- `l` is unchanged in `Some (l, …)`: the model does not perform reads nor writes.
- The design produces the right value, as indicated by the `Some (…, model op input, …)` part of the output.
- `ctx'` records the reads and writes made to local variables; that's an implementation detail, so we don't say anything about it.

We are now ready for the proof, which is structured in two parts — one per operator.
|*)

      destruct op; cbv zeta; intros; eexists. (* .unfold *)

(*|
We can use abstract interpretation to compute the results that the design produces.  Ideally we'd prefer to run `simpl`, but `simpl` in Coq is extremely slow; so we use `cbv` instead, carefully passing it a list of things to not simplify:
|*)

      { unfold run_design; rewrite <- interp_action_cps_correct.
        cbv -[Vect.Bits.slice Bits.slice Bits.mul]. (* .unfold *)

(*|
Hence abstract interpretation shows that the design does not fail (we see `Some` on both sides).  Now we need to show that the two ways of doing this computation (the model's way and the design's way) do match up:
|*)

        repeat f_equal; clear. (* .unfold *)

(*|
This a property of multiplication: multiplying by 4 is the same as shifting left by two places, and the moduli line up properly.  We leave it to the reader — it's not entirely trivial!  THe most efficient way to proceed would probably be to use existing theorems on `N.testbit` along with `Bits.to_N`.
|*)

        admit. }

      { unfold run_design; rewrite <- interp_action_cps_correct.
        cbv -[Vect.Bits.slice Bits.slice Bits.mul vect_app Bits.rotate_l]. (* .unfold *)

        apply f_equal.

(*|
No math involved in this property: it's just a rephrasing of rotation as a slice and an append.  We could prove a general theorem for all bitwidths, but because of the way Kôika's definitions are written this property actually simplifies:
|*)

        cbv; reflexivity.
    Admitted.
  End Correctness.

(*|
Now that we have a verified function, we can incorporate it into a rule and then into a design:
|*)

Inductive reg_t := input_op | input_data | output_data.

Definition R r :=
  match r with
  | input_op    => bits_t 8
  | input_data  => bits_t sz
  | output_data => bits_t sz
  end.

Definition _runDesign : uaction _ _ :=
  {{
     let op := read0(input_op) in
     let input := read0(input_data) in
     write0(output_data, {design reg_t}(op, input))
  }}.

Inductive rule_name_t := runDesign.

Definition rules : rule_name_t -> rule R empty_Sigma :=
  tc_rules R empty_Sigma
           (fun rl => match rl with
                   | runDesign => _runDesign
                   end).

Definition system : scheduler :=
  runDesign |> done.

(*|
Extracting to Verilog and C++
=============================
|*)

Definition r : ContextEnv.(env_t) R :=
  #{ input_op => Ob~0~0~0~0~0~1~1~0;
     input_data => Bits.of_nat 16 7;
     output_data => Bits.of_nat 16 0 }#.

Definition package :=
  {| ip_koika := {| koika_reg_types := R;
                   koika_reg_init reg := r.[reg];
                   koika_ext_fn_types := empty_Sigma;
                   koika_rules := rules;
                   koika_rule_external _ := false;
                   koika_scheduler := system;
                   koika_module_name := "combinational_proof_tutorial" |};

     ip_sim := {| sp_ext_fn_specs := empty_ext_fn_props;
                 sp_prelude := None |};

     ip_verilog := {| vp_ext_fn_specs := empty_ext_fn_props |} |}.

(*|
This last bit registers our program, which allows the build system to locate it:
|*)

Definition prog := Interop.Backends.register package.
Extraction "combinational_proof_tutorial.ml" prog.