Set Implicit Arguments.

Set Printing Universes.

Set Asymmetric Patterns.

Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.

Arguments idpath {A a} , [A] a.

Arguments paths_ind [A] a P f y p.
Arguments paths_rec [A] a P f y p.
Arguments paths_rect [A] a P f y p.

Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.

Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
  match p with idpath => u end.

Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
  := match p with idpath => idpath end.
Arguments ap {A B} f {x y} p : simpl nomatch.

Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
  forall x : A, r (s x) = x.

(** A typeclass that includes the data making [f] into an adjoint equivalence. *)
Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
  equiv_inv : B -> A ;
  eisretr : Sect equiv_inv f;
  eissect : Sect f equiv_inv;
  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
}.

Arguments eisretr {A B} f {_} _.
Arguments eissect {A B} f {_} _.
Arguments eisadj {A B} f {_} _.

Inductive type_eq (A : Type) : Type -> Type :=
| type_eq_refl : type_eq A A
| type_eq_impossible : False -> forall B : Type, type_eq A B.

Definition type_eq_sym {A B} (p : type_eq A B) : type_eq B A
  := match p in (type_eq _ B) return (type_eq B A) with
       | type_eq_refl => type_eq_refl _
       | type_eq_impossible f B => type_eq_impossible _ f A
     end.

Definition type_eq_sym_type_eq_sym {A B} (p : type_eq A B) : type_eq_sym (type_eq_sym p) = p
  := match p as p return type_eq_sym (type_eq_sym p) = p with
       | type_eq_refl => idpath
       | type_eq_impossible f _ => idpath
     end.

Module Type LiftT.
  Section local.
    Let type_cast_up_type : Type.
    Proof.
      let U0 := constr:(Type) in
      let U1 := constr:(Type) in
      let unif := constr:(U0 : U1) in
      exact (forall T : U0, { T' : U1 & type_eq T' T }).
    Defined.

    Axiom type_cast_up : type_cast_up_type.
  End local.

  Definition Lift (T : Type) := projT1 (type_cast_up T).
  Definition lift {T} : T -> Lift T
    := match projT2 (type_cast_up T) in (type_eq _ T') return T' -> Lift T with
         | type_eq_refl => fun x => x
         | type_eq_impossible bad _ => match bad with end
       end.
  Section equiv.
    Definition lower' {T} : Lift T -> T
      := match projT2 (type_cast_up T) in (type_eq _ T') return Lift T -> T' with
           | type_eq_refl => fun x => x
           | type_eq_impossible bad _ => match bad with end
         end.
    Definition lift_lower {T} (x : Lift T) : lift (lower' x) = x.
    Proof.
      unfold lower', lift.
      destruct (projT2 (type_cast_up T)) as [|[]].
      reflexivity.
    Defined.
    Definition lower_lift {T} (x : T) : lower' (lift x) = x.
    Proof.
      unfold lower', lift, Lift in *.
      destruct (type_cast_up T) as [T' p]; simpl.
      let y := match goal with |- ?y => constr:(y) end in
      let P := match (eval pattern p in y) with ?f p => constr:(f) end in
      apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *.
      generalize (type_eq_sym p); intro p'; clear p.
      destruct p' as [|[]]; simpl.
      reflexivity.
    Defined.

    Global Instance isequiv_lift A : IsEquiv (@lift A).
    Proof.
      refine (@BuildIsEquiv
                _ _
                lift lower'
                lift_lower
                lower_lift
                _).
      compute.
      intro x.
      destruct (type_cast_up A) as [T' p].
      let y := match goal with |- ?y => constr:(y) end in
      let P := match (eval pattern p in y) with ?f p => constr:(f) end in
      apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *.
      generalize (type_eq_sym p); intro p'; clear p.
      destruct p' as [|[]]; simpl.
      reflexivity.
    Defined.
  End equiv.
  Definition lower {A} := (@equiv_inv _ _ (@lift A) _).
End LiftT.

Module Lift : LiftT.
  Section local.
    Let type_cast_up_type : Type.
    Proof.
      let U0 := constr:(Type) in
      let U1 := constr:(Type) in
      let unif := constr:(U0 : U1) in
      exact (forall T : U0, { T' : U1 & type_eq T' T }).
    Defined.

    Definition type_cast_up : type_cast_up_type
      := fun T => existT (fun T' => type_eq T' T) T (type_eq_refl _).
  End local.

  Definition Lift (T : Type) := projT1 (type_cast_up T).
  Definition lift {T} : T -> Lift T
    := match projT2 (type_cast_up T) in (type_eq _ T') return T' -> Lift T with
         | type_eq_refl => fun x => x
         | type_eq_impossible bad _ => match bad with end
       end.
  Section equiv.
    Definition lower' {T} : Lift T -> T
      := match projT2 (type_cast_up T) in (type_eq _ T') return Lift T -> T' with
           | type_eq_refl => fun x => x
           | type_eq_impossible bad _ => match bad with end
         end.
    Definition lift_lower {T} (x : Lift T) : lift (lower' x) = x.
    Proof.
      unfold lower', lift.
      destruct (projT2 (type_cast_up T)) as [|[]].
      reflexivity.
    Defined.
    Definition lower_lift {T} (x : T) : lower' (lift x) = x.
    Proof.
      unfold lower', lift, Lift in *.
      destruct (type_cast_up T) as [T' p]; simpl.
      let y := match goal with |- ?y => constr:(y) end in
      let P := match (eval pattern p in y) with ?f p => constr:(f) end in
      apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *.
      generalize (type_eq_sym p); intro p'; clear p.
      destruct p' as [|[]]; simpl.
      reflexivity.
    Defined.

    Global Instance isequiv_lift A : IsEquiv (@lift A).
    Proof.
      refine (@BuildIsEquiv
                _ _
                lift lower'
                lift_lower
                lower_lift
                _).
      compute.
      intro x.
      destruct (type_cast_up A) as [T' p].
      let y := match goal with |- ?y => constr:(y) end in
      let P := match (eval pattern p in y) with ?f p => constr:(f) end in
      apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *.
      generalize (type_eq_sym p); intro p'; clear p.
      destruct p' as [|[]]; simpl.
      reflexivity.
    Defined.
  End equiv.
  Definition lower {A} := (@equiv_inv _ _ (@lift A) _).
End Lift.
(* Toplevel input, characters 15-24:
Anomaly: Invalid argument: enforce_eq_instances called with instances of different lengths.
Please report. *)


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This development makes use of contexts to define the semantics of various
constructs. This file collects some general purpose definitions, theorems, and
tactics. *)
Require Export list.
Require Import tactics.

(** * Contexts with one hole *)
(** The most commonly used kind of context is the one with exactly one hole.
A context equipped with a value for its hole is known as a zipper. We define
an operational type class for substitution. The function [subst E x] is
supposed to substitute the value [x] in the hole of the context [E]. *)
Class Subst A B C := subst: A → B → C.
#[global] Instance: Params (@subst) 4 := {}.
Arguments subst {_ _ _ _} !_ _ / : simpl nomatch.

(** We generally define contexts as lists of singular contexts. For example
for binary trees [Inductive tree := leaf | branch : tree → tree → tree], we
would first define
[Inductive tree_ctx := branchL : tree → tree_ctx | branchR : tree → tree_ctx],
and then the actual context is defined as [list tree_ctx]. A pair
[tree * list tree_ctx] is a zipper, where the second projection is a tree
turned inside-out representing a path from the top. *)

(** We define subsitution for contexts as singular contexts in a generic way. *)
#[global] Instance list_subst `{Subst A B B} : Subst (list A) B B :=
  fix go (l : list A) (b : B) : B := let _ : Subst _ _ _ := @go in
  match l with [] => b | a :: l => subst l (subst a b) end.
Lemma subst_nil `{Subst A B B} b : subst [] b = b.
Proof. done. Qed.
Lemma subst_app `{Subst A B B} (l1 l2 : list A) b :
  subst (l1 ++ l2) b = subst l2 (subst l1 b).
Proof. revert b. induction l1; simpl; auto. Qed.
Lemma subst_snoc `{Subst A B B} (l1 : list A) a b :
  subst (l1 ++ [a]) b = subst a (subst l1 b).
Proof. exact (subst_app l1 [a] b). Qed.

#[global] Instance list_subst_injective `{Subst A B B} :
  (∀ a, Inj (=) (=) (subst a)) →
  ∀ l : list A, Inj (=) (=) (subst l).
Proof.
  intros ? l. red. induction l as [|x l IH]; simpl; intros; auto.
  eapply (inj (subst _)), IH; eassumption.
Qed.

(** * Contexts with multiple holes *)
(** Less commonly used kinds of contexts are those with multiple holes. These
can be represented as dependent types indexed by the number of holes. We define
a class [DepSubst] for substitution. The function [depsubst E xs] is supposed to
substitute the values of the vector [xs] in the holes of [E]. *)
Class DepSubst {I} (A : I → Type) (B : I → Type) C :=
  depsubst : ∀ {i}, A i → B i → C.
#[global] Instance: Params (@depsubst) 6 := {}.
Arguments depsubst {_ _ _ _ _ _} !_ _ / : simpl nomatch.

(** * Tactics *)
(** The tactic [simplify_subst_equality H] simplifies an assumption [H] that
is an equality involving [subst]. It repeatedly tries to use injectivity of
[subst], or to perform case analysis on the context. Such case analyses are
only performed for contexts for which an instance of [DestructSubst] is
declared. *)
Class DestructSubst `(Subst A B C) := {}.

Tactic Notation "simplify_subst_equality" hyp(H) :=
  match type of H with
  | subst ?a _ = subst ?a _ => apply (inj a) in H
  | @subst _ _ _ ?sub ?a _ = _ =>
    is_var a; let ssub := constr:(_ : DestructSubst sub) in
    destruct a; first [discriminate H | injection' H]
  | _ = @subst _ _ _ ?sub ?a _ =>
    is_var a; let ssub := constr:(_ : DestructSubst sub) in
    destruct a; first [discriminate H | injection' H]
  end;
  list_simplifier.
Tactic Notation "simplify_subst_equality" :=
  repeat_on_hyps (fun H => simplify_subst_equality H);
  list_simplifier.

(** The tactic [simplify_list_subst_equality] behaves like the previous tactic,
but then for the case of lists as contexts. *)
Tactic Notation "simplify_list_subst_equality" hyp(H) :=
  match type of H with
  | subst ?l _ = subst ?l _ => apply (list_subst_injective _ l) in H
  | @subst _ _ _ list_subst ?l _ = _ =>
     destruct l as [|?? _] using rev_ind;
       [ rewrite subst_nil in H; simplify_equality
       | rewrite subst_snoc in H; simplify_subst_equality H]
  | _ = @subst _ _ _ list_subst ?l _ =>
     destruct l as [|?? _] using rev_ind;
       [ rewrite subst_nil in H; simplify_equality
       | rewrite subst_snoc in H; simplify_subst_equality H]
  | _ => simplify_subst_equality H
  end.
Tactic Notation "simplify_list_subst_equality" :=
  repeat_on_hyps (fun H => simplify_list_subst_equality H);
  list_simplifier.


Require Import String.
Require Import Reals Coq.Lists.List Coquelicot.Series Coquelicot.Hierarchy Coquelicot.SF_seq.
Require Import pmf_monad Permutation fixed_point Finite LibUtils.
Require Import Sums Coq.Reals.ROrderedType.
Require Import micromega.Lra.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Equivalence RelationClasses EquivDec Morphisms.
Require Import Streams StreamAdd.
Require Import mdp.
Require Import Vector.
Require Import Lia.
Import ListNotations.
Set Bullet Behavior "Strict Subproofs".

Section turtle.

  Inductive turtle_color : Set :=
    turtle_green
  | turtle_white
  | turtle_star
  | turtle_red.

  Instance turtle_color_tostring : ToString turtle_color
    := {|
    toString c := match c with
                     turtle_green => "+"%string
                   | turtle_white => " "%string
                   | turtle_star => "*"%string
                   | turtle_red  => "X"%string
                   end
      |}.

  Definition newline := String (Ascii.ascii_of_N 10) EmptyString.

  Instance turtle_color_dec : EqDec turtle_color eq.
  Proof.
    change (forall (x y:turtle_color), {x = y} + {x <> y}).
    decide equality.
  Defined.

  Definition turtle_grid max_x max_y := Matrix turtle_color max_x max_y.

  Definition string_bracket (sstart send:string) (smiddle:string)
    := String.append sstart (String.append smiddle send).

  Definition vector_join {A} (delim:string) (f:A->string) {n} (v:Vector A n) : string
    := String.concat delim (List.map f (vector_to_list v)).

  Definition turtle_gridline_tostring {n} (v:Vector turtle_color n) : string
    := string_bracket "| "%string " |"%string (vector_join " | "%string toString v).

  Definition turtle_grid_vline max_x
    := string_bracket "--"%string "--"%string (String.concat "---"%string (repeat "-"%string max_x)).

  Instance turtle_grid_tostring {max_x max_y} : ToString (turtle_grid max_x max_y)
    := {|
    toString m :=
      string_bracket (String.append (turtle_grid_vline max_x) newline)
                     (String.append newline (turtle_grid_vline max_x))
                     (vector_join (string_bracket newline newline (turtle_grid_vline max_x))
                                  (fun line => turtle_gridline_tostring line)
                                  (transpose m))
      |}.

  Definition turtle_state max_x max_y :=  prod ({x:nat | x < max_x}%nat) ({y:nat | y < max_y}%nat).

  Instance turtle_state_dec max_x max_y : EqDec (turtle_state max_x max_y) eq.
  Proof.
    intros [[x1 pfx1] [y1 pfy1]] [[x2 pfx2] [y2 pfy2]].
    destruct (x1 == x2).
    - destruct (y1 == y2).
      + left.
        destruct e; destruct e0.
        erewrite (index_pf_irrel _ _ pfx1).
        erewrite (index_pf_irrel _ _ pfy1).
        reflexivity.
      + right; congruence.
    - right; congruence.
  Defined.

  Inductive turtle_action
    := Up
     | Down
     | Left
     | Right.

  Instance turtle_action_dec : EqDec turtle_action eq.
  Proof.
    change (forall (x y:turtle_action), {x = y} + {x <> y}).
    decide equality.
  Defined.

  Instance turtle_state_finite max_x max_y : Finite (turtle_state max_x max_y).
  Proof.
    apply finite_prod; apply bounded_nat_finite.
  Defined.

  Instance turtle_action_finite : Finite turtle_action.
  Proof.
    exists (Up::Down::Left::Right::nil).
    destruct x; simpl; tauto.
  Qed.

  Program Instance turtle_state_nonempty max_x max_y : NonEmpty (turtle_state (S max_x) (S max_y))
    := ((0, 0))%nat.
  Next Obligation.
    lia.
  Qed.
  Next Obligation.
    lia.
  Qed.

  Instance turtle_action_nonempty : NonEmpty turtle_action
    := Up.

  Definition color_reward (c:turtle_color) : R
    := match c with
         turtle_green => 2
       | turtle_white => 0
       | turtle_star => 1
       | turtle_red => -10
       end.

  Definition turtle_reward {max_x max_y} (grid:turtle_grid max_x max_y) (state:turtle_state max_x max_y): R
    := let '(x,y) := state in
       let color := grid x y in
       color_reward color.

  Program Definition turtle_move {max_x max_y} (s:turtle_state max_x max_y) (a:turtle_action) :
    option (turtle_state max_x max_y)
    := (let '(x,y) := s in
       match a with
       | Up => if y == 0 then None else Some (x, y-1)
       | Down => if lt_dec (y+1) max_y then Some (x, y+1) else None
       | Left => if x == 0 then None else Some (x-1, y)
       | Right => if lt_dec (x+1) max_x then Some (x+1, y) else None
       end)%nat.
  Next Obligation.
    lia.
  Qed.
  Next Obligation.
    lia.
  Qed.

  Definition turtle_action_opp (a:turtle_action) : turtle_action
    := match a with
       | Up => Down
       | Down => Up
       | Left => Right
       | Right => Left
       end.

  Program Definition turtle_confused_outcomes {max_x max_y} (correct_s oops_s:turtle_state max_x max_y) : Pmf (turtle_state max_x max_y)
    := {|
    outcomes := (mknonnegreal 0.75 _, correct_s)::(mknonnegreal 0.25 _, oops_s)::nil
      |}.
  Next Obligation.
    lra.
  Qed.
  Next Obligation.
    lra.
  Qed.
  Next Obligation.
    lra.
  Qed.

  Definition turtle_prob_t {max_x max_y} (s:turtle_state max_x max_y) (a:turtle_action) : Pmf (turtle_state max_x max_y)
    := let '(x,y) := s in
       match turtle_move s a, turtle_move s (turtle_action_opp a) with
       | Some correct_s, Some oops_s => turtle_confused_outcomes correct_s oops_s
       | Some next_s, None => Pmf_pure next_s
       | None, Some next_s => Pmf_pure next_s
       (* This grid is one or zero dimensional, so just stay still *)
       | None, None => Pmf_pure s
       end.

  Definition turtle_mdp {max_x max_y} (grid:turtle_grid (S max_x) (S max_y)) : MDP :=
    {|
    state := turtle_state (S max_x) (S max_y);
    act _ := turtle_action;
    st_eqdec := turtle_state_dec (S max_x) (S max_y);
    fs := turtle_state_finite (S max_x) (S max_y);
    fa _ := turtle_action_finite;
    ne := turtle_state_nonempty max_x max_y;
    na _ := turtle_action_nonempty ;
    t := turtle_prob_t ;
    reward _ _ s' := turtle_reward grid s'
    |}.

  Definition CeRtL_grid : turtle_grid 5%nat 5%nat
    := transpose (
           list_to_vector [
               list_to_vector [turtle_white; turtle_white; turtle_white; turtle_white; turtle_white] ;
             list_to_vector [turtle_red; turtle_red; turtle_red; turtle_star; turtle_white] ;
             list_to_vector [turtle_white; turtle_white; turtle_star; turtle_red; turtle_white] ;
             list_to_vector [turtle_green; turtle_red; turtle_white; turtle_white; turtle_white] ;
             list_to_vector [turtle_white; turtle_white; turtle_white; turtle_red; turtle_white]
             ]).

  Definition CeRtL_mdp : MDP := turtle_mdp CeRtL_grid.

  (*
  Eval vm_compute in
      String.append newline (toString CeRtL_grid).
   *)

  Lemma CeRtl_grid_correct : toString CeRtL_grid =
                             String.concat newline [
"---------------------";
"|   |   |   |   |   |";
"---------------------";
"| X | X | X | * |   |";
"---------------------";
"|   |   | * | X |   |";
"---------------------";
"| + | X |   |   |   |";
"---------------------";
"|   |   |   | X |   |";
"---------------------"]%string.
  Proof.
    reflexivity.
  Qed.

End turtle.


(* Copyright (c) 2008-2010, 2012, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import String List.

Require Import CpdtTactics DepList.

Set Implicit Arguments.
(* end hide *)

(** printing ~> $\leadsto$ *)

(** %\chapter{Generic Programming}% *)

(** %\index{generic programming}% _Generic programming_ makes it possible to write functions that operate over different types of data.  %\index{parametric polymorphism}%Parametric polymorphism in ML and Haskell is one of the simplest examples.  ML-style %\index{module systems}%module systems%~\cite{modules}% and Haskell %\index{type classes}%type classes%~\cite{typeclasses}% are more flexible cases.  These language features are often not as powerful as we would like.  For instance, while Haskell includes a type class classifying those types whose values can be pretty-printed, per-type pretty-printing is usually either implemented manually or implemented via a %\index{deriving clauses}%[deriving] clause%~\cite{deriving}%, which triggers ad-hoc code generation.  Some clever encoding tricks have been used to achieve better within Haskell and other languages, but we can do%\index{datatype-generic programming}% _datatype-generic programming_ much more cleanly with dependent types.  Thanks to the expressive power of CIC, we need no special language support.

   Generic programming can often be very useful in Coq developments, so we devote this chapter to studying it.  In a proof assistant, there is the new possibility of generic proofs about generic programs, which we also devote some space to. *)

(** * Reifying Datatype Definitions *)

(** The key to generic programming with dependent types is%\index{universe types}% _universe types_.  This concept should not be confused with the idea of _universes_ from the metatheory of CIC and related languages, which we will study in more detail in the next chapter.  Rather, the idea of universe types is to define inductive types that provide _syntactic representations_ of Coq types.  We cannot directly write CIC programs that do case analysis on types, but we _can_ case analyze on reified syntactic versions of those types.

   Thus, to begin, we must define a syntactic representation of some class of datatypes.  In this chapter, our running example will have to do with basic algebraic datatypes, of the kind found in ML and Haskell, but without additional bells and whistles like type parameters and mutually recursive definitions.

   The first step is to define a representation for constructors of our datatypes.  We use the [Record] command as a shorthand for defining an inductive type with a single constructor, plus projection functions for pulling out any of the named arguments to that constructor. *)

(* EX: Define a reified representation of simple algebraic datatypes. *)

(* begin thide *)
Record constructor : Type := Con {
  nonrecursive : Type;
  recursive : nat
}.

(** The idea is that a constructor represented as [Con T n] has [n] arguments of the type that we are defining.  Additionally, all of the other, non-recursive arguments can be encoded in the type [T].  When there are no non-recursive arguments, [T] can be [unit].  When there are two non-recursive arguments, of types [A] and [B], [T] can be [A * B].  We can generalize to any number of arguments via tupling.

   With this definition, it is easy to define a datatype representation in terms of lists of constructors.  The intended meaning is that the datatype came from an inductive definition including exactly the constructors in the list. *)

Definition datatype := list constructor.

(** Here are a few example encodings for some common types from the Coq standard library.  While our syntax type does not support type parameters directly, we can implement them at the meta level, via functions from types to [datatype]s. *)

Definition Empty_set_dt : datatype := nil.
Definition unit_dt : datatype := Con unit 0 :: nil.
Definition bool_dt : datatype := Con unit 0 :: Con unit 0 :: nil.
Definition nat_dt : datatype := Con unit 0 :: Con unit 1 :: nil.
Definition list_dt (A : Type) : datatype := Con unit 0 :: Con A 1 :: nil.

(** The type [Empty_set] has no constructors, so its representation is the empty list.  The type [unit] has one constructor with no arguments, so its one reified constructor indicates no non-recursive data and [0] recursive arguments.  The representation for [bool] just duplicates this single argumentless constructor.    We get from [bool] to [nat] by changing one of the constructors to indicate 1 recursive argument.  We get from [nat] to [list] by adding a non-recursive argument of a parameter type [A].

   As a further example, we can do the same encoding for a generic binary tree type. *)

(* end thide *)

Section tree.
  Variable A : Type.

  Inductive tree : Type :=
  | Leaf : A -> tree
  | Node : tree -> tree -> tree.
End tree.

(* begin thide *)
Definition tree_dt (A : Type) : datatype := Con A 0 :: Con unit 2 :: nil.

(** Each datatype representation stands for a family of inductive types.  For a specific real datatype and a reputed representation for it, it is useful to define a type of _evidence_ that the datatype is compatible with the encoding. *)

Section denote.
  Variable T : Type.
  (** This variable stands for the concrete datatype that we are interested in. *)

  Definition constructorDenote (c : constructor) :=
    nonrecursive c -> ilist T (recursive c) -> T.
  (** We write that a constructor is represented as a function returning a [T].  Such a function takes two arguments, which pack together the non-recursive and recursive arguments of the constructor.  We represent a tuple of all recursive arguments using the length-indexed list type %\index{Gallina terms!ilist}%[ilist] that we met in Chapter 8. *)

  Definition datatypeDenote := hlist constructorDenote.
  (** Finally, the evidence for type [T] is a %\index{Gallina terms!hlist}%heterogeneous list, including a constructor denotation for every constructor encoding in a datatype encoding.  Recall that, since we are inside a section binding [T] as a variable, [constructorDenote] is automatically parameterized by [T]. *)

End denote.
(* end thide *)

(** Some example pieces of evidence should help clarify the convention.  First, we define a helpful notation for constructor denotations.  %The ASCII \texttt{\textasciitilde{}>} from the notation will be rendered later as $\leadsto$.% *)

Notation "[ v , r ~> x ]" := ((fun v r => x) : constructorDenote _ (Con _ _)).

(* begin thide *)
Definition Empty_set_den : datatypeDenote Empty_set Empty_set_dt :=
  HNil.
Definition unit_den : datatypeDenote unit unit_dt :=
  [_, _ ~> tt] ::: HNil.
Definition bool_den : datatypeDenote bool bool_dt :=
  [_, _ ~> true] ::: [_, _ ~> false] ::: HNil.
Definition nat_den : datatypeDenote nat nat_dt :=
  [_, _ ~> O] ::: [_, r ~> S (hd r)] ::: HNil.
Definition list_den (A : Type) : datatypeDenote (list A) (list_dt A) :=
  [_, _ ~> nil] ::: [x, r ~> x :: hd r] ::: HNil.
Definition tree_den (A : Type) : datatypeDenote (tree A) (tree_dt A) :=
  [v, _ ~> Leaf v] ::: [_, r ~> Node (hd r) (hd (tl r))] ::: HNil.
(* end thide *)

(** Recall that the [hd] and [tl] calls above operate on richly typed lists, where type indices tell us the lengths of lists, guaranteeing the safety of operations like [hd].  The type annotation attached to each definition provides enough information for Coq to infer list lengths at appropriate points. *)

(** * Recursive Definitions *)

(* EX: Define a generic [size] function. *)

(** We built these encodings of datatypes to help us write datatype-generic recursive functions.  To do so, we will want a reified representation of a%\index{recursion schemes}% _recursion scheme_ for each type, similar to the [T_rect] principle generated automatically for an inductive definition of [T].  A clever reuse of [datatypeDenote] yields a short definition. *)

(* begin thide *)
Definition fixDenote (T : Type) (dt : datatype) :=
  forall (R : Type), datatypeDenote R dt -> (T -> R).

(** The idea of a recursion scheme is parameterized by a type and a reputed encoding of it.  The principle itself is polymorphic in a type [R], which is the return type of the recursive function that we mean to write.  The next argument is a heterogeneous list of one case of the recursive function definition for each datatype constructor.  The [datatypeDenote] function turns out to have just the right definition to express the type we need; a set of function cases is just like an alternate set of constructors where we replace the original type [T] with the function result type [R].  Given such a reified definition, a [fixDenote] invocation returns a function from [T] to [R], which is just what we wanted.

   We are ready to write some example functions now.  It will be useful to use one new function from the [DepList] library included in the book source. *)

Check hmake.
(** %\vspace{-.15in}% [[
  hmake
     : forall (A : Type) (B : A -> Type),
       (forall x : A, B x) -> forall ls : list A, hlist B ls
       ]]

  The function [hmake] is a kind of [map] alternative that goes from a regular [list] to an [hlist].  We can use it to define a generic size function that counts the number of constructors used to build a value in a datatype. *)

Definition size T dt (fx : fixDenote T dt) : T -> nat :=
  fx nat (hmake (B := constructorDenote nat) (fun _ _ r => foldr plus 1 r) dt).

(** Our definition is parameterized over a recursion scheme [fx].  We instantiate [fx] by passing it the function result type and a set of function cases, where we build the latter with [hmake].  The function argument to [hmake] takes three arguments: the representation of a constructor, its non-recursive arguments, and the results of recursive calls on all of its recursive arguments.  We only need the recursive call results here, so we call them [r] and bind the other two inputs with wildcards.  The actual case body is simple: we add together the recursive call results and increment the result by one (to account for the current constructor).  This [foldr] function is an [ilist]-specific version defined in the [DepList] module.

   It is instructive to build [fixDenote] values for our example types and see what specialized [size] functions result from them. *)

Definition Empty_set_fix : fixDenote Empty_set Empty_set_dt :=
  fun R _ emp => match emp with end.
Eval compute in size Empty_set_fix.
(** %\vspace{-.15in}% [[
     = fun emp : Empty_set => match emp return nat with
                              end
     : Empty_set -> nat
]]

Despite all the fanciness of the generic [size] function, CIC's standard computation rules suffice to normalize the generic function specialization to exactly what we would have written manually. *)

Definition unit_fix : fixDenote unit unit_dt :=
  fun R cases _ => (hhd cases) tt INil.
Eval compute in size unit_fix.
(** %\vspace{-.15in}% [[
     = fun _ : unit => 1
     : unit -> nat
]]

Again normalization gives us the natural function definition.  We see this pattern repeated for our other example types. *)

Definition bool_fix : fixDenote bool bool_dt :=
  fun R cases b => if b
    then (hhd cases) tt INil
    else (hhd (htl cases)) tt INil.
Eval compute in size bool_fix.
(** %\vspace{-.15in}% [[
     = fun b : bool => if b then 1 else 1
     : bool -> nat
]]
*)

Definition nat_fix : fixDenote nat nat_dt :=
  fun R cases => fix F (n : nat) : R :=
    match n with
      | O => (hhd cases) tt INil
      | S n' => (hhd (htl cases)) tt (ICons (F n') INil)
    end.

(** To peek at the [size] function for [nat], it is useful to avoid full computation, so that the recursive definition of addition is not expanded inline.  We can accomplish this with proper flags for the [cbv] reduction strategy. *)

Eval cbv beta iota delta -[plus] in size nat_fix.
(** %\vspace{-.15in}% [[
     = fix F (n : nat) : nat := match n with
                                | 0 => 1
                                | S n' => F n' + 1
                                end
     : nat -> nat
]]
*)

Definition list_fix (A : Type) : fixDenote (list A) (list_dt A) :=
  fun R cases => fix F (ls : list A) : R :=
    match ls with
      | nil => (hhd cases) tt INil
      | x :: ls' => (hhd (htl cases)) x (ICons (F ls') INil)
    end.
Eval cbv beta iota delta -[plus] in fun A => size (@list_fix A).
(** %\vspace{-.15in}% [[
     = fun A : Type =>
       fix F (ls : list A) : nat :=
         match ls with
         | nil => 1
         | _ :: ls' => F ls' + 1
         end
     : forall A : Type, list A -> nat
]]
*)

Definition tree_fix (A : Type) : fixDenote (tree A) (tree_dt A) :=
  fun R cases => fix F (t : tree A) : R :=
    match t with
      | Leaf x => (hhd cases) x INil
      | Node t1 t2 => (hhd (htl cases)) tt (ICons (F t1) (ICons (F t2) INil))
    end.
Eval cbv beta iota delta -[plus] in fun A => size (@tree_fix A).
(** %\vspace{-.15in}% [[
     = fun A : Type =>
       fix F (t : tree A) : nat :=
         match t with
         | Leaf _ => 1
         | Node t1 t2 => F t1 + (F t2 + 1)
         end
     : forall A : Type, tree A -> n
]]
*)
(* end thide *)

(** As our examples show, even recursive datatypes are mapped to normal-looking size functions. *)

(** ** Pretty-Printing *)

(** It is also useful to do generic pretty-printing of datatype values, rendering them as human-readable strings.  To do so, we will need a bit of metadata for each constructor.  Specifically, we need the name to print for the constructor and the function to use to render its non-recursive arguments.  Everything else can be done generically. *)

Record print_constructor (c : constructor) : Type := PI {
  printName : string;
  printNonrec : nonrecursive c -> string
}.

(** It is useful to define a shorthand for applying the constructor [PI].  By applying it explicitly to an unknown application of the constructor [Con], we help type inference work. *)

Notation "^" := (PI (Con _ _)).

(** As in earlier examples, we define the type of metadata for a datatype to be a heterogeneous list type collecting metadata for each constructor. *)

Definition print_datatype := hlist print_constructor.

(** We will be doing some string manipulation here, so we import the notations associated with strings. *)

Local Open Scope string_scope.

(** Now it is easy to implement our generic printer, using another function from [DepList.] *)

Check hmap.
(** %\vspace{-.15in}% [[
  hmap
     : forall (A : Type) (B1 B2 : A -> Type),
       (forall x : A, B1 x -> B2 x) ->
       forall ls : list A, hlist B1 ls -> hlist B2 ls
]]
*)

Definition print T dt (pr : print_datatype dt) (fx : fixDenote T dt) : T -> string :=
  fx string (hmap (B1 := print_constructor) (B2 := constructorDenote string)
    (fun _ pc x r => printName pc ++ "(" ++ printNonrec pc x
      ++ foldr (fun s acc => ", " ++ s ++ acc) ")" r) pr).

(** Some simple tests establish that [print] gets the job done. *)

Eval compute in print HNil Empty_set_fix.
(** %\vspace{-.15in}% [[
     = fun emp : Empty_set => match emp return string with
                              end
     : Empty_set -> string
     ]]
     *)

Eval compute in print (^ "tt" (fun _ => "") ::: HNil) unit_fix.
(** %\vspace{-.15in}% [[
     = fun _ : unit => "tt()"
     : unit -> string
   ]]
   *)

Eval compute in print (^ "true" (fun _ => "")
  ::: ^ "false" (fun _ => "")
  ::: HNil) bool_fix.
(** %\vspace{-.15in}% [[
   = fun b : bool => if b then "true()" else "false()"
   : bool -> string
   ]]
   *)

Definition print_nat := print (^ "O" (fun _ => "")
  ::: ^ "S" (fun _ => "")
  ::: HNil) nat_fix.
Eval cbv beta iota delta -[append] in print_nat.
(** %\vspace{-.15in}% [[
     = fix F (n : nat) : string :=
         match n with
         | 0%nat => "O" ++ "(" ++ "" ++ ")"
         | S n' => "S" ++ "(" ++ "" ++ ", " ++ F n' ++ ")"
         end
     : nat -> string
     ]]
     *)

Eval simpl in print_nat 0.
(** %\vspace{-.15in}% [[
     = "O()"
     : string
     ]]
     *)

Eval simpl in print_nat 1.
(** %\vspace{-.15in}% [[
     = "S(, O())"
     : string
     ]]
     *)

Eval simpl in print_nat 2.
(** %\vspace{-.15in}% [[
     = "S(, S(, O()))"
     : string
     ]]
     *)

Eval cbv beta iota delta -[append] in fun A (pr : A -> string) =>
  print (^ "nil" (fun _ => "")
  ::: ^ "cons" pr
  ::: HNil) (@list_fix A).
(** %\vspace{-.15in}% [[
     = fun (A : Type) (pr : A -> string) =>
       fix F (ls : list A) : string :=
         match ls with
         | nil => "nil" ++ "(" ++ "" ++ ")"
         | x :: ls' => "cons" ++ "(" ++ pr x ++ ", " ++ F ls' ++ ")"
         end
     : forall A : Type, (A -> string) -> list A -> string
     ]]
     *)

Eval cbv beta iota delta -[append] in fun A (pr : A -> string) =>
  print (^ "Leaf" pr
  ::: ^ "Node" (fun _ => "")
  ::: HNil) (@tree_fix A).
(** %\vspace{-.15in}% [[
     = fun (A : Type) (pr : A -> string) =>
       fix F (t : tree A) : string :=
         match t with
         | Leaf x => "Leaf" ++ "(" ++ pr x ++ ")"
         | Node t1 t2 =>
             "Node" ++ "(" ++ "" ++ ", " ++ F t1 ++ ", " ++ F t2 ++ ")"
         end
     : forall A : Type, (A -> string) -> tree A -> string
     ]]
     *)

(* begin hide *)
(* begin thide *)
Definition append' := append.
(* end thide *)
(* end hide *)

(** Some of these simplified terms seem overly complex because we have turned off simplification of calls to [append], which is what uses of the [++] operator desugar to.  Selective [++] simplification would combine adjacent string literals, yielding more or less the code we would write manually to implement this printing scheme. *)

(** ** Mapping *)

(** By this point, we have developed enough machinery that it is old hat to define a generic function similar to the list [map] function. *)

Definition map T dt (dd : datatypeDenote T dt) (fx : fixDenote T dt) (f : T -> T)
  : T -> T :=
  fx T (hmap (B1 := constructorDenote T) (B2 := constructorDenote T)
    (fun _ c x r => f (c x r)) dd).

Eval compute in map Empty_set_den Empty_set_fix.
(** %\vspace{-.15in}% [[
     = fun (_ : Empty_set -> Empty_set) (emp : Empty_set) =>
       match emp return Empty_set with
       end
     : (Empty_set -> Empty_set) -> Empty_set -> Empty_set
     ]]
     *)

Eval compute in map unit_den unit_fix.
(** %\vspace{-.15in}% [[
     = fun (f : unit -> unit) (_ : unit) => f tt
     : (unit -> unit) -> unit -> unit
     ]]
     *)

Eval compute in map bool_den bool_fix.
(** %\vspace{-.15in}% [[
     = fun (f : bool -> bool) (b : bool) => if b then f true else f false
     : (bool -> bool) -> bool -> bool
     ]]
     *)

Eval compute in map nat_den nat_fix.
(** %\vspace{-.15in}% [[
     = fun f : nat -> nat =>
       fix F (n : nat) : nat :=
         match n with
         | 0%nat => f 0%nat
         | S n' => f (S (F n'))
         end
     : (nat -> nat) -> nat -> nat
     ]]
     *)

Eval compute in fun A => map (list_den A) (@list_fix A).
(** %\vspace{-.15in}% [[
     = fun (A : Type) (f : list A -> list A) =>
       fix F (ls : list A) : list A :=
         match ls with
         | nil => f nil
         | x :: ls' => f (x :: F ls')
         end
     : forall A : Type, (list A -> list A) -> list A -> list A
     ]]
     *)

Eval compute in fun A => map (tree_den A) (@tree_fix A).
(** %\vspace{-.15in}% [[
     = fun (A : Type) (f : tree A -> tree A) =>
       fix F (t : tree A) : tree A :=
         match t with
         | Leaf x => f (Leaf x)
         | Node t1 t2 => f (Node (F t1) (F t2))
         end
     : forall A : Type, (tree A -> tree A) -> tree A -> tree A
     ]]
     *)

(** These [map] functions are just as easy to use as those we write by hand.  Can you figure out the input-output pattern that [map_nat S] displays in these examples? *)

Definition map_nat := map nat_den nat_fix.
Eval simpl in map_nat S 0.
(** %\vspace{-.15in}% [[
     = 1%nat
     : nat
     ]]
     *)

Eval simpl in map_nat S 1.
(** %\vspace{-.15in}% [[
     = 3%nat
     : nat
     ]]
     *)

Eval simpl in map_nat S 2.
(** %\vspace{-.15in}% [[
     = 5%nat
     : nat
     ]]
     *)

(** We get [map_nat S n] = [2 * n + 1], because the mapping process adds an extra [S] at every level of the inductive tree that defines a natural, including at the last level, the [O] constructor. *)

(** * Proving Theorems about Recursive Definitions *)

(** We would like to be able to prove theorems about our generic functions.  To do so, we need to establish additional well-formedness properties that must hold of pieces of evidence. *)

Section ok.
  Variable T : Type.
  Variable dt : datatype.

  Variable dd : datatypeDenote T dt.
  Variable fx : fixDenote T dt.

  (** First, we characterize when a piece of evidence about a datatype is acceptable.  The basic idea is that the type [T] should really be an inductive type with the definition given by [dd].  Semantically, inductive types are characterized by the ability to do induction on them.  Therefore, we require that the usual induction principle is true, with respect to the constructors given in the encoding [dd]. *)

  Definition datatypeDenoteOk :=
    forall P : T -> Prop,
      (forall c (m : member c dt) (x : nonrecursive c) (r : ilist T (recursive c)),
        (forall i : fin (recursive c), P (get r i))
        -> P ((hget dd m) x r))
      -> forall v, P v.

  (** This definition can take a while to digest.  The quantifier over [m : member c dt] is considering each constructor in turn; like in normal induction principles, each constructor has an associated proof case.  The expression [hget dd m] then names the constructor we have selected.  After binding [m], we quantify over all possible arguments (encoded with [x] and [r]) to the constructor that [m] selects.  Within each specific case, we quantify further over [i : fin (recursive c)] to consider all of our induction hypotheses, one for each recursive argument of the current constructor.

     We have completed half the burden of defining side conditions.  The other half comes in characterizing when a recursion scheme [fx] is valid.  The natural condition is that [fx] behaves appropriately when applied to any constructor application. *)

  Definition fixDenoteOk :=
    forall (R : Type) (cases : datatypeDenote R dt)
      c (m : member c dt)
      (x : nonrecursive c) (r : ilist T (recursive c)),
      fx cases ((hget dd m) x r)
      = (hget cases m) x (imap (fx cases) r).

  (** As for [datatypeDenoteOk], we consider all constructors and all possible arguments to them by quantifying over [m], [x], and [r].  The lefthand side of the equality that follows shows a call to the recursive function on the specific constructor application that we selected.  The righthand side shows an application of the function case associated with constructor [m], applied to the non-recursive arguments and to appropriate recursive calls on the recursive arguments. *)

End ok.

(** We are now ready to prove that the [size] function we defined earlier always returns positive results.  First, we establish a simple lemma. *)

(* begin thide *)
Lemma foldr_plus : forall n (ils : ilist nat n),
  foldr plus 1 ils > 0.
  induction ils; crush.
Qed.
(* end thide *)

Theorem size_positive : forall T dt
  (dd : datatypeDenote T dt) (fx : fixDenote T dt)
  (dok : datatypeDenoteOk dd) (fok : fixDenoteOk dd fx)
  (v : T),
  size fx v > 0.
(* begin thide *)
  unfold size; intros.
  (** [[
  ============================
   fx nat
     (hmake
        (fun (x : constructor) (_ : nonrecursive x)
           (r : ilist nat (recursive x)) => foldr plus 1%nat r) dt) v > 0
    ]]

    Our goal is an inequality over a particular call to [size], with its definition expanded.  How can we proceed here?  We cannot use [induction] directly, because there is no way for Coq to know that [T] is an inductive type.  Instead, we need to use the induction principle encoded in our hypothesis [dok] of type [datatypeDenoteOk dd].  Let us try applying it directly.
    [[
  apply dok.
    ]]
%\vspace{-.3in}%
<<
Error: Impossible to unify "datatypeDenoteOk dd" with
 "fx nat
    (hmake
       (fun (x : constructor) (_ : nonrecursive x)
          (r : ilist nat (recursive x)) => foldr plus 1%nat r) dt) v > 0".
>>

    Matching the type of [dok] with the type of our conclusion requires more than simple first-order unification, so [apply] is not up to the challenge.  We can use the %\index{tactics!pattern}%[pattern] tactic to get our goal into a form that makes it apparent exactly what the induction hypothesis is. *)

  pattern v.
  (** %\vspace{-.15in}%[[
  ============================
   (fun t : T =>
    fx nat
      (hmake
         (fun (x : constructor) (_ : nonrecursive x)
            (r : ilist nat (recursive x)) => foldr plus 1%nat r) dt) t > 0) v
      ]]
      *)

  apply dok; crush.
  (** %\vspace{-.15in}%[[
  H : forall i : fin (recursive c),
      fx nat
        (hmake
           (fun (x : constructor) (_ : nonrecursive x)
              (r : ilist nat (recursive x)) => foldr plus 1%nat r) dt)
        (get r i) > 0
  ============================
   hget
     (hmake
        (fun (x0 : constructor) (_ : nonrecursive x0)
           (r0 : ilist nat (recursive x0)) => foldr plus 1%nat r0) dt) m x
     (imap
        (fx nat
           (hmake
              (fun (x0 : constructor) (_ : nonrecursive x0)
                 (r0 : ilist nat (recursive x0)) =>
               foldr plus 1%nat r0) dt)) r) > 0
    ]]

    An induction hypothesis [H] is generated, but we turn out not to need it for this example.  We can simplify the goal using a library theorem about the composition of [hget] and [hmake]. *)

  rewrite hget_hmake.
  (** %\vspace{-.15in}%[[
  ============================
   foldr plus 1%nat
     (imap
        (fx nat
           (hmake
              (fun (x0 : constructor) (_ : nonrecursive x0)
                 (r0 : ilist nat (recursive x0)) =>
               foldr plus 1%nat r0) dt)) r) > 0
    ]]

    The lemma we proved earlier finishes the proof. *)

  apply foldr_plus.

  (** Using hints, we can redo this proof in a nice automated form. *)

  Restart.

  Hint Rewrite hget_hmake.
  Hint Resolve foldr_plus.

  unfold size; intros; pattern v; apply dok; crush.
Qed.
(* end thide *)

(** It turned out that, in this example, we only needed to use induction degenerately as case analysis.  A more involved theorem may only be proved using induction hypotheses.  We will give its proof only in unautomated form and leave effective automation as an exercise for the motivated reader.

   In particular, it ought to be the case that generic [map] applied to an identity function is itself an identity function. *)

Theorem map_id : forall T dt
  (dd : datatypeDenote T dt) (fx : fixDenote T dt)
  (dok : datatypeDenoteOk dd) (fok : fixDenoteOk dd fx)
  (v : T),
  map dd fx (fun x => x) v = v.
(* begin thide *)
  (** Let us begin as we did in the last theorem, after adding another useful library equality as a hint. *)

  Hint Rewrite hget_hmap.

  unfold map; intros; pattern v; apply dok; crush.
  (** %\vspace{-.15in}%[[
  H : forall i : fin (recursive c),
      fx T
        (hmap
           (fun (x : constructor) (c : constructorDenote T x)
              (x0 : nonrecursive x) (r : ilist T (recursive x)) =>
            c x0 r) dd) (get r i) = get r i
  ============================
   hget dd m x
     (imap
        (fx T
           (hmap
              (fun (x0 : constructor) (c0 : constructorDenote T x0)
                 (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
               c0 x1 r0) dd)) r) = hget dd m x r
    ]]

    Our goal is an equality whose two sides begin with the same function call and initial arguments.  We believe that the remaining arguments are in fact equal as well, and the [f_equal] tactic applies this reasoning step for us formally. *)

  f_equal.
  (** %\vspace{-.15in}%[[
  ============================
   imap
     (fx T
        (hmap
           (fun (x0 : constructor) (c0 : constructorDenote T x0)
              (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
            c0 x1 r0) dd)) r = r
    ]]

    At this point, it is helpful to proceed by an inner induction on the heterogeneous list [r] of recursive call results.  We could arrive at a cleaner proof by breaking this step out into an explicit lemma, but here we will do the induction inline to save space.*)

  induction r; crush.

  (* begin hide *)
  (* begin thide *)
  Definition pred' := pred.
  (* end thide *)
  (* end hide *)

  (** The base case is discharged automatically, and the inductive case looks like this, where [H] is the outer IH (for induction over [T] values) and [IHr] is the inner IH (for induction over the recursive arguments).
     [[
  H : forall i : fin (S n),
      fx T
        (hmap
           (fun (x : constructor) (c : constructorDenote T x)
              (x0 : nonrecursive x) (r : ilist T (recursive x)) =>
            c x0 r) dd)
        (match i in (fin n') return ((fin (pred n') -> T) -> T) with
         | First n => fun _ : fin n -> T => a
         | Next n idx' => fun get_ls' : fin n -> T => get_ls' idx'
         end (get r)) =
      match i in (fin n') return ((fin (pred n') -> T) -> T) with
      | First n => fun _ : fin n -> T => a
      | Next n idx' => fun get_ls' : fin n -> T => get_ls' idx'
      end (get r)
  IHr : (forall i : fin n,
         fx T
           (hmap
              (fun (x : constructor) (c : constructorDenote T x)
                 (x0 : nonrecursive x) (r : ilist T (recursive x)) =>
               c x0 r) dd) (get r i) = get r i) ->
        imap
          (fx T
             (hmap
                (fun (x : constructor) (c : constructorDenote T x)
                   (x0 : nonrecursive x) (r : ilist T (recursive x)) =>
                 c x0 r) dd)) r = r
  ============================
   ICons
     (fx T
        (hmap
           (fun (x0 : constructor) (c0 : constructorDenote T x0)
              (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
            c0 x1 r0) dd) a)
     (imap
        (fx T
           (hmap
              (fun (x0 : constructor) (c0 : constructorDenote T x0)
                 (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
               c0 x1 r0) dd)) r) = ICons a r
    ]]

    We see another opportunity to apply [f_equal], this time to split our goal into two different equalities over corresponding arguments.  After that, the form of the first goal matches our outer induction hypothesis [H], when we give type inference some help by specifying the right quantifier instantiation. *)

  f_equal.
  apply (H First).
  (** %\vspace{-.15in}%[[
  ============================
   imap
     (fx T
        (hmap
           (fun (x0 : constructor) (c0 : constructorDenote T x0)
              (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
            c0 x1 r0) dd)) r = r
    ]]

    Now the goal matches the inner IH [IHr]. *)

  apply IHr; crush.
  (** %\vspace{-.15in}%[[
  i : fin n
  ============================
   fx T
     (hmap
        (fun (x0 : constructor) (c0 : constructorDenote T x0)
           (x1 : nonrecursive x0) (r0 : ilist T (recursive x0)) =>
         c0 x1 r0) dd) (get r i) = get r i
    ]]

    We can finish the proof by applying the outer IH again, specialized to a different [fin] value. *)

  apply (H (Next i)).
Qed.
(* end thide *)

(** The proof involves complex subgoals, but, still, few steps are required, and then we may reuse our work across a variety of datatypes. *)


(***
A Complete Proof System for the Later Modality
==============================================
Author: Herman Bergwerf
DOI: 10.5281/zenodo.6340500
*)

Require Import Nat Compare_dec.
From stdpp Require Import gmap list.

Section Generic_utilities.

Fixpoint adj {X} (xs : list X) :=
  match xs with
  | [] => []
  | [_] => []
  | x :: (y :: _) as xs' => (x, y) :: adj xs'
  end.

Lemma adj_cons {X} (x0 x1 : X) xs :
  adj (x0 :: x1 :: xs) = (x0, x1) :: adj (x1 :: xs).
Proof.
done.
Qed.

Lemma adj_fmap {X Y} (f : X -> Y) xs :
  adj (f <$> xs) = (λ p, (f (fst p), f (snd p))) <$> adj xs.
Proof.
induction xs; simpl. done.
destruct xs; simpl in *. done.
rewrite IHxs; done.
Qed.

Lemma in_seq_iff start n len :
  n ∈ seq start len ↔ start ≤ n < start + len.
Proof.
rewrite elem_of_list_In; apply in_seq.
Qed.

Lemma subseteq_mbind {X Y} (f : X -> list Y) x (xs : list X) :
  x ∈ xs -> f x ⊆ xs ≫= f.
Proof.
intros H y Hy; apply elem_of_list_bind; exists x; done.
Qed.

Lemma subseteq_fmap {X Y} (f : X -> Y) (l l' : list X) :
  l ⊆ l' -> f <$> l ⊆ f <$> l'.
Proof.
intros H y Hy. apply elem_of_list_fmap in Hy as (x & -> & Hx).
apply elem_of_list_fmap; exists x; auto.
Qed.

Lemma elem_of_list_mapM {X Y} xs ys (f : X -> list Y) :
  ys ∈ mapM f xs ↔ Forall2 (λ y x, y ∈ f x) ys xs.
Proof.
revert ys; induction xs; simpl; intro ys; split; intro H.
- apply elem_of_list_ret in H as ->; apply Forall2_nil; done.
- apply Forall2_nil_inv_r in H as ->; apply elem_of_list_ret; done.
- apply elem_of_list_bind in H as (y & H1 & H2).
  apply elem_of_list_bind in H1 as (ys' & H3 & H4).
  apply elem_of_list_ret in H3 as ->.
  apply Forall2_cons; split. done.
  apply IHxs, H4.
- inversion H; subst; clear H.
  apply elem_of_list_bind; exists x; split; [|done].
  apply elem_of_list_bind; exists l; split.
  apply elem_of_list_ret; done. apply IHxs, H4.
Qed.

End Generic_utilities.

Inductive term := t_Const (b : bool) | t_Var (i : nat).
Inductive connective := Conj | Disj | Impl.
Inductive form (X : Type) :=
  | f_Term (x : X)
  | f_Later (p : form X)
  | f_Conn (c : connective) (p q : form X).

Arguments f_Term {_}.
Arguments f_Later {_}.
Arguments f_Conn {_}.

Definition f_later {X} n (f : form X) := Nat.iter n f_Later f.
Definition f_big {X} c (d : form X) fs := foldr (f_Conn c) d fs.

Fixpoint FV (f : form term) : gset nat :=
  match f with
  | f_Term (t_Var i) => {[ i ]}
  | f_Term _ => ∅
  | f_Later p => FV p
  | f_Conn _ p q => FV p ∪ FV q
  end.

Fixpoint MD (f : form term) :=
  match f with
  | f_Term _ => 0
  | f_Later p => S (MD p)
  | f_Conn _ p q => max (MD p) (MD q)
  end.

Global Instance fmap_form : FMap form :=
  λ X Y f, fix rec (r : form X) :=
    match r with
    | f_Term x => f_Term (f x)
    | f_Later p => f_Later (rec p)
    | f_Conn c p q => f_Conn c (rec p) (rec q)
    end.

Notation "⊤" := (f_Term (t_Const true)).
Notation "⊥" := (f_Term (t_Const false)).
Notation "$ x" := (f_Term x) (at level 40, format "$ x").
Notation "# i" := (f_Term (t_Var i)) (at level 40, format "# i").
Notation "▷ p" := (f_Later p) (at level 49, right associativity, format "▷ p").
Notation "n *▷ p" := (f_later n p) (at level 50, format "n *▷ p").
Notation "p `∧` q" := (f_Conn Conj p q) (at level 56, left associativity).
Notation "p `∨` q" := (f_Conn Disj p q) (at level 56, left associativity).
Notation "p ⟹ q" := (f_Conn Impl p q) (at level 54, right associativity).
Notation "p ⟺ q" := (p ⟹ q `∧` q ⟹ p) (at level 54).
Notation "⋀ fs" := (f_big Conj ⊤ fs) (at level 57).
Notation "⋁ fs" := (f_big Disj ⊥ fs) (at level 57).

(*
The sequent could be replaced with an implication, e.g. we could write something
like ⊢ p ⟹ q instead of p ⊢ q. But there are some advantages of using a sequent
relation: (1) Automation: this gives setoid rewriting and a pre-order instance.
(2) Readability: the sequent avoids parentheses in some cases, and creates a
clear separation between hypothesis and goal.

This treatment of natural deduction is not completely rigorous. We do not use
lists to store the context, but a single formula (this started as an experiment,
but at this point going back requires too much work). We do not prove a
deduction theorem, but include transitivity as an axiom.
*)

Reserved Notation "p ⊢ q" (at level 70).
Reserved Notation "⊢ q" (at level 70).

Inductive deduction : form term -> form term -> Prop :=
  | d_refl p           : p ⊢ p
  | d_trans p q r      : p ⊢ q -> q ⊢ r -> p ⊢ r
  | d_true_intro p     : p ⊢ ⊤
  | d_false_elim p     : ⊥ ⊢ p
  | d_conj_intro c p q : c ⊢ p -> c ⊢ q -> c ⊢ p `∧` q
  | d_conj_elim_l p q  : p `∧` q ⊢ p
  | d_conj_elim_r p q  : p `∧` q ⊢ q
  | d_disj_intro_l p q : p ⊢ p `∨` q
  | d_disj_intro_r p q : q ⊢ p `∨` q
  | d_disj_elim p q r  : p ⊢ r -> q ⊢ r -> p `∨` q ⊢ r
  | d_impl_intro c p q : c `∧` p ⊢ q -> c ⊢ p ⟹ q
  | d_impl_elim c p q  : c ⊢ p ⟹ q -> c ⊢ p -> c ⊢ q
  | d_later_intro p    : p ⊢ ▷p
  | d_later_elim p     : ⊢ ▷p -> ⊢ p
  | d_later_fix p      : ▷p ⊢ p -> ⊢ p
  | d_later_mono p q   : p ⊢ q -> ▷p ⊢ ▷q
  | d_later_conj p q   : ▷p `∧` ▷q ⊢ ▷(p `∧` q)
  | d_compare p q      : ⊢ p ⟹ q `∨` ▷q ⟹ p
where "p ⊢ q" := (deduction p q) and "⊢ q" := (⊤ ⊢ q).
Notation "p ⊣⊢ q" := (p ⊢ q ∧ q ⊢ p) (at level 71).

Ltac inv H := inversion H; subst; clear H.
Ltac cut x := transitivity x.
Ltac ecut := etransitivity.
Ltac refl := reflexivity.
Ltac d_split := apply d_conj_intro.
Ltac d_intro := apply d_impl_intro.
Ltac d_mp := eapply d_impl_elim.
Ltac d_apply_l H := ecut; [eapply H|].
Ltac d_apply_r H := ecut; [|eapply H].
Ltac d_left := d_apply_r d_disj_intro_l.
Ltac d_right := d_apply_r d_disj_intro_r.

Global Instance d_pre_order :
  PreOrder deduction.
Proof.
split. intros p; apply d_refl.
intros p q r; apply d_trans.
Defined.

Lemma d_clr p q : ⊢ q -> p ⊢ q.
Proof. d_apply_l d_true_intro; done. Qed.

Lemma d_clr_l c p q : c ⊢ q -> p `∧` c ⊢ q.
Proof. d_apply_l d_conj_elim_r; done. Qed.

Lemma d_clr_r c p q : c ⊢ q -> c `∧` p ⊢ q.
Proof. d_apply_l d_conj_elim_l; done. Qed.

Ltac clr := apply d_clr.
Ltac clr_l := apply d_clr_l.
Ltac clr_r := apply d_clr_r.
Ltac d_hyp := refl || (clr_l; d_hyp) || (clr_r; d_hyp).

Lemma d_conj_comm p q : p `∧` q ⊢ q `∧` p.
Proof. d_split; d_hyp. Qed.

Lemma d_conj_assoc p q r : (p `∧` q) `∧` r ⊣⊢ p `∧` (q `∧` r).
Proof. split; repeat d_split; d_hyp. Qed.

Lemma d_impl_revert c p q : c ⊢ p ⟹ q -> c `∧` p ⊢ q.
Proof. intros; d_mp; [clr_r; done|clr_l; done]. Qed.

Lemma d_impl_revert_top p q : ⊢ p ⟹ q -> p ⊢ q.
Proof. intros; d_mp; [clr; done|refl]. Qed.

Ltac d_comm := d_apply_l d_conj_comm.
Ltac d_assoc := d_apply_l d_conj_assoc.
Ltac d_revert := apply d_impl_revert || apply d_impl_revert_top.

Section Deductions.

Implicit Types p q : form term.

Lemma d_strong_fix p :
  ▷p ⟹ p ⊢ p.
Proof.
d_mp; [clr|refl].
eapply d_later_fix.
d_intro; d_mp; [d_hyp|].
d_comm; d_revert.
d_apply_l d_later_intro.
d_intro; d_apply_l d_later_conj.
apply d_later_mono; d_mp; d_hyp.
Qed.

Lemma d_later_impl p q :
  ▷p ⟹ ▷q ⊢ ▷(p ⟹ q).
Proof.
d_revert; d_apply_r d_disj_elim.
apply d_compare with (p:=p)(q:=q).
d_intro; d_apply_r d_later_intro; d_hyp.
d_intro; cut (▷q). d_mp. d_hyp.
d_apply_r d_later_intro; d_apply_r d_strong_fix.
d_intro. d_mp. d_hyp. d_mp; d_hyp.
apply d_later_mono; d_intro; d_hyp.
Qed.

Lemma d_later_inj p q :
  ▷p ⊢ ▷q -> p ⊢ q.
Proof.
intros; d_mp; [clr|refl]. apply d_later_elim.
d_apply_r d_later_impl. d_intro; clr_l; done.
Qed.

Lemma d_compare_weak p q :
  ⊢ p ⟹ q `∨` q ⟹ p.
Proof.
d_apply_r d_disj_elim.
apply d_compare with (p:=p)(q:=q).
d_left; d_hyp. d_right; d_intro; d_mp.
d_hyp. d_apply_r d_later_intro; d_hyp.
Qed.

Lemma d_big_conj_intro c ps :
  (∀ p, p ∈ ps -> c ⊢ p) -> c ⊢ ⋀ ps.
Proof.
induction ps; simpl; intros. clr; done.
apply d_conj_intro. apply H, elem_of_list_here.
apply IHps; intros; apply H, elem_of_list_further, H0.
Qed.

Lemma d_big_conj_elim p ps :
  p ∈ ps -> ⋀ ps ⊢ p.
Proof.
induction ps; simpl; intros.
apply elem_of_nil in H; done.
inv H. d_hyp. clr_l; apply IHps, H2.
Qed.

Lemma d_big_disj_intro p ps :
  p ∈ ps -> p ⊢ ⋁ ps.
Proof.
induction ps; simpl; intros.
apply not_elem_of_nil in H; done.
inv H; [d_left|d_right]. done. auto.
Qed.

Lemma d_big_disj_elim ps q :
  (∀ p, p ∈ ps -> p ⊢ q) -> ⋁ ps ⊢ q.
Proof.
induction ps; simpl; intros. constructor.
apply d_disj_elim.
apply H; left; done.
apply IHps; intros.
apply H; right; done.
Qed.

Lemma d_big_disj_subseteq ps qs :
  ps ⊆ qs -> ⋁ ps ⊢ ⋁ qs.
Proof.
intros; apply d_big_disj_elim; intros.
d_apply_r d_big_disj_intro. done. auto.
Qed.

Lemma d_big_disj_conj_swap {X} (f : X -> list (form term)) (xs : list X) :
  ⋀ ((λ x, ⋁ f x) <$> xs) ⊢ ⋁ ((λ c, ⋀ c) <$> mapM f xs).
Proof.
induction xs. simpl; d_left; done.
ecut. apply d_conj_intro.
clr_r; done. clr_l; apply IHxs.
d_revert; apply d_big_disj_elim; intros p Hp; d_intro.
d_comm; d_revert; apply d_big_disj_elim; intros q Hq; d_intro.
apply elem_of_list_fmap in Hq as (qs & -> & Hqs).
d_apply_r d_big_disj_intro. d_comm; done.
apply elem_of_list_fmap; exists (p :: qs); simpl; split. done.
apply elem_of_list_bind; exists p; split; [|done].
apply elem_of_list_bind; exists qs; split; [|done].
apply elem_of_list_ret; done.
Qed.

Lemma d_iff_refl p :
  ⊢ p ⟺ p.
Proof.
d_split; d_intro; d_hyp.
Qed.

Lemma d_iff_symm p q :
  p ⟺ q ⊢ q ⟺ p.
Proof.
d_split; d_hyp.
Qed.

Lemma d_iff_trans p q r :
  p ⟺ q `∧` q ⟺ r ⊢ p ⟺ r.
Proof.
d_split; d_intro; d_mp; try d_hyp; d_mp.
clr_r; clr_r; d_hyp. d_hyp.
clr_r; clr_l; d_hyp. d_hyp.
Qed.

Lemma d_impl_later p q :
  p ⟹ q ⊢ ▷p ⟹ ▷q.
Proof.
d_apply_l d_later_intro; d_intro.
d_apply_l d_later_conj; apply d_later_mono.
d_revert; done.
Qed.

Lemma d_impl_laters m n p q :
  m ≤ n -> p ⟹ q ⊢ m*▷p ⟹ n*▷q.
Proof.
intro H; induction H.
induction m; simpl; intros. done. d_apply_r d_impl_later; done.
d_intro; simpl; d_apply_r d_later_intro; d_revert; done.
Qed.

Lemma d_iff_laters n p q :
  p ⟺ q ⊢ n*▷p ⟺ n*▷q.
Proof.
d_split; d_apply_r d_impl_laters; d_hyp.
Qed.

Lemma d_laters_le m n p :
  m ≤ n -> m*▷p ⊢ n*▷p.
Proof.
intro H; induction H; simpl. done.
d_apply_r d_later_intro; apply IHle.
Qed.

Lemma d_laters_intro n p :
  p ⊢ n*▷p.
Proof.
induction n; simpl. done.
d_apply_r d_later_intro; done.
Qed.

Lemma laters_S n p :
  ▷(n*▷p) = S n*▷p.
Proof.
done.
Qed.

Lemma laters_add m n p :
  (m + n)*▷p = m*▷(n*▷p).
Proof.
induction m; simpl; congruence.
Qed.

End Deductions.

Section Reference_model.

Inductive Sω :=
  | Finite (n : nat)
  | Infinite.

Definition Sω_succ (p : Sω) :=
  match p with
  | Finite n => Finite (S n)
  | Infinite => Infinite
  end.

Definition Sω_min (p0 p1 : Sω) :=
  match p0, p1 with
  | Finite n0, Finite n1 => Finite (min n0 n1)
  | _, Infinite => p0
  | Infinite, _ => p1
  end.

Definition Sω_max (p0 p1 : Sω) :=
  match p0, p1 with
  | Finite n0, Finite n1 => Finite (max n0 n1)
  | _, Infinite => Infinite
  | Infinite, _ => Infinite
  end.

Definition Sω_leb (p0 p1 : Sω) :=
  match p0, p1 with
  | Finite n0, Finite n1 => n0 <=? n1
  | _, Infinite => true
  | _, _ => false
  end.

Definition Sω_le (p0 p1 : Sω) :=
  match p0, p1 with
  | Finite n0, Finite n1 => n0 ≤ n1
  | _, Infinite => True
  | _, _ => False
  end.

Definition interp (Γ : nat -> Sω) (x : term) :=
  match x with
  | t_Const false => Finite 0
  | t_Const true => Infinite
  | t_Var i => Γ i
  end.

Fixpoint eval (f : form Sω) : Sω :=
  match f with
  | ($x) => x
  | (▷p) => Sω_succ (eval p)
  | (p `∧` q) => Sω_min (eval p) (eval q)
  | (p `∨` q) => Sω_max (eval p) (eval q)
  | (p ⟹ q) => if Sω_leb (eval p) (eval q) then Infinite else eval q
  end.

Definition realizes (Γ : nat -> Sω) (p q : form term) : Prop :=
  Sω_le (eval (interp Γ <$> p)) (eval (interp Γ <$> q)).

Global Instance Sω_le_pre_order :
  PreOrder Sω_le.
Proof.
split. intros []; simpl; done.
intros [] [] []; simpl; try done; lia.
Qed.

Global Instance realizes_pre_order Γ :
  PreOrder (realizes Γ).
Proof.
split; unfold realizes. intros p; done.
intros p q r; intros; etrans; done.
Qed.

Lemma Sω_le_leb p q :
  Sω_le p q ↔ Sω_leb p q = true.
Proof.
destruct p, q; simpl; try done.
split; apply Nat.leb_le.
Qed.

Lemma Sω_le_cases p q :
  Sω_le p q ∨ Sω_le (Sω_succ q) p.
Proof.
destruct p, q; simpl; auto; lia.
Qed.

Lemma Sω_compare p q :
  Sω_le Infinite (eval (p ⟹ q `∨` ▷q ⟹ p)).
Proof.
simpl; edestruct Sω_le_cases; apply Sω_le_leb in H; rewrite H; simpl.
all: destruct (if Sω_leb _ _ then _ else _); done.
Qed.

Lemma realizes_conj_intro Γ c p q :
  realizes Γ c p -> realizes Γ c q -> realizes Γ c (p `∧` q).
Proof.
unfold realizes; simpl; repeat destruct (eval _); simpl; try done; lia.
Qed.

Lemma realizes_impl_intro_top p q Γ :
  realizes Γ p q -> realizes Γ ⊤ (p ⟹ q).
Proof.
unfold realizes; simpl; repeat destruct (eval _); simpl; try done.
intros; apply Nat.leb_le in H; rewrite H; done.
Qed.

Theorem deduction_sound Γ p q :
  p ⊢ q -> realizes Γ p q.
Proof.
unfold realizes; intros H; induction H.
18: apply Sω_compare.
all: simpl in *; repeat destruct (eval _); simpl in *; try done; try lia.
all: destruct (_ <=? _) eqn:E; try done.
all: try apply Nat.leb_le in E; try apply Nat.leb_gt in E; lia.
Qed.

End Reference_model.

(*
We replace formulas with a term of the form `n*▷$x`.
*)
Section Symbolic_evaluation.

Definition bounded_term `{ElemOf nat X} (range : X) x :=
  match x with
  | t_Const _ => True
  | t_Var i => i ∈ range
  end.

Implicit Types fv : gset nat.

Definition atom fv md a := ∃ x n,
  bounded_term fv x ∧ n ≤ md ∧ a = n*▷$x.

Lemma atom_const fv md b :
  atom fv md ($t_Const b).
Proof.
exists (t_Const b), 0; repeat split; lia.
Qed.

Lemma atom_later fv md a :
  atom fv md a -> atom fv (S md) (▷a).
Proof.
intros (x & d & H1 & H2 & ->); exists x, (S d);
simpl; repeat split. done. lia.
Qed.

Lemma atom_weaken fv fv' md md' a :
  atom fv md a -> fv ⊆ fv' -> md ≤ md' -> atom fv' md' a.
Proof.
intros (x & d & H1 & H2 & ->); exists x, d; repeat split.
destruct x; simpl in *. done. apply H, H1. lia.
Qed.

Variable ctx : form term.
Variable fv : gset nat.
Variable md : nat.

Hypothesis exhaustive : ∀ a b,
  atom fv md a -> atom fv md b ->
  ctx ⊢ a ⟹ b ∨ ctx ⊢ ▷b ⟹ a.

Ltac d_apply_r_lift_iff H :=
  (d_apply_r d_conj_elim_l; d_apply_r H) ||
  (d_apply_r d_conj_elim_r; d_apply_r H).

Ltac d_subst_r H := d_mp; [(d_apply_r H || d_apply_r_lift_iff H); d_hyp|].

Local Lemma exhaustive_weak a b :
  atom fv md a -> atom fv md b ->
  ctx ⊢ a ⟹ b ∨ ctx ⊢ b ⟹ a.
Proof.
intros; destruct (exhaustive a b); try done. left; done.
right; d_intro; d_subst_r H1; d_apply_r d_later_intro; d_hyp.
Qed.

Theorem d_reduce_to_atom f :
  FV f ⊆ fv -> MD f ≤ md ->
  ∃ a, atom (FV f) (MD f) a ∧ ctx ⊢ f ⟺ a.
Proof.
induction f as [[]|p|[] p IHp q IHq]; simpl; intros Hfv Hmd.
3-6: destruct IHp as (a & Aa & Ha); try lia. 3,5,7,9: set_solver.
4-6: destruct IHq as (b & Ab & Hb); try lia. 4,6,8: set_solver.
4-5: destruct (exhaustive_weak a b).
12: destruct (exhaustive a b).
4,5,8,9,12,13: eapply atom_weaken; [eassumption|set_solver|lia].
1: exists ($t_Const b).
2: exists (#i). 3: exists (▷a).
4: exists a. 5: exists b.
6: exists b. 7: exists a.
8: exists ⊤. 9: exists b.
1,2: split; [|clr; apply d_iff_refl].
apply atom_const. exists (t_Var i), 0; simpl; split; [set_solver|done]. split.
apply atom_later, Aa. d_apply_l Ha; d_split; d_apply_r d_impl_later; d_hyp.
all: split. 1,3,5,7,11: eapply atom_weaken; [eassumption|set_solver|lia].
5: apply atom_const. all: d_split; d_intro.
2,4: d_split; [d_subst_r Ha|d_subst_r Hb]; try d_hyp; d_subst_r H; d_hyp.
d_subst_r Ha; d_hyp. d_subst_r Hb; d_hyp.
1,3: d_comm; d_revert; apply d_disj_elim; d_intro.
d_subst_r H; d_subst_r Ha; d_hyp. d_subst_r Hb; d_hyp.
d_subst_r Ha; d_hyp. d_subst_r H; d_subst_r Hb; d_hyp.
d_right; d_subst_r Hb; d_hyp. d_left; d_subst_r Ha; d_hyp.
constructor. d_intro; d_subst_r Hb; d_subst_r H; d_subst_r Ha; d_hyp.
d_apply_r d_strong_fix; d_intro; d_subst_r Hb; d_mp; [d_hyp|].
d_subst_r Ha; d_subst_r H; d_hyp. d_intro; d_subst_r Hb; d_hyp.
Qed.

End Symbolic_evaluation.

(*
We obtain a disjunction of all possible implication orderings.
*)
Section Permutation_deduction.

Implicit Types xs : list nat.

Definition perm_form xs :=
  ⋀ ((λ p, #p.1 ⟹ #p.2) <$> adj xs).

Lemma perm_form_unfold x y zs :
  perm_form (x :: y :: zs) = #x ⟹ #y `∧` perm_form (y :: zs).
Proof.
done.
Qed.

Lemma d_perm_form_tl x ys :
  perm_form (x :: ys) ⊢ perm_form ys.
Proof.
destruct ys. unfold perm_form; simpl; done.
rewrite perm_form_unfold; clr_l; done.
Qed.

Lemma d_interleave x xs :
  perm_form xs ⊢ ⋁ (perm_form <$> interleave x xs).
Proof.
induction xs as [|y zs].
unfold perm_form; simpl. d_left; constructor.
simpl interleave; rewrite fmap_cons; simpl.
d_revert; d_apply_r d_disj_elim.
apply d_compare_weak with (p:=#x)(q:=#y).
d_intro; d_left.
rewrite perm_form_unfold; done.
(* interleave x into the tail. *)
d_intro; d_right.
d_comm; d_revert; d_apply_l d_conj_intro.
apply d_perm_form_tl. done. d_revert.
d_apply_l IHzs. apply d_big_disj_elim; intros; d_intro; d_intro.
apply elem_of_list_fmap in H as (zs' & -> & H).
d_apply_r d_big_disj_intro.
2: { apply elem_of_list_fmap; eexists; split; [done|].
apply elem_of_list_fmap; exists zs'; done. }
(* y comes before zs' ∈ interleave x zs. *)
destruct zs as [|z zs]; simpl in *.
- apply elem_of_list_singleton in H; subst.
  unfold perm_form; simpl. d_split; d_hyp.
- inv H; rewrite ?perm_form_unfold.
  repeat d_split; d_hyp.
  apply elem_of_list_fmap in H2 as (zs'' & -> & H).
  rewrite perm_form_unfold; d_split; d_hyp.
Qed.

Lemma d_bind_interleave x xss :
  ⋁ (perm_form <$> xss) ⊢ ⋁ (perm_form <$> xss ≫= interleave x).
Proof.
apply d_big_disj_elim; intros.
apply elem_of_list_fmap in H as (xs & -> & H).
d_apply_r d_big_disj_subseteq. apply d_interleave with (x:=x).
apply subseteq_fmap, subseteq_mbind, H.
Qed.

Theorem d_permutations (xs : list nat) :
  ⊢ ⋁ (perm_form <$> permutations xs).
Proof.
induction xs as [|x xs]; simpl. d_left; constructor.
d_apply_l IHxs; apply d_bind_interleave.
Qed.

End Permutation_deduction.

(*
We obtain a disjunction with some different offsets between propositions.
*)
Section Offset_deduction.

Definition offset_clause md (p q : form term) n :=
  if n <=? md then n*▷p ⟺ q else n*▷p ⟹ q.

Definition offset_clauses p q md :=
  offset_clause md p q <$> seq 0 (2 + md).

Definition clause_terms xs :=
  t_Const false :: (t_Var <$> xs).

Lemma in_fmap_seq {X} (f : nat -> X) m n :
  m ≤ n -> f m ∈ f <$> seq 0 (S n).
Proof.
intros; apply elem_of_list_fmap; exists m; split.
done. apply in_seq_iff; lia.
Qed.

Lemma d_offsets ctx p q n :
  ctx ⊢ p ⟹ q ->
  ctx ⊢ n*▷p ⟹ q `∨` ⋁ ((λ i, i*▷p ⟺ q) <$> seq 0 n).
Proof.
intros; induction n. d_left; done.
d_apply_l IHn; apply d_disj_elim.
d_revert; d_apply_r d_disj_elim.
apply (d_compare q (n*▷p)).
- d_intro; d_right; d_apply_r d_big_disj_intro.
  2: apply in_fmap_seq; done. d_split; d_hyp.
- d_intro; d_left; d_hyp.
- d_right; apply d_big_disj_subseteq.
  apply subseteq_fmap; intros i.
  rewrite ?in_seq_iff; lia.
Qed.

Lemma d_offset_clauses ctx p q md :
  ctx ⊢ p ⟹ q -> ctx ⊢ ⋁ offset_clauses p q md.
Proof.
unfold offset_clauses; intros.
ecut. apply d_offsets with (n:=S md), H.
apply d_disj_elim.
- d_apply_r d_big_disj_intro.
  2: apply in_fmap_seq; done. unfold offset_clause.
  replace (S md <=? md) with false. done.
  symmetry; apply Nat.leb_gt; lia.
- eapply d_big_disj_elim; intros r Hr.
  apply elem_of_list_fmap in Hr as (d & -> & Hd).
  apply in_seq_iff in Hd. d_apply_r d_big_disj_intro.
  2: apply in_fmap_seq with (m:=d); lia. unfold offset_clause.
  replace (d <=? md) with true. done.
  symmetry; apply Nat.leb_le; lia.
Qed.

Lemma d_offset_clauses_perm md (xs : list nat) :
  perm_form xs ⊢ ⋀ ((λ p, ⋁ (offset_clauses ($p.1) ($p.2) md))
    <$> adj (clause_terms xs)).
Proof.
unfold perm_form; apply d_big_conj_intro; intros.
apply elem_of_list_fmap in H as (p' & -> & H).
unfold clause_terms in H; destruct xs. apply elem_of_nil in H; done.
rewrite fmap_cons, adj_cons, <-fmap_cons in H.
apply elem_of_cons in H as [->|].
- clr; apply d_offset_clauses; simpl.
  d_intro; d_apply_r d_false_elim; d_hyp.
- rewrite adj_fmap in H; apply elem_of_list_fmap in H as (ij & -> & H).
  apply d_offset_clauses, d_big_conj_elim, elem_of_list_fmap; exists ij; done.
Qed.

End Offset_deduction.

(*
We implement a decision procedure that looks for counterexamples.
*)
Section Counterexample_search.

Implicit Types fv : gset nat.

Fixpoint case_clauses (case : list (nat * nat)) (md : nat) (bot : form term) :=
  match case with
  | [] => []
  | (i, n) :: case' =>
    offset_clause md bot (#i) n ::
    case_clauses case' md (#i)
  end.

Fixpoint case_val (case : list (nat * nat)) (i : nat) : nat :=
  match case with
  | [] => 0
  | (j, n) :: case' => n + if i =? j then 0 else case_val case' i
  end.

Definition case_form md bot case :=
  ⋀ case_clauses case md bot.

Definition list_cases (fv : gset nat) (md : nat) : list (list (nat * nat)) :=
  let skips := seq 0 (2 + md) in
  let perms := permutations (elements fv) in
  xs ← perms; mapM (λ i, pair i <$> skips) xs.

Definition eval_case (f : form term) (case : list (nat * nat)) : bool :=
  Sω_leb Infinite (eval (interp (Finite ∘ case_val case) <$> f)).

Definition counterexample (f : form term) : option (list (nat * nat)) :=
  find (negb ∘ eval_case f) (list_cases (FV f) (MD f)).

Example not_strong_later_inj :
  counterexample ((▷#0 ⟹ ▷#1) ⟹ #0 ⟹ #1) = Some [(1, 0); (0, 1)].
Proof. done. Qed.

Example not_excluded_middle :
  counterexample (#0 `∨` (#0 ⟹ ⊥)) = Some [(0, 1)].
Proof. done. Qed.

Section Case_form_exhaustive.

Lemma offset_clause_weaken md p q n :
  offset_clause md p q n ⊢ n*▷p ⟹ q.
Proof.
unfold offset_clause; destruct (_ <=? _); d_hyp.
Qed.

Lemma case_form_exhaustive_bot_var case md bot p :
  p ∈ case.*1 ->
  case_form md bot case ⊢ S md*▷bot ⟹ #p ∨ ∃ n,
  case_form md bot case ⊢ n*▷bot ⟺ #p.
Proof.
unfold case_form; intros Hp; revert bot.
induction case as [|[r k] case]; simpl; intros.
apply elem_of_nil in Hp; done.
rewrite fmap_cons in Hp; inv Hp.
- (* p = r *)
  unfold offset_clause; destruct (k <=? md) eqn:E.
  + right; exists k; d_hyp.
  + left; clr_r; d_intro; d_mp. d_hyp. clr_l.
    rewrite laters_S; apply d_laters_le.
    apply Nat.leb_gt in E; lia.
- (* p ∈ case.*1 *)
  destruct IHcase with (bot:=#r) as [IH|(n & IH)]. done.
  + left; d_intro; d_mp. d_apply_r IH; d_hyp.
    d_comm; d_assoc; clr_r. rewrite laters_S.
    d_comm; d_revert; d_apply_l offset_clause_weaken.
    d_apply_r d_impl_laters; [|done]. d_intro; d_mp.
    d_hyp. clr_l; apply d_laters_intro.
  + unfold offset_clause; destruct (k <=? md) eqn:E.
    * right; exists (n + k). d_comm; d_revert; d_apply_l IH; d_intro.
      d_apply_r d_iff_trans; d_split; [|d_hyp].
      rewrite laters_add; d_apply_r d_iff_laters. d_hyp.
    * left. d_comm; d_revert; d_apply_l IH; d_intro; d_intro.
      d_mp. d_hyp. d_assoc; clr_l. d_mp.
      d_apply_r d_impl_laters. d_hyp. done.
      clr_l; rewrite laters_S, <-laters_add.
      apply d_laters_le; apply Nat.leb_gt in E; lia.
Qed.

Lemma case_form_exhaustive_var_var case md bot p q :
  p ∈ case.*1 -> q ∈ case.*1 ->
  case_form md bot case ⊢ S md*▷#p ⟹ #q ∨
  case_form md bot case ⊢ S md*▷#q ⟹ #p ∨
  (∃ n, case_form md bot case ⊢ n*▷#p ⟺ #q) ∨
  (∃ n, case_form md bot case ⊢ n*▷#q ⟺ #p).
Proof.
unfold case_form; intros Hp Hq; revert bot.
induction case as [|[r k] case]; simpl; intros. apply elem_of_nil in Hp; done.
replace (_ :: _).*1 with (r :: case.*1) in Hp, Hq by done; inv Hp; inv Hq.
- (* p = q = r *)
  right; right; right; exists 0; clr; apply d_iff_refl.
- (* p = r, q ∈ case.*1 *)
  eapply case_form_exhaustive_bot_var in H1 as [].
  left. clr_l; apply H. destruct H as (n & H).
  right; right; left; exists n; clr_l; apply H.
- (* p ∈ case.*1, q = r *)
  eapply case_form_exhaustive_bot_var in H1 as [].
  right; left. clr_l; apply H. destruct H as (n & H).
  right; right; right; exists n; clr_l; apply H.
- (* p, q ∈ case.*1 *)
  destruct IHcase with (bot:=#r) as [IH|[IH|[(n & IH)|(n & IH)]]]; try done.
  left; clr_l; done. right; left; clr_l; done.
  right; right; left; exists n; clr_l; done.
  right; right; right; exists n; clr_l; done.
Qed.

Lemma case_form_exhaustive_const_term case md b x :
  bounded_term case.*1 x ->
  case_form md ⊥ case ⊢ S md*▷$x ⟹ $t_Const b ∨
  case_form md ⊥ case ⊢ S md*▷$t_Const b ⟹ $x ∨
  (∃ n, case_form md ⊥ case ⊢ n*▷$t_Const b ⟺ $x).
Proof.
intros; destruct b. left; d_intro; clr; done.
destruct x. destruct b. right; left; d_intro; clr; done.
right; right; exists 0; clr; apply d_iff_refl.
edestruct case_form_exhaustive_bot_var. apply H.
right; left; apply H0. right; right; apply H0.
Qed.

Lemma case_form_exhaustive_term_term case md x y :
  bounded_term case.*1 x ->
  bounded_term case.*1 y ->
  case_form md ⊥ case ⊢ S md*▷$x ⟹ $y ∨
  case_form md ⊥ case ⊢ S md*▷$y ⟹ $x ∨
  (∃ n, case_form md ⊥ case ⊢ n*▷$x ⟺ $y) ∨
  (∃ n, case_form md ⊥ case ⊢ n*▷$y ⟺ $x).
Proof.
intros; destruct x.
edestruct case_form_exhaustive_const_term.
apply H0. right; left; apply H1. destruct H1; auto.
destruct y. edestruct case_form_exhaustive_const_term.
apply H. left; apply H1. destruct H1; auto.
apply case_form_exhaustive_var_var; done.
Qed.

Lemma convert_bounded_term fv xs x :
  xs ≡ₚ elements fv -> bounded_term fv x -> bounded_term xs x.
Proof.
destruct x; simpl; intros.
done. rewrite H; set_solver.
Qed.

Lemma case_form_exhaustive fv md case a b :
  case.*1 ≡ₚ elements fv ->
  atom fv md a -> atom fv md b ->
  case_form md ⊥ case ⊢ a ⟹ b ∨ case_form md ⊥ case ⊢ ▷b ⟹ a.
Proof.
intros Hrange (x & m & Hx & Hm & ->) (y & n & Hy & Hn & ->).
rewrite laters_S; edestruct case_form_exhaustive_term_term
with (case:=case)(x:=x)(y:=y) as [H|[H|[(i & H)|(i & H)]]].
1,2: eapply convert_bounded_term; [apply Hrange|done].
- left; d_apply_l H; d_intro. d_apply_r d_laters_intro.
  d_mp. d_hyp. clr_l; apply d_laters_le; lia.
- right; d_apply_l H; d_intro. d_apply_r d_laters_intro.
  d_mp. d_hyp. clr_l; apply d_laters_le; lia.
- destruct (le_le_S_dec m (i + n)).
  + left; d_apply_l H; d_apply_l d_iff_laters.
    d_intro; d_mp. d_hyp. clr_l; rewrite <-laters_add.
    apply d_laters_le; lia.
  + right; d_apply_l H; d_apply_l d_iff_laters.
    d_intro; ecut. d_mp; [|clr_l; done]; d_hyp.
    rewrite <-laters_add; apply d_laters_le; lia.
- destruct (le_le_S_dec (i + m) n).
  + left; d_apply_l H; d_apply_l d_iff_laters.
    d_intro; ecut. d_mp; [|clr_l; done]; d_hyp.
    rewrite <-laters_add; apply d_laters_le; lia.
  + right; d_apply_l H; d_apply_l d_iff_laters.
    d_intro; d_mp. d_hyp. clr_l; rewrite <-laters_add.
    apply d_laters_le; lia.
Qed.

End Case_form_exhaustive.

Section List_cases.

Lemma list_cases_in case fv md :
  case ∈ list_cases fv md -> case.*1 ≡ₚ elements fv.
Proof.
unfold list_cases; intros.
eapply elem_of_list_bind in H as (xs & H1 & H2).
apply permutations_Permutation in H2; rewrite H2; clear H2.
replace case.*1 with xs; [done|].
apply elem_of_list_mapM in H1; induction H1. done.
apply elem_of_list_fmap in H as (n & -> & H).
rewrite fmap_cons, IHForall2; done.
Qed.

Lemma convert_to_case_form md bot cs xs :
  Forall2 (λ c p, c ∈ offset_clauses ($p.1) ($p.2) md)
    cs (adj (bot :: (t_Var <$> xs))) ->
  ∃ case, Forall2 (λ c i, c.1 = i ∧ c.2 ≤ S md) case xs ∧
    ⋀ cs ⊢ case_form md ($bot) case.
Proof.
unfold case_form; revert bot cs; induction xs as [|i xs]; intros.
- apply Forall2_nil_inv_r in H as ->.
  exists []; split. apply Forall2_nil; done. done.
- rewrite fmap_cons, adj_cons in H.
  apply Forall2_cons_inv_r in H as (c & cs' & H1 & H2 & ->).
  apply IHxs in H2 as (case & IH1 & IH2). unfold offset_clauses in H1.
  apply elem_of_list_fmap in H1 as (n & -> & Hn); simpl.
  apply in_seq_iff in Hn; exists ((i, n) :: case); split.
  apply Forall2_cons; simpl; split. lia. apply IH1.
  simpl. d_split. d_hyp. clr_l; apply IH2.
Qed.

Lemma d_list_cases fv md :
  ⊢ ⋁ (case_form md ⊥ <$> list_cases fv md).
Proof.
unfold list_cases.
ecut. apply d_permutations.
apply d_big_disj_elim; intros.
apply elem_of_list_fmap in H as (xs & -> & H).
ecut. apply d_offset_clauses_perm with (md:=md).
ecut. apply d_big_disj_conj_swap.
eapply d_big_disj_elim; intros.
apply elem_of_list_fmap in H0 as (cs & -> & Hcs).
apply elem_of_list_mapM in Hcs.
apply convert_to_case_form in Hcs as (case & H1 & H2).
d_apply_l H2; apply d_big_disj_intro.
apply elem_of_list_fmap; exists case; split. done.
apply elem_of_list_bind; exists xs; split; [|done].
eapply elem_of_list_mapM, Forall2_impl. apply H1.
intros [i n] i'; intros (<- & Hn); simpl in Hn.
apply elem_of_list_fmap; eexists; split. done.
apply in_seq_iff; lia.
Qed.

End List_cases.

Section Soundness.

Lemma eval_case_spec f case :
  eval_case f case = true ↔ realizes (Finite ∘ case_val case) ⊤ f.
Proof.
unfold eval_case, realizes;
rewrite Sω_le_leb; done.
Qed.

Theorem counterexample_sound f case :
  counterexample f = Some case ->
  ¬realizes (Finite ∘ case_val case) ⊤ f.
Proof.
intros; rewrite <-eval_case_spec.
apply find_some in H as [_ <-]; simpl; destruct (eval_case _); done.
Qed.

End Soundness.

Section Completeness.

Lemma fmap_later {X Y} (t : X -> Y) n (f : form X) :
  t <$> (n*▷f) = n*▷(t <$> f).
Proof.
induction n; simpl. done.
rewrite <-IHn; done.
Qed.

Lemma eval_later n f i :
  eval f = Finite i -> eval (n*▷f) = Finite (n + i).
Proof.
induction n; simpl; intros.
done. rewrite IHn; done.
Qed.

Lemma realizes_later_iff Γ p q i n :
  eval (interp Γ <$> p) = Finite i ->
  eval (interp Γ <$> q) = Finite (n + i) ->
  realizes Γ ⊤ (n*▷p ⟹ q) ∧ realizes Γ ⊤ (q ⟹ n*▷p).
Proof.
intros Hp Hq; split; apply realizes_impl_intro_top;
unfold realizes; erewrite fmap_later, eval_later, Hq; done.
Qed.

Lemma realizes_finite_atom Γ fv md a :
  atom fv md a -> realizes (Finite ∘ Γ) ⊤ a -> ∃ n, a = n*▷⊤.
Proof.
unfold realizes; intros ([[]|] & n & Hx & Hn & ->) H; simpl in *.
exists n; done. all: exfalso; erewrite fmap_later, eval_later in H; done.
Qed.

Lemma realizes_case_form md bot bot_n case Γ :
  (∀ i, i ∈ case.*1 -> Γ i = Finite (bot_n + case_val case i)) ->
  NoDup case.*1 -> eval (interp Γ <$> bot) = Finite bot_n ->
  realizes Γ ⊤ (case_form md bot case).
Proof.
unfold case_form; revert bot bot_n.
induction case as [|[i n] case]; rewrite ?fmap_cons; simpl; intros. done.
assert (Hi : eval (interp Γ <$> #i) = Finite (n + bot_n)).
simpl; rewrite H, Nat.eqb_refl, Nat.add_0_r, Nat.add_comm.
done. apply elem_of_list_here. apply realizes_conj_intro.
- edestruct realizes_later_iff. apply H1. apply Hi.
  unfold offset_clause; destruct (n <=? md).
  apply realizes_conj_intro; done. done.
- inv H0; apply IHcase with (bot_n:=n + bot_n).
  intros j Hj; rewrite H. 2: apply elem_of_list_further, Hj.
  destruct (j =? i) eqn:E. apply Nat.eqb_eq in E as ->; done.
  rewrite Nat.add_assoc, Nat.add_comm with (m:=n); done. done. done.
Qed.

Lemma case_val_realizes_case_form md case :
  NoDup case.*1 ->
  realizes (Finite ∘ case_val case) ⊤ (case_form md ⊥ case).
Proof.
intro Hfv; eapply realizes_case_form; try done.
intros i Hi; rewrite Nat.add_0_l; done.
Qed.

Lemma case_form_reduce f  case :
  case.*1 ≡ₚ elements (FV f) ->
  ∃ a, atom (FV f) (MD f) a ∧
  case_form (MD f) ⊥ case ⊢ f ⟺ a.
Proof.
intros; eapply d_reduce_to_atom.
intros; eapply case_form_exhaustive.
all: done.
Qed.

Lemma eval_case_complete f case :
  case.*1 ≡ₚ elements (FV f) ->
  eval_case f case = true ->
  case_form (MD f) ⊥ case ⊢ f.
Proof.
intros Hfv Heval; edestruct case_form_reduce as (a & Ha & Hf).
apply Hfv. eapply realizes_finite_atom in Ha as [d ->].
d_apply_l Hf; d_mp. d_hyp. clr; apply d_laters_intro.
etrans. apply realizes_conj_intro.
eapply case_val_realizes_case_form.
rewrite Hfv; apply NoDup_elements.
apply eval_case_spec, Heval.
apply deduction_sound.
d_revert; d_apply_l Hf; d_hyp.
Qed.

Theorem counterexample_complete f :
  counterexample f = None -> ⊤ ⊢ f.
Proof.
unfold counterexample; intros. ecut.
apply d_list_cases with (fv:=FV f)(md:=MD f).
eapply d_big_disj_elim; intros p Hp.
apply elem_of_list_fmap in Hp as (case & -> & Hcase).
apply eval_case_complete. eapply list_cases_in, Hcase.
eapply find_none, negb_false_iff in H.
apply H. apply elem_of_list_In, Hcase.
Qed.

End Completeness.

End Counterexample_search.

Theorem deduction_decidable p q :
  { p ⊢ q } + { ∃ Γ, ¬ realizes Γ p q }.
Proof.
destruct (counterexample (p ⟹ q)) as [case|] eqn:E.
- right; eexists. intros H; apply realizes_impl_intro_top in H.
  eapply counterexample_sound. apply E. apply H.
- left; apply d_impl_revert_top.
  apply counterexample_complete, E.
Qed.

Corollary deduction_complete p q :
  (∀ Γ, realizes Γ p q) -> p ⊢ q.
Proof.
intros; edestruct deduction_decidable as [D|[Γ C]].
apply D. exfalso; apply C, H.
Qed.