(*
This is a verified (certified) boolean formula solver (the SAT solver).
The formula consists of literals, negations, conjunctions, and disjunctions.
This algorithm implements full exhaustive search using list of all possible
valuations for the formula.

This is NOT a backtracking algorithm described on wikipedia.
This is just another one. It looks to me like it is not easy thing
to implement unit propagation and pure literal elimination for this
algorithm. But the second step of algorithm should be easy to perform in
parallel mode.

The idea of the algorithm:
    1. Basing on formula variable list build a list of all possible
       valuations for the formula.
    2. Take this valuations one by one and check the formula using each
       valuation. If we face the valuation on which the formula evaluates to
       true, this means we have what we need. Otherwise, when after the
       checking all possible valuations we haven't found the valuation on which
       the formula evaluates to true, this means that for all possible
       valuations formula evaluates to false.

This task is inspired by Adam Chlipala's tasks for the
"Certified Programming with Dependent Types" (CPDT) book,
http://adam.chlipala.net/cpdt/ .

The aim of this work is to show programming skills and have a bit fun.
*)

From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Set Asymmetric Patterns.

Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Our variables are encoded as natural numbers. *)
Definition var := nat.

(* Boolean formula. *)
Inductive formula : Set :=
  | Flit of var                  (* literal *)
  | Fneg of formula              (* negation of the formula *)
  | Fcon of formula & formula    (* conjunction of two formulas *)
  | Fdis of formula & formula.   (* disjunction of two formulas *)

(* Valuation is a map from variable to bool. *)
Definition valuation : Set := var -> bool.

(* Evaluates the formula. *)
Fixpoint formulaDenote (truth : valuation) (f : formula) : bool :=
  match f with
  | Flit var => truth var
  | Fneg f' => ~~ (formulaDenote truth f')
  | Fcon f1 f2 => formulaDenote truth f1 && formulaDenote truth f2
  | Fdis f1 f2 => formulaDenote truth f1 || formulaDenote truth f2
  end.

(* Specification for `formulaDenote` *)
Inductive formulaDenoteSpec : valuation -> formula -> bool -> Set :=
| SpecLit vl v :
    formulaDenoteSpec vl (Flit v) (vl v)
| SpecNeg vl f b :
    formulaDenoteSpec vl f b ->
    formulaDenoteSpec vl (Fneg f) (~~b)
| SpecDis1 vl f1 f2 :
    formulaDenoteSpec vl f1 true ->
    formulaDenoteSpec vl (Fdis f1 f2) true
| SpecDis2 vl f1 f2 b2 :
    formulaDenoteSpec vl f1 false ->
    formulaDenoteSpec vl f2 b2 ->
    formulaDenoteSpec vl (Fdis f1 f2) b2
| SpecConj1 vl f1 f2 :
    formulaDenoteSpec vl f1 false ->
    formulaDenoteSpec vl (Fcon f1 f2) false
| SpecConj2 vl f1 f2 b2 :
    formulaDenoteSpec vl f1 true ->
    formulaDenoteSpec vl f2 b2 ->
    formulaDenoteSpec vl (Fcon f1 f2) b2.

(* Proof that `formulaDenote` satisfy to the specification above *)
Lemma formulaDenoteCorrect  vl f : formulaDenoteSpec vl f (formulaDenote vl f).
  elim: f => /= [ v | f | f1 H1 f2 H2 | f1 H1 f2 H2 ];
    [ by constructor
    | by constructor
    | case E: (formulaDenote vl f1) => //=; constructor => //;
        by move: H1; rewrite E .. ].
Defined.

(* Add variable with value to the valuation. *)
Definition add_val (x : var) (value : bool) (vl : valuation) : valuation :=
  fun v => if v == x then value else vl v.

(* Notation from Software Foundations book (by Pierce at al.) *)
Notation "x '!->' v ';' vl" := (add_val x v vl)
                                 (at level 100, v at next level,
                                  right associativity).

Section Maybe.
  (* First we build simple version using the maybe type *)
  (* as it is shown in the CPDT book. *)

  (* The `maybe` type and notation from CPDT. *)
  Inductive maybe (A : Set) (P : A -> Prop) : Set := Unknown | Found a of P a.

  Notation "{{ x | P }}" := (@maybe _ (fun x => P)).
  Notation "??" := (Unknown _).
  Notation "[| x |]" := (@Found _ _ x _).

  (* Adding one variable to given valuation list. *)
  (* Adding both values (`true` and `false`) for variable `x` to *)
  (* both copies of head and repeat for tail. *)
  Fixpoint add_var' (x : var) (vals : list valuation) : list valuation :=
    match vals with
    | [:: ] => [:: ]
    | vl :: vls => [::  x !-> true; vl, x !-> false; vl & add_var' x vls]
     end.

  (* Building list of all possible valuations for given variable list. *)
  (* We start from `[ (fun _ => false) ]` and then add each variable *)
  (* to the list one by one using `add_var`. *)
  Fixpoint buildValuations' (vars : list var) : list valuation :=
    match vars with
    | [:: ] => [:: xpred0 ]
    | v :: vs => add_var' v (buildValuations' vs)
    end.

  (* Try to find a valuation on which given formula evaluates to `true`. *)
  (* Just go through valuation list and try each valuation *)
  (* using `formulaDenote`. *)
  Definition solveFormula' f :
    forall (vals : list valuation), {{vl | formulaDenote vl f}}.
    refine(fix F vals : {{vl | formulaDenote vl f}} :=
             if vals is vl' :: vals'
             then
               _
             else ??
          ).
    case H: (formulaDenote vl' f).
      by apply: [| vl' |].
      by apply: (F vals').
  Defined.
End Maybe.

(* ************************************************************************* *)
(*                                                                           *)
(* Below we define valuation equivalence under a given variable list and     *)
(* several lemmas for it.                                                    *)
(* We are interested in equivalence of two valuations for a given formula f, *)
(* so, we consider two valuations as equivalent (for the formula) when they  *)
(* both have the same assigments for all formula'sariables.                  *)
(*                                                                           *)
(* ************************************************************************* *)

(* Predicates for working with valuations, similar to mathcomp library's. *)
Notation xpredEq := (fun (p1 p2 : pred _) x => p1 x == p2 x).
Notation xpredNeq := (fun (p1 p2 : pred _) x => p1 x != p2 x).
Definition predEq :=
  fun (T : Type) (p1 p2 : pred T) => [pred x | xpredEq p1 p2 x].
Definition predNeq :=
  fun (T : Type) (p1 p2 : pred T) => [pred x | xpredNeq p1 p2 x].

Search "symmetry".

(* Symmetry for an equality predicate. *)
Lemma predEq_sym (T : eqType) (p1 p2 : pred T) : predEq p1 p2 =1 predEq p2 p1.
    by move => x /=; rewrite eq_sym.
Defined.

(* Valuation equivalence under given variable list itself. *)
Definition eqv (vrs : list var) (vl vl' : var -> bool) :=
  all (predEq vl vl') vrs.

(* Useful notation similar to what mathcomp library has. *)
Notation "vl '==(' vrs ')' vl'" := (eqv vrs vl vl') (at level 50).

(* Valuation equivalence reflexivity. *)
Lemma eqv_refl vrs : reflexive (eqv vrs).
  rewrite /reflexive => vl; apply/allP => x0 H; apply: eq_refl.
Defined.

(* If two valuations are equivalent under a variable list then *)
(* they return the same value for any variable in the list. *)
Lemma eqv_in vrs vl vl' v : vl ==(vrs) vl' -> v \in vrs -> vl v == vl' v.
    by move/allP => /(_ v) H /H.
Defined.

(* Valuation equivalence symmetry. *)
Lemma eqv_sym vrs vl vl' : (vl ==(vrs) vl') = (vl' ==(vrs) vl).
    by rewrite /eqv;
       under eq_all => x do rewrite predEq_sym.
Defined.

(* Valuation equivalence symmetry. *)
(* JFF, proof with induction. *)
Lemma eqv_sym' vrs vl vl' : (vl ==(vrs) vl') = (vl' ==(vrs) vl).
    by elim: vrs => //= v vrs ->; rewrite eq_sym.
Defined.

(* Valuation equivalence transitivity. *)
Lemma eqv_trans vrs : transitive (eqv vrs).
  rewrite /transitive => vl2 vl1 vl3 /allP H12 /allP H23; apply/allP => x H.
  by move: (H12 x H) (H23 x H) => /eq_op_trans H1 /H1.
Defined.

(* Include - are all variables of one sequence (`vrs'`) also *)
(* members of another (`vrs`)? (So, vrs is 'bigger' then vrs'). *)
Definition incl (T : eqType) (vrs' vrs : seq T) := all (mem vrs) vrs'.

(* If two valuations are equivalent under a variable list `vrs` then *)
(* they are also equivalent under any variable list included to `vrs`. *)
Lemma eqv_incl vrs vrs' vl vl' :
  incl vrs' vrs -> vl ==(vrs) vl' -> vl ==(vrs') vl'.
  move => /allP Hincl /allP Heqv.
  by apply/allP => x /Hincl /Heqv.
Defined.

(* When we have `undup (vrs ++ vrs')` *)
(* then we also have both includes below: *)
(* `incl vrs (undup (vrs ++ vrs'))`  *)
(* `incl vrs' (undup (vrs ++ vrs'))`. *)
Lemma incl_undup_cat (T : eqType) (vrs vrs' : seq T) :
  incl vrs (undup (vrs ++ vrs')) /\ incl vrs' (undup (vrs ++ vrs')).
  rewrite /incl; split;
    by apply/allP => t; rewrite /= mem_undup mem_cat => -> //; apply/orbT.
Defined.

(* Check if valuation is in list using valuation equivalence under *)
(* variable list. *)
Definition has_val (vrs : seq var) (val : valuation) (vls : list valuation) :=
  has (fun val' => val ==(vrs) val') vls.

(* Notation similar to mathcomp's *)
Notation "vl '\in(' vrs ')' vls" := (has_val vrs vl vls) (at level 30).
Notation "vl '\notin(' vrs ')' vls" := (~~has_val vrs vl vls) (at level 30).

(* Valuation list is complete under given variable list when *)
(* for any given valuation there is an equivalent  valuation *)
(* in the valuation list *)
Definition valuation_list_complete (vrs : seq var) (vals : seq valuation) :=
  forall (vl : valuation), vl \in(vrs) vals.

(* Notation for list completeness under variable list. *)
Notation "'\complete(' vrs ')' vls" :=
  (valuation_list_complete vrs vls) (at level 50).

(* When valuation list is complete and formula `f` evaluates to some *)
(* value `b` on all valuations from the list, this means that formula `f` *)
(* evaluates to value `b` on all valuations. *)
(* Just a direct consequence from the completeness definition given above. *)
Corollary list_complete__no_more_valuations f vrs vls :
  \complete(vrs) vls ->
  forall b, (forall vl, vl \in(vrs) vls -> formulaDenote vl f == b) ->
       forall vl, formulaDenote vl f == b.
  rewrite /valuation_list_complete => H1 b H2 vl.
  by move: (H1 vl) => /H2.
Defined.

(* Specialization of lemma above to boolean `false` due to some problems *)
(* arose when rewriting general lemma. *)
Lemma list_complete__no_more_valuations_false f vrs vls:
  \complete(vrs) vls ->
  (forall vl, vl \in(vrs) vls -> ~~ formulaDenote vl f) ->
  forall vl, ~~ formulaDenote vl f.
  move => lc H vl.
  rewrite -eqbF_neg;
    apply: (@list_complete__no_more_valuations f vrs vls lc _) => // vl0 H1.
  move: (H vl0 H1); by rewrite eqbF_neg.
Defined.

(* We also need three lemmas about `add_val`. *)
(* (Two of them just like in Software Foundations, keyword is `t_update`) *)

(* We have the same value for variable which we have just added to valuation *)
Lemma add_val_eq vl x v : (x !-> v; vl) x = v.
  by rewrite /add_val eq_refl.
Defined.

(* When we add a new variable to valuation, then value of the old variable *)
(* is the same as before adding the new one. *)
Lemma add_val_neq vl x x' v : x' != x -> (x !-> v; vl) x' = vl x'.
  by rewrite /add_val => /negbTE ->.
Defined.

(* When we add a new variable to valuation and this new variable is not in *)
(* given variable list, then resulting valuation equals under variable list *)
(* to initial valuation. *)
Lemma add_val_notin_eqv vrs vl x v :
  x \notin vrs ->
  vl ==(vrs) (x !-> v; vl).
  elim: vrs => //= x' vrs' IH; rewrite in_cons.
  case E: (x == x') => //= /IH ->; rewrite add_val_neq;
    first by rewrite eq_refl.
  by move: E; rewrite eq_sym => ->.
Defined.

(* ****************************************************************** *)
(*                                                                    *)
(* Now after we have built a 'skeleton' version of `solveFormula`,    *)
(* and some theory about valuations, valuation equality, and          *)
(* and valuation lists, we are ready to build 'certified' version     *)
(* of solveFormula, so, the one with type                             *)
(*       `{vl | formulaDenote vl f = true} +                          *)
(*        {forall vl, formulaDenote vl f = false}`                    *)
(*                                                                    *)
(* ***   The main idea of certified algorithm.   ***                  *)
(*                                                                    *)
(* We search for valuation on which formula evaluates to true,        *)
(* otherwise, if we are not able to find such valuation, this means   *)
(* that on all possible valuations formula returns false.             *)
(*                                                                    *)
(* When we have the complete list of valuations, we can show that     *)
(* either we have such valuation in the list, or there is no such     *)
(* valuations at all (see lemma `list_complete__no_more_valuations`). *)
(*                                                                    *)
(* So, what we need to do is essentially to build complete list of    *)
(* valuations for the formula (means for the formula variables,       *)
(* see lemma `vals_eqv__f_eq` below) and check if there is valuation  *)
(* with required properties in the list.                              *)
(* ****************************************************************** *)

(* ****************************************************************** *)
(*                                                                    *)
(* The first step of certified algorithm: building the complete       *)
(* valuation list for given list of (formula) variables.              *)
(*                                                                    *)
(* ****************************************************************** *)

(* Useful notation from CPDT *)
Notation "[ x ]" := (@exist _ _ x _).
Notation "!!" := (inright _ _).
Notation "[|| x ||]" := (inleft _ [x]).

(* Add one variable to complete list.                               *)
(* When we add one variable which is not in `vrs`, and `vls`        *)
(* is complete under `vrs` then we have `vls1` which is complete    *)
(* under `v::vrs`.                                                  *)
Definition add_var v vrs vls (prf : v \notin vrs) :
  {vls1 | forall vl, vl \in(vrs) vls -> vl \in(v::vrs) vls1}.
  refine(
      let fix F vls' : {vls1' | forall vl', vl' \in(vrs) vls' -> vl' \in(v::vrs) vls1'} :=
          match vls' with
          | [:: ] => [ [:: ] ]
          | vl'' :: vls'' =>
            let: [ vls1'' ] := F vls''
             in  [ [::  v !-> true; vl'', v !-> false; vl'' & vls1''] ]
          end
      in F vls
    ); first by [].
  move => vl'; move: (i vl') => {i} IH /=.
  case E: (vl' ==(vrs) vl'') => /=;
    last by move /IH ->; rewrite !orbT.
  rewrite !add_val_eq !(eqv_trans E) //;
    [ | by apply: add_val_notin_eqv .. ];
    by case : (vl' v).
Defined.

(* We just add variables one by one using `add_var` to list complete *)
(* list. The first list is complete under empty variable list *)
(* (any list is ok). Then `add_var` does its job. *)
Definition buildValuations vrs : uniq vrs -> {vls | forall vl, vl \in(vrs) vls}.
  refine (let fix F vrs : uniq vrs -> {vls | forall vl, vl \in(vrs) vls} :=
            match vrs with
            | [:: ] => fun _ => [ [:: xpred0] ]
            | v' :: vrs' =>
              fun Hu =>
                let: [ vls' ] := F vrs' _ in
                let: [ vls1'] := @add_var v' vrs' vls' _ in
                [ vls1' ]
            end
          in F vrs); first by []; move: Hu => /= /andP [] //.
  move => Hnin Hu vl.
  by move: (i vl) => /i0.
Defined.

(* ************************************************************** *)
(*                                                                *)
(* Now we need relate formula and its variable list               *)
(*                                                                *)
(* ************************************************************** *)

(* Build list of all formula variables for the given formula f. *)
Fixpoint fvars (f : formula) : seq var :=
  match f with
  | Flit x => [:: x]
   | Fneg f' => fvars f'
  | Fcon f1 f2 | Fdis f1 f2 => undup (fvars f1 ++ fvars f2)
  end.

(* Relation which exresses that given list of variables contains all *)
(* variables of the given formula. *)
Inductive vs : formula -> seq var -> Set :=
| VsLit x :
    vs (Flit x) [::x]
| VsNeg f xs :
    vs f xs -> vs (Fneg f) xs
| VsCon f1 xs1 f2 xs2 :
    vs f1 xs1 ->
    vs f2 xs2 ->
    vs (Fcon f1 f2) (undup (xs1 ++ xs2))
| VsDis f1 xs1 f2 xs2 :
    vs f1 xs1 ->
    vs f2 xs2 ->
    vs (Fdis f1 f2) (undup (xs1 ++ xs2)).

(* Proof that `fvars` gives all formula variables. *)
Definition vars_vs : forall f, vs f (fvars f).
  elim; by constructor.
Defined.

(* Proof that `fvars` is uniq *)
Lemma vars_uniq f : uniq (fvars f).
  elim: f => //= f1 H1 f2; by rewrite undup_uniq.
Defined.

(* Formula evaluates to the same value on valuations which *)
(* are equivalent under formula variable list. *)
Lemma vals_eqv__f_eq f vrs: vs f vrs ->
  forall vl' vl,
    vl ==(vrs) vl' ->
    formulaDenote vl f = formulaDenote vl' f.
  elim => /=
           [ x vl' vl /andP [] /eqP //
           | f0 vrs0 H IH vl vl'
           | f0 vrs0 f1 vrs1 H0 IH0 H1 IH1 vl' vl
           | f0 vrs0 f1 vrs1 H0 IH0 H1 IH1 vl' vl
           ];
    [ by move/IH => ->
    | move: (incl_undup_cat vrs0 vrs1) =>
        [] /eqv_incl Hi0 /eqv_incl Hi1 H;
        by move: (Hi0 _ _ H) (Hi1 _ _ H) => /IH0 -> /IH1 -> .. ].
Defined.

(* Solving the formula. The idea is essentially the same as for *)
(* `solveFormula'` above: we just go through the list of valuations *)
(* and check the formula on valuation valuation. *)
(* The only thing now is that we show that we have checked every *)
(* valuation from the given valuation list. *)
Definition solveFormula1 f (vrs : seq var) (prf : vs f vrs):
  forall (vals : list valuation),
    {vl | formulaDenote vl f} +
    {forall vl, vl \in(vrs) vals -> ~~formulaDenote vl f}.
  refine(fix F vals : {vl | formulaDenote vl f} +
                      {forall vl, (vl \in(vrs) vals) -> ~~formulaDenote vl f} :=
           if vals is vl' :: vals'
           then
             _
           else !!
        ); first by [].
  case H: (formulaDenote vl' f); first by apply: [|| vl' ||].
  case: (F vals'); first by left.
  move => H1; right => vl /= /orP []; last by apply/H1.
  by move => /(vals_eqv__f_eq prf) ->; rewrite H.
Defined.

(* If our list of valuations is complete and we havent found valuation *)
(* in this list, this means that there is no such valuation at all *)
(* (The case when we have found such valuation is easy one) *)
Definition solveFormula0
        f (vrs : seq var)
        (prf : vs f vrs)
        (vals : list valuation)
        (vlc : \complete(vrs) vals)
  :
  {truth | formulaDenote truth f} + {forall truth, ~~formulaDenote truth f}.
  case: (@solveFormula1 f vrs prf vals).
  move => [] truth H; by apply: [|| truth ||].
  move /(list_complete__no_more_valuations_false vlc); by right.
Defined.

(* Certified `solveFormula` function. *)
(* Take the complete valuation list and try to find valuation with *)
(* needed properties in it. *)
Definition solveFormula f :
  {truth | formulaDenote truth f} + {forall truth, ~~formulaDenote truth f}.
  refine(
      let: [ vls ] := buildValuations (vars_uniq f)
      in solveFormula0 (vars_vs f) _).
  apply: i.
Defined.

Eval compute in solveFormula (Fcon (Flit 1) (Fneg (Flit 1))).
Eval compute in solveFormula (Fdis (Flit 1) (Fneg (Flit 1))).

(*
Adding CNF predicate , so this is simple verified CNF solver now,
https://en.wikipedia.org/wiki/Conjunctive_normal_form
*)
Inductive clause : formula -> Set :=
| clLit v : clause (Flit v)
| clNeg v : clause (Fneg (Flit v))
| clDis f1 f2 of clause f1 & clause f2 : clause (Fdis f1 f2).

Inductive cnf : formula -> Set :=
| clBase f of clause f : cnf f
| clCon f1 f2 of cnf f1 & cnf f2 : cnf (Fcon f1 f2).

Definition solveCNFFormula f (_ : cnf f) :
  {truth | formulaDenote truth f} + {forall truth, ~~formulaDenote truth f} :=
  solveFormula f.


Module ODRL.

Require Import Arith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Init.Datatypes.
Set Implicit Arguments .

Definition l23 : list nat
  := 2 :: 3 :: nil.

Locate pair.

(*
Inductive triple M := Triple : M -> M -> M -> triple M.
Notation "[ x , y , z ]" := (Triple x y z).
Definition triple1 := [1,2,3].
*)

(*
Inductive C : sort :=

| c1 : C1           c1 is the constructor, and C1 is the type of the c1
| ...
| cn : Cn.

Naming convention: Constructors start with Capital letter, types with lower case.

where name is the name of the type to be defined; sort is one of Set or Type
(or even Prop); ci are the names of the constructors and Ci is the type of the
constructor ci.
The declaration of an inductive definition introduces new primitive objects
for the type itself and its constructors; it also generates theorems which are
abbreviations for more complex terms expressing that name is the smallest set
containing the terms build with constructors. These theorems provide induction
principles to reason on objects in inductive types.
*)

Section nonemptylist.

Variable X : Set.

Inductive nonemptylist : Set :=
  | Single : X -> nonemptylist
  | NewList : X -> nonemptylist -> nonemptylist.

Fixpoint app_nonempty (l1 l2 : nonemptylist) : nonemptylist :=
  match l1 with
  | Single s  => NewList s l2
  | NewList s rest => NewList s (app_nonempty rest l2)
  end.

End nonemptylist.

Definition ne2 := Single 2.
Definition ne3 := NewList 3 ne2.
Definition ne4 := NewList 4 (NewList 8 (Single 8)).

Notation "x , l" := (NewList x l) (at level 60, right associativity).
Notation "[ x ]" := (Single x).

Definition mylist2 := 1 , 2 , [3].

Section Fold_Nonempty.
  Variables A B : Set.
  Variable f : B -> A -> A.
  Variable a0 : A.

  Fixpoint fold_nonempty (l:nonemptylist B) : A :=
    match l with
      | Single s => f s a0
      | NewList s rest => f s (fold_nonempty rest)
    end.

End Fold_Nonempty.

Section MyPair.
  Variable X : Set.
  Variable Y : Set.

  Record Twos : Set :=
  mkTwos
  {
    left    : X;
    right   : Y
  }.
End MyPair.

Definition half := (mkTwos 2 5).

Eval compute in (left half).
Check half.
Check Twos.

Section Process_Lists.

Variable X : Set.
Variable Y : Set.
Variable Z : Set.

Fixpoint process_two_lists (l1 : nonemptylist X) (l2 : nonemptylist Y) :  nonemptylist (Twos X Y) :=

let process_element_list := (fix process_element_list (e1 : X) (l2 : nonemptylist Y) :  nonemptylist (Twos X Y) :=
  match l2 with
    | Single s => Single (mkTwos e1 s)
    | NewList s rest => app_nonempty (Single (mkTwos e1 s)) (process_element_list e1 rest)
  end) in

  match l1 with
    | Single s => process_element_list s l2
    | NewList s rest => app_nonempty (process_element_list s l2) (process_two_lists rest l2)
  end.

End Process_Lists.

Definition lst1 := process_two_lists (NewList 4 (NewList 8 (Single 8))) (NewList 3 (NewList 2 (Single 1))).
Eval compute in lst1.

(*
Eval compute in
fold_nonempty (fun x y => x + y) 0 lst1.
*)

Definition lst2 := process_two_lists (NewList 91 (Single 92)) (NewList 3 (NewList 2 (Single 1))).
Eval compute in lst2.

Definition subject := nat.

Inductive prin : Set :=
  | Prin : subject -> prin
  | Prins : nonemptylist prin -> prin.

Definition myprin1 := Prin 5.
Check myprin1.
Definition myprin_list := NewList myprin1 (Single (Prin 2)).
Definition myprins := Prins myprin_list.
Check myprins.

Definition act := nat.
Definition Play := 1.
Definition Print := 2.
Definition Display := 3.

Definition asset := nat.
Definition FindingNemo := 1.
Definition Alien := 2.
Definition Beatles := 3.
Definition LoveAndPeace := 4.

Definition money := nat.

Definition policyId := nat.

Section times.

Definition time := nat.

Inductive timeprod : Set :=
  timepair : time -> time -> timeprod.

Definition rangestart (p : timeprod) : time :=
  match p with
  | timepair x y => x
  end.
Definition rangeend (p : timeprod) : time :=
  match p with
  | timepair x y => y
  end.

Definition inRange (t: time) (p : timeprod) : Prop :=
  ((rangestart p) <= t) /\ (t <= (rangeend p)).

End times.

Eval simpl in (timepair 2 5).

Eval simpl in (inRange 2 (timepair 2 5)).

Inductive requirement : Set :=
  | PrePay : money -> requirement
  | Attribution : subject -> requirement
  | InSequence : nonemptylist requirement -> requirement
  | AnySequence : nonemptylist requirement -> requirement.

Inductive constraint : Set :=
  | Principal : prin  -> constraint
  | ForEachMember : prin  -> nonemptylist (constraint ) -> constraint
  | Count : nat -> constraint
  | CountByPrin : prin -> nat -> constraint.

(*
Inductive policyId : Set :=
  | PolicyId : nat -> policyId.
*)

Inductive preRequisite : Set :=
  | TruePrq : preRequisite
  | Constraint : constraint -> preRequisite
  | Requirement : requirement -> preRequisite
  | Condition : cond -> preRequisite
  | AndPrqs : nonemptylist (preRequisite) -> preRequisite
  | OrPrqs : nonemptylist (preRequisite) -> preRequisite
  | XorPrqs : nonemptylist (preRequisite) -> preRequisite

with cond : Set :=
  | SuspendPS : policySet -> cond
  | SuspendConstrint : constraint -> cond

with policySet : Set :=
  | PrimitivePolicySet : preRequisite -> policy -> policySet
  | PrimitiveExclusivePolicySet : preRequisite -> policy  -> policySet
  | AndPolicySet : nonemptylist (policySet) -> policySet

with policy : Set :=
  | PrimitivePolicy : preRequisite -> policyId -> act -> policy
  | AndPolicy : nonemptylist (policy) -> policy.

Inductive agreement : Set :=
  | Agreement : prin -> asset -> policySet -> agreement.

Definition const1 := Count 5.
Definition preReq1 := Constraint const1.
Definition policyId1 := 12.
Definition act1 := Print.
Check preReq1.
Check PrimitivePolicy.
Check (Constraint (Count 5)).

(*
preReq1 : preRequisite nat
PrimitivePolicy : forall X : Type, list (preRequisite X) -> policyId -> act -> policy X
Constraint : forall X : Type, constraint X -> preRequisite X
*)
Definition p1 := PrimitivePolicy (Constraint (Count 5)) policyId1 act1.

Check length.
Print length.

Definition makePrimitivePolicy (prq : preRequisite) (id : policyId) (ac : act) : policy :=
  PrimitivePolicy prq id ac.

Definition p2 := makePrimitivePolicy (Constraint (Count 7)) 22 Print.

Definition p3 := makePrimitivePolicy (Constraint (Count 8)) 23 Display.

Inductive user : Set :=
  | Alice : user
  | Bob : user
  | Charlie : user
  | David : user
  | Alex : user.

(* First, you need to introduce the predicates.  Here is one example. *)

(*
Assumptions extend the environment with axioms, parameters, hypotheses or variables. An assumption binds an ident to a type. It is accepted by Coq if and only if this type is a correct type in the environment preexisting the declaration and if ident was not previously defined in the same module. This type is considered to be the type (or specification, or statement) assumed by ident and we say that ident has type type.

Axiom ident :term .

This command links term to the name ident as its specification in the global context. The fact asserted by term is thus assumed as a postulate.

Parameter ident :term.
Is equivalent to Axiom ident : term
*)

Parameter Permitted : subject -> act -> asset -> Prop.

(* The following 2 definitions implement the translation of a
   principle to a formula.  I implemented these 2 in full to give you
   a complete example.  The first illustrates recursive function definitions
   in Coq. *)

(******
If a fixpoint is not written with an explicit { struct ... }, then
all arguments are tried successively (from left to right) until one is
found that satisfies the structural decreasing condition.
*******)

(* is x in prin? *)
Fixpoint trans_prin
  (x: subject)(p: prin) : Prop :=

let trans_prin_list := (fix trans_prin_list (x: subject)(prins: nonemptylist prin){struct prins} : Prop :=
  match prins with
    | Single s => trans_prin x s
    | NewList s prins' => ((trans_prin x s) \/ trans_prin_list x prins')
  end) in

  match p with
    | Prin s => (x=s)
    | Prins prins => trans_prin_list x prins
  end.

(* This definition is what needs to be filled in.  It shows the
   general structure of mutually recursive functions in Coq.  It
   defines 6 functions mutually recursively, but I didn't try to get
   them all.  There are probably some missing.  You will also probably
   want to implement some helper functions outside the structure of
   this recursive definition.  In each case there are a bunch of
   arguments in parentheses, followed by a "struct" declaration, which
   indicates which argument the recursion will be on.  The result
   "True" must be filled in with the real definition.  Notice that
   some functions have a regular and a list version.  The list version
   needs to call the regular version on every element of the list,
   similar to how trans_prin_list above works. *)

Definition getIds (p:policy) : nonemptylist policyId := Single 2.

Check getIds.

Definition getPrincipals (prn : prin) : nonemptylist prin :=
  match prn with
    | Prin s => Single prn
    | Prins prin_list => prin_list
  end.

Check getPrincipals.

Fixpoint trans_preRequisite_list
  (x:subject)(preReqs:nonemptylist preRequisite)(IDs:list policyId)
  (Ss:list subject){struct preReqs} : Prop :=
  True.

(*
Fixpoint trans_forEachMember
  (x:subject)(principals: nonemptylist prin)(const_list:nonemptylist constraint)
  (IDs:nonemptylist policyId)(a:asset){struct const_list} : Prop :=
  True
*)

(*
subjects(s) => {s}
subjects({prin1, . . . , prink}) => subjects(prin1) + ... + subjects(prink)
*)

Fixpoint getSubjects (prn : prin) : nonemptylist subject :=
let getSubjectsAux
  := (fix getSubjectsAux
        (prins_list : nonemptylist prin) :=
            match prins_list with
              | Single prn => getSubjects prn
              | NewList prn prn_list =>  app_nonempty (getSubjects prn) (getSubjectsAux prn_list)
            end) in

  match prn with
    | Prin s => Single s
    | Prins prin_list => getSubjectsAux prin_list
  end.

Definition getCount (s:subject) (id: policyId) : nat :=
2.

Fixpoint trans_count
  (x:subject)(n:nat)(IDs:nonemptylist policyId)
  (prin_u:prin)(a:asset) : Prop :=

  let trans_count_aux
    := (fix trans_count_aux
         (ids_and_subjects : nonemptylist (Twos policyId subject)) : nat :=
     match ids_and_subjects with
        | Single pair1 => getCount (right pair1) (left pair1)
        | NewList pair1 rest_pairs =>
            (getCount (right pair1)(left pair1)) +
            (trans_count_aux rest_pairs)
      end) in

  let ids_and_subjects := process_two_lists IDs (getSubjects prin_u) in
  let running_total := trans_count_aux ids_and_subjects in
  running_total < n.

Fixpoint trans_constraint
  (x:subject)(const:constraint)(IDs:nonemptylist policyId)
  (prin_u:prin)(a:asset){struct const} : Prop :=

  let trans_const_list
    := (fix trans_const_list
         (x:subject)(const_list:nonemptylist constraint)
	 (IDs:nonemptylist policyId)(prin_u:prin)(a:asset){struct const_list} :=
     match const_list with
       | Single const1 => trans_constraint x const1 IDs prin_u a
       | NewList const const_list' => ((trans_constraint x const IDs prin_u a) /\ (trans_const_list x const_list' IDs prin_u a))
     end) in
(*
let trans_forEachMember_Aux
  := (fix trans_forEachMember_Aux
         (x:subject)(prins_and_constraints : nonemptylist (Twos prin constraint))
         (IDs:nonemptylist policyId)(a:asset) {struct prins_and_constraints} : Prop :=

      match prins_and_constraints with
        | Single pair1 => trans_constraint x (right pair1) IDs (left pair1) a
        | NewList pair1 rest_pairs =>
            (trans_constraint x (right pair1) IDs (left pair1) a) /\
            (trans_forEachMember_Aux x rest_pairs IDs a)
      end) in

let trans_forEachMember
  := (fix trans_forEachMember
         (x:subject)(principals: nonemptylist prin)(const_list:nonemptylist constraint)
         (IDs:nonemptylist policyId)(a:asset){struct const_list} : Prop :=

      let prins_and_constraints := process_two_lists principals const_list in
      trans_forEachMember_Aux x prins_and_constraints IDs a) in

*)
  match const with
    | Principal prn => trans_prin x prn

    | ForEachMember prn const_list => True (*trans_forEachMember x (getPrincipals prn) const_list IDs a*)

    | Count n => trans_count x n IDs prin_u a

    | CountByPrin prn n => True

  end

with trans_requirment
(x:subject)(prq:preRequisite)(IDs:nonemptylist policyId)(prin_u:prin)(a:asset){struct prq} : Prop :=
  True.
(*
with trans_condition
(x:subject)(prq:preRequisite)(IDs:nonemptylist policyId)(prin_u:prin)(a:asset){struct prq} : Prop :=
  True
with trans_andPrqs
(x:subject)(prq:preRequisite)(IDs:nonemptylist policyId)(prin_u:prin)(a:asset){struct prq} : Prop :=
  True
with trans_orPrqs
(x:subject)(prq:preRequisite)(IDs:nonemptylist policyId)(prin_u:prin)(a:asset){struct prq} : Prop :=
  True
with trans_xorPrqs
(x:subject)(prq:preRequisite)(IDs:nonemptylist policyId)(prin_u:prin)(a:asset){struct prq} : Prop :=
  True
*)
Fixpoint trans_preRequisite
  (x:subject)(prq:preRequisite)(IDs:nonemptylist policyId)(prin_u:prin)(a:asset){struct prq} : Prop :=
  match prq with
    | TruePrq => True
    | Constraint const => trans_constraint x const IDs prin_u a
    | Requirement req => True (*trans_requirment x prq IDs prin_u a*)
    | Condition cond => True (*trans_condition x prq IDs prin_u a*)
    | AndPrqs prqs => True (*trans_andPrqs x prq IDs prin_u a*)
    | OrPrqs prqs => True (*trans_orPrqs x prq IDs prin_u a*)
    | XorPrqs prqs => True (*trans_xorPrqs x prq IDs prin_u a*)
  end

with trans_policy_positive
  (x:subject)(p:policy)(prin_u:prin)(a:asset){struct p} :=

let trans_p_list := (fix trans_p_list (x:subject)(p_list:nonemptylist policy)(prin_u:prin)(a:asset){struct p_list}:=
                  match p_list with
                    | Single p1 => trans_policy_positive x p1 prin_u a
                    | NewList p p_list' => ((trans_policy_positive x p prin_u a) /\ (trans_p_list x p_list' prin_u a))
                  end) in

  match p with
    | PrimitivePolicy prq policyId action => ((trans_preRequisite x prq (Single policyId) prin_u a) ->
                                              (Permitted x action a))
    | AndPolicy p_list => trans_p_list x p_list prin_u a
  end

with trans_policy_negative
  (x:subject)(p:policy)(a:asset){struct p} :=
let trans_p_list := (fix trans_p_list (x:subject)(p_list:nonemptylist policy)(a:asset){struct p_list}:=
                  match p_list with
                    | Single p1 => trans_policy_negative x p1 a
                    | NewList p p_list' => ((trans_policy_negative x p a) /\ (trans_p_list x p_list' a))
                  end) in

  match p with
    | PrimitivePolicy prq policyId action => not (Permitted x action a)
    | AndPolicy p_list => trans_p_list x p_list a
  end

(*
I had to define trans_ps_list as a 'let' inside of trans_ps otherwise I was getting the:
"Recursive call to trans_ps has principal argument equal to "ps1" instead of
a subterm of "ps_list"." error.

This solution was found here:
http://cs.stackexchange.com/questions/104/recursive-definitions-over-an-inductive-type-with-nested-components

*)
with trans_ps
  (x:subject)(ps:policySet)(prin_u:prin)(a:asset){struct ps} :=

let trans_ps_list := (fix trans_ps_list (x:subject)(ps_list:nonemptylist policySet)(prin_u:prin)(a:asset){struct ps_list}:=
                  match ps_list with
                    | Single ps1 => trans_ps x ps1 prin_u a
                    | NewList ps ps_list' => ((trans_ps x ps prin_u a) /\ (trans_ps_list x ps_list' prin_u a))
                  end) in
  match ps with
    | PrimitivePolicySet prq p => (((trans_prin x prin_u) /\
                                    (trans_preRequisite x prq (getIds p) prin_u a)) ->
                                   (trans_policy_positive x p prin_u a))
    | PrimitiveExclusivePolicySet prq p => ((((trans_prin x prin_u) /\
                                              (trans_preRequisite x prq (getIds p) prin_u a)) ->
                                             (trans_policy_positive x p prin_u a)) /\

                                            ((not (trans_prin x prin_u)) -> (trans_policy_negative x p a)))

    | AndPolicySet ps_list => trans_ps_list x ps_list prin_u a
  end.

Definition trans_agreement_aux :
  subject -> agreement -> Prop :=
    fun x a =>
      match a with
        | Agreement prin_u a ps => trans_ps x ps prin_u a
      end.

(* This is the top level translation function.  It calls the one above *)
Definition trans_agreement : agreement -> Prop :=
  fun a =>
    forall (x:subject), trans_agreement_aux x a.

End ODRL.


(* The First Logical Relations Proof: Measure Semantics vs. Sampler Semantics *)

Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.

Require Import LiftedTypes.
Require Import Weights.
Require Import MyReals.                   (* including times: Weight -> real -> real *)
Require Import Measures.
Require Import Types.                     (* including variables and environments *)

Require Import Syntax.

Require Import MeasureSemantics.
Require Import SamplingSemantics.

(* false_invert: tactic from SF *)
(* false_invert proves any goal provided there is at least one *)
(* hypothesis H in the context that can be proved absurd by calling *)
(* inversion H. *)

Ltac false_invert :=
  intros;
  match goal with
    [ H:_ |- _ ] => solve [ inversion H ]
  end.

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

Definition EqReal : (den_Mtype Real_type) ->
                    (den_Mtype Real_type) -> Prop :=
  fun v1 v2 => (v1 = v2).

Hint Unfold EqReal.

Function EqMtype (m : Mtype) : (den_typeM (Stype m))
                               -> (den_typeS (Stype m)) -> Prop
         :=
  match m with
  | Real_type => EqReal
  |Prod_type m1 m2 => fun v1 v2 => (EqMtype m1 (fst v1) (fst v2))
                        /\ (EqMtype m2 (snd v1) (snd v2))
  end.

Hint Unfold EqMtype.

Function coerceMS {m} (v: den_typeM (Stype m)) : (den_typeS (Stype m))
  := v.

Hint Unfold coerceMS.

Theorem EqMtype_coerce : forall (m : Mtype) (v: den_typeM (Stype m)),
    EqMtype m (@coerceMS m v) v.
Proof.
  induction m; auto.
  constructor.
  - apply IHm1.
  - apply IHm2.
Qed.

Theorem EqMtype_injective :
  forall (m : Mtype)  (v v': den_typeM (Stype m)),
    EqMtype m (@coerceMS m v) v' -> v = v'.
Proof.
  induction m; auto.
  destruct v, v'.
  inversion 1.
  f_equal; auto.
Qed.

Function lift_Rel {A B : Type} (R : (A -> B -> Prop)) :
  ((lifted A) -> (lifted B) -> Prop) :=
  fun d d' =>
    match (d, d') with
      | (bottom, bottom) => True
      | (lift u, lift u') => R u u'
      | _ => False
    end.
Hint Unfold lift_Rel.

(* Finally, here's the relation Rel itself, defined as a Fixpoint over
   Otypes.  *)

Fixpoint Rel (t : Otype) : (den_typeM t) -> (den_typeS t) -> Prop :=
  match t with
  | Stype m => EqMtype m
  | Funtype t u => (fun f1 f2 =>
                      forall a1 a2,
                        (Rel t a1 a2)
                        -> (lift_Rel (Rel u) (f1 a1) (f2 a2)))
  | Meastype t => (fun mu s =>
                     forall k,
                       mu k =
                       mu_L (fun u => (strict20 (s u)
                                                (fun a w => (times w (k a))))))
  end.
Hint Unfold Rel.

Definition den_envM := @den_env den_typeM.
Definition den_envS := @den_env den_typeS.

Fixpoint Rel_Env G : (den_envM G) -> (den_envS G)
                     -> Prop :=
  match G with
    | nil => fun r1 r2 => True
    | (o :: G') => fun r1 r2 =>
                     Rel o (fst r1) (fst r2)
                     /\ Rel_Env G' (snd r1) (snd r2)
  end.
Hint Unfold Rel_Env.

Lemma Fund_Env : forall G (o : Otype)
                        (var : Var G o)
                        (r1 : den_envM G)
                        (r2 : den_envS G),
                   Rel_Env G r1 r2 ->
                   Rel o (env_lookup var r1) (env_lookup var r2).
Proof.
  induction G as [| o' G'];
    try false_invert.
  (* G = o':: G' *)
  induction var as [| G'' ? ? ? IHvar ];
    inversion 1; auto.
  apply IHvar.
  auto.
Qed.

Lemma lookup_preserves_Rel : forall G (o : Otype)
                       (var : Var G o)
                       (r : den_envM G)
                       (s : den_envS G),
    Rel_Env G r s -> Rel o (apply_env r var) (apply_env s var).
Proof.
  induction G; try false_invert.
  (* G = o' :: G' *)
  induction var.
  - (* var = var_0 *)
    inversion 1.
    auto.
  - (* var = var_S v' *)
    intros.
    apply IHvar.
    apply H.
Qed.

Lemma extend_env_preserves_Rel :
  forall G o r1 r2 val1 val2,
    Rel_Env G r1 r2 -> Rel o val1 val2 -> Rel_Env (o::G) (val1,r1) (val2,r2).
Proof.
  auto.
Qed.

Theorem Rel_strict2 : forall o1 o2 o3 d1 d1' d2 d2' f f',
    lift_Rel (Rel o1) d1 d1' ->
    lift_Rel (Rel o2) d2 d2' ->
    (forall v1 v1' v2 v2',
        Rel o1 v1 v1' -> Rel o2 v2 v2' -> lift_Rel (Rel o3) (f v1 v2) (f' v1' v2'))
    -> lift_Rel (Rel o3) (strict2 d1 d2 f) (strict2 d1' d2' f').
Proof.
  destruct d1, d1', d2, d2'; try false_invert; eauto.
Qed.

Theorem Rel_Return : forall m (v : den_typeS (Stype m)),
    Rel _ (returnopM v) (returnopS v).
Proof.
  autounfold; simpl.
  symmetry.
  auto using mu_L_const, times_one_weight.
Qed.

Theorem Rel_Uniform : Rel _ uniformopM uniformopS.
Proof.
  autounfold; simpl.
  auto using mu_L_extensional, times_one_weight.
Qed.

Lemma RelMeas_Lemma1 :
  forall (m : Mtype)
         (mu : (lifted (den_typeM (Meastype m))))
         (s  : (lifted (den_typeS (Meastype m))))
         k,
    lift_Rel (Rel (Meastype m)) mu s ->
    strict0 mu (fun mu' => (mu' k))
    = strict0 s (fun s' =>
                   (mu_L (fun u =>
                            strict20 (s' u) (fun b w =>
                                               (times w (k b)))))).
Proof.
  destruct mu, s;
    try false_invert;
    eauto.
Qed.

Lemma split_entropy_sampler : forall
    (o o' : Mtype)
    (mu : den_typeM (Meastype o))
    (s : den_typeS (Meastype o))
    (f : den_typeM (Stype o) -> lifted (den_typeM (Meastype o')))
    (f' : den_typeM (Stype o) -> lifted (den_typeS (Meastype o')))
    (k : den_Mtype o' -> real)
    (H0 : forall a : den_typeM (Stype o),
        lift_Rel (Rel (Meastype o')) (f a) (f' a)),

    mu_L (fun u =>
            (strict20 (s (left_half u))
                     (fun a w1 =>
                        (strict0 (f' a)
                                 (fun s2 =>
                                    (strict20 (s2 (right_half u))
                                              (fun b w2 =>
                                                 (times (prod_weights w1 w2)
                                                        (k b)))))))))
    =
    mu_L (fun u => (strict20 (s u)
                             (fun a w2 =>
                                (times w2
                                       (strict0 (f a)
                                                (fun mu' => mu' k)))))).
Proof.
  intros.
  rewrite <- (split_entropy
                (fun lu ru =>
                   strict20 (s lu)
                            (fun a w =>
                               (strict0 (f' a)
                                        (fun s2 =>
                                                 (strict20 (s2 ru) _)))))).
  apply mu_L_extensional; intro u.
  rewrite strict20_mu_L.
  f_equal.
  extensionality x.
  extensionality w.
  erewrite RelMeas_Lemma1 by auto. (* H0 is used here *)
  rewrite strict0_linear.
  rewrite strict0_mu_L.
  f_equal.
  extensionality x0.
  rewrite <- mu_L_linear.
  f_equal.
  extensionality u0.
  rewrite strict20_linear.
  f_equal.
  extensionality a.
  extensionality b.
  rewrite times_assoc.
  auto.
Qed.

Theorem Rel_bindop : forall (o o': Mtype) mu s
                            f f',
    Rel _ mu s ->
    (forall a, lift_Rel (Rel (Meastype o')) (f a) (f' a)) ->
    Rel _ (@bindopM o o' mu f) (@bindopS o o' s f').
Proof.
  intros.
  autounfold.
  intros.
  rewrite H; clear H.
  erewrite <- split_entropy_sampler; auto.
  f_equal; extensionality u.
  rewrite strict20_strict2.
  f_equal. extensionality a. extensionality w.
  rewrite strict20_strict.
  f_equal. extensionality x.
  rewrite strict20_strict2.
  f_equal.
Qed.

Theorem Rel_distval : forall p, Rel (Meastype Real_type) (mu_1 p) (distvalS p).
Proof.
  intros.
  simpl.
  intros.
  rewrite mu_1_density_1.
  auto.
Qed.

Definition Fun_Thm_Exp G o  (exp: Exp G o) :=
  forall
         (r : den_envM G)
         (s : den_envS G),
    Rel_Env G r s
    -> lift_Rel (@Rel o) (den_expM exp r) (den_expS exp s).
Hint Unfold Fun_Thm_Exp.

Definition Fun_Thm_Val G o  (val: Val G o) :=
  forall
         (r : den_envM G)
         (s : den_envS G),
    Rel_Env G r s
    -> Rel o (den_valM val r) (den_valS val s).
Hint Unfold Fun_Thm_Val.

Theorem Fund_Thm: forall G o exp, @Fun_Thm_Exp G o exp.
Proof.
  apply (exp_val_rec Fun_Thm_Exp Fun_Thm_Val);
    unfold Fun_Thm_Exp, Fun_Thm_Val;
    intros; simpl;
      eauto using lookup_preserves_Rel, extend_env_preserves_Rel,
      Rel_strict2, Rel_Return, Rel_Uniform, Rel_bindop,
    times_one_weight, mu_L_extensional, mu_1_density_1.

  (* prodexp *)
  - specialize (H r s H1).
    specialize (H0 r s H1).
     destruct (den_expM e r), (den_expS e s), (den_expM e0 r), (den_expS e0 s);
      try false_invert;
      eauto using H, H0.
     simpl.
     unfold lift_Rel.
     auto.

  (* proj1exp *)
  - specialize (H r s H0).
    destruct (den_expM e r), (den_expS e s); try false_invert; auto.
    simpl.
    unfold lift_Rel.
    unfold lift_Rel in H.
    unfold Rel in H.
    apply H.

      (* proj2exp *)
  - specialize (H r s H0).
    destruct (den_expM e r), (den_expS e s); try false_invert; auto.
    simpl.
    unfold lift_Rel.
    unfold lift_Rel in H.
    unfold Rel in H.
    apply H.

  (* appexp *)
  - specialize (H r s H1).
    specialize (H0 r s H1).
    destruct (den_expM e r), (den_expS e s), (den_expM e0 r), (den_expS e0 s);
      try false_invert;
      eauto using H, H0.

  (* appexp *)
  - specialize (H r s H1).
    specialize (H0 r s H1).
    destruct (den_expM e r), (den_expS e s), (den_expM e0 r), (den_expS e0 s);
      try false_invert;
      auto.
    apply Rel_bindop; auto.
    intros.
    apply H0.
    apply EqMtype_coerce.

  (* returnexp *)
  - specialize (H r s H0).
    destruct (den_expM e r), (den_expS e s);
      try false_invert;
      auto.
    apply EqMtype_injective in H; subst.
    apply Rel_Return.

  (* prodval *)
  - specialize (H r s H1).
    specialize (H0 r s H1).
    auto.

  (* distval *)
  - specialize (H r s H0).
    intros.
    rewrite H.
    apply Rel_distval.

  (* bindval *)
  - apply Rel_bindop; auto.
    intros.
    apply H0; auto.
    apply EqMtype_coerce.

  (* returnval *)
  - eapply EqMtype_injective in H; eauto.
    rewrite H.
    apply Rel_Return.
Qed.


(*===========================================================================
    Model for x86 flags
  ===========================================================================*)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat tuple.
Require Import bitsrep bitsops update.
Local Open Scope update_scope.

(* Represent a flag finitely! *)
(*=Flag *)
Definition Flag  := BITS 5.
Definition CF: Flag := #0. Definition PF: Flag := #2.
Definition ZF: Flag := #6. Definition SF: Flag := #7.
Definition OF: Flag := #11.
(*=End *)

(* Some instructions leave the state of certain flags "unspecified" *)
(*=FlagVal *)
Inductive FlagVal := mkFlag (b: bool) | FlagUnspecified.
Coercion mkFlag : bool >-> FlagVal.
(*=End *)

(* State of the flags *)
(* Lookup is just function application *)
(*=FlagState *)
Definition FlagState := Flag -> FlagVal.
(*=End *)

Instance FlagStateUpdateOps : UpdateOps FlagState Flag FlagVal :=
  fun fs f v => fun f' => if f == f' then v else fs f'.

Lemma setFlagThenGetDistinct (f1:BITS 5) (v:FlagVal) (f2:BITS 5) (fs: FlagState) :
  ~~ (f1 == f2) -> (fs !f1:=v) f2 = fs f2.
Proof. move => neq. rewrite /update /FlagStateUpdateOps. by rewrite (negbTE neq). Qed.

Lemma setFlagThenGetSame f v fs : (fs !f:=v) f = v.
Proof. rewrite /update /FlagStateUpdateOps.
by rewrite (introT (eqP) (refl_equal _)).
Qed.

Require Import FunctionalExtensionality.

Instance FlagStateUpdate : Update FlagState Flag FlagVal.
apply Build_Update.
(* Same flag *)
move => fs f v w. rewrite /update /FlagStateUpdateOps.
apply functional_extensionality => f'. by case: (f == f').
(* Different flag *)
move => fs f1 f2 v1 v2 neq. rewrite /update /FlagStateUpdateOps.
apply functional_extensionality => f.
case E1: (f2 == f) => //.
case E2: (f1 == f) => //. rewrite (elimT (eqP) E1) in neq.
by rewrite (elimT (eqP) E2) in neq.
Qed.

Definition noFlags : FlagState := fun _ => FlagUnspecified.

Definition getFlag (flags: FlagState) (f: Flag) := flags f.
Coercion getFlag : FlagState >-> Funclass.

Open Scope update_scope.
Definition updateFlag (flags: FlagState) (f: Flag) (b:FlagVal) := flags ! f := b.
Definition forgetFlag (flags: FlagState) (f: Flag) := flags !f := FlagUnspecified.

Definition initialFlagState :=
  noFlags
  ! CF := mkFlag false
  ! PF := mkFlag false
  ! ZF := mkFlag false
  ! SF := mkFlag false
  ! OF := mkFlag false.

Require Import Coq.Strings.String.
Definition showFlag s res := (if res is mkFlag f then (if f then s else ".") else "?")%string.
Definition flagsToString (f:FlagState) :=
  (showFlag "C" (f CF) ++
   showFlag "P" (f PF) ++
   showFlag "Z" (f ZF) ++
   showFlag "S" (f SF) ++
   showFlag "O" (f OF))%string.


Set Implicit Arguments.
Require Import List.
Opaque plus. (* avoid pesky reductions *)
Require Import DblibTactics.
Require Import DeBruijn.

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

(* Environments map variables to data. *)

(* Environments are homogeneous -- there is only one kind of variables --
   and non-dependent -- variables do not occur within data. *)

(* What should be the type of an environment? Multiple answers come to mind,
   such as [list A], [nat -> option A], [list (option A)], etc. The choice of
   a definition is guided by the desire that [lookup] and [insert] be total
   functions that satisfy a number of natural laws. In particular, if [insert]
   is a total function, then we cannot expect the domain of an environment to
   be contiguous. This rules out [list A]. Representing an environment by its
   lookup function, of type [nat -> option A], works, but does not allow
   defining [fold] over environments. In the end, representing an environment
   by a finite list of possibly-null entries seems to be a reasonable
   choice. *)

Definition env A :=
  list (option A).

(* What notion of equality over environments do we need? Extensional equality
   of the [lookup] functions seems to be the most natural notion. The
   predicate [agree], defined below, is a bounded version of this
   notion. Perhaps by chance, the basic laws that relate [lookup], [insert],
   and [map] are valid with respect to Leibniz equality, so we do not define
   extensional equality. *)

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

(* Operations on environments. *)

(* The empty environment is undefined everywhere. *)

Definition empty A : env A :=
  nil.

(* Environment lookup. *)

Fixpoint lookup A (x : nat) (e : env A) : option A :=
  match e, x with
  | nil, _ =>
      None
  | entry :: _, 0 =>
      entry
  | _ :: e, S x =>
      lookup x e
  end.

(* [insert x a e] inserts a new variable [x], associated with data [a], in the
   environment [e]. The pre-existing environment entries at index [x] and
   above are shifted up. Thus, [insert x] is closely analogous to [shift x]
   for terms. *)

(* [insert] inserts a non-null entry in the environment. We define it in terms
   of [raw_insert], which can also be used to insert a null entry. [raw_insert]
   is useful because it allows generating every environment (thus, it can be
   used in the formulation of an induction principle). *)

Fixpoint raw_insert A (x : nat) (o : option A) (e : env A) : env A :=
  match x, e with
  | 0, _ =>
      o :: e
  | S x, entry :: e =>
      entry :: raw_insert x o e
  | S x, nil =>
      None :: raw_insert x o e
  end.

Notation insert x a e :=
  (raw_insert x (Some a) e).

(* [map f e] is the environment obtained by applying [f] to every datum
   in the environment [e]. *)

Fixpoint map A B (f : A -> B) (e : env A) :=
  match e with
  | nil =>
      nil
  | None :: e =>
      None :: map f e
  | Some a :: e =>
      Some (f a) :: map f e
  end.

(* [fold f e accu] performs an iteration over all entries in the environment.
   Older entries are visited first: in other words, the initial accumulator
   should make sense at the toplevel, outside of the environment, and is
   pushed successively into every binding, so as to yield a final accumulator
   that makes sense inside this environment. *)

Fixpoint fold A B (f : option A -> B -> B) (e : env A) (accu : B) : B :=
  match e with
  | nil =>
      accu
  | o :: e =>
      f o (fold f e accu)
  end.

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

(* Basic arithmetic simplifications. *)

Lemma one_plus_x_minus_one_left:
  forall x,
  (1 + x) - 1 = x.
Proof.
  intros. omega.
Qed.

Lemma one_plus_x_minus_one_right:
  forall x,
  x > 0 ->
  1 + (x - 1) = x.
Proof.
  intros. omega.
Qed.

Ltac one_plus_x_minus_one :=
  repeat rewrite one_plus_x_minus_one_left in *;
  repeat rewrite one_plus_x_minus_one_right in * by omega.
  (* I tried [autorewrite with ... using omega]; it does not work. *)

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

(* Trivial facts. *)

Lemma raw_insert_zero:
  forall A o (e : env A),
  raw_insert 0 o e = o :: e.
Proof.
  reflexivity.
Qed.

Lemma raw_insert_successor:
  forall A x o (e : env A),
  raw_insert (S x) o e =
  lookup 0 e :: raw_insert x o (tail e).
Proof.
  intros. destruct e; reflexivity. (* ! *)
Qed. (* Maybe this should be the definition of [raw_insert]. *)

Lemma empty_eq_insert:
  forall A x o (e : env A),
  empty _ = insert x o e ->
  False.
Proof.
  unfold empty; intros; destruct x.
  rewrite raw_insert_zero in *. congruence.
  rewrite raw_insert_successor in *. congruence.
Qed.

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

(* Interaction between [lookup] and [empty]. *)

Lemma lookup_empty_None:
  forall A x,
  lookup x (@empty A) = None.
Proof.
  destruct x; simpl; reflexivity.
Qed.

Lemma lookup_empty_Some:
  forall A x (a : A),
  lookup x (@empty _) = Some a ->
  False.
Proof.
  destruct x; simpl; congruence.
Qed.

Lemma lookup_successor:
  forall A x (e : env A),
  lookup (S x) e = lookup x (tail e).
Proof.
  destruct e.
  do 2 rewrite lookup_empty_None. reflexivity.
  reflexivity.
Qed.

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

(* Interaction between [lookup] and [insert]. *)

Lemma lookup_insert_bingo:
  forall A x y (o : option A) e,
  x = y ->
  lookup x (raw_insert y o e) = o.
(* Hence, [lookup x (insert y a e) = Some a]. *)
Proof.
  induction x; intros; destruct y; destruct e; simpl; try solve [
    elimtype False; omega
  | eauto with omega
  ].
Qed.

Lemma lookup_insert_recent:
  forall A x y (o : option A) e,
  x < y ->
  lookup x (raw_insert y o e) = lookup x e.
(* Hence, [lookup x (insert y a e) = lookup x e]. *)
Proof.
  induction x; intros; destruct y; destruct e; simpl; try solve [
    elimtype False; omega
  | eauto with omega
  ].
  (* One troublesome case. *)
  erewrite <- lookup_empty_None. eauto with omega.
Qed.

Lemma lookup_insert_old:
  forall A x y (o : option A) e,
  x > y ->
  lookup x (raw_insert y o e) = lookup (x - 1) e.
(* Hence, [lookup x (insert y a e) = lookup (x - 1) e]. *)
Proof.
  (* Induction over [x], which is non-zero. *)
  induction x; intros; [ elimtype False; omega | replace (S x - 1) with x by omega ].
  (* Case analysis. *)
  destruct y; destruct e; simpl; try solve [ eauto ].
  (* One troublesome case. *)
  rewrite lookup_empty_None. erewrite <- lookup_empty_None. eauto with omega.
  (* Another troublesome case. *)
  destruct x; intros; [ elimtype False; omega | replace (S x - 1) with x in * by omega ].
  simpl lookup at 2.
  eauto with omega.
Qed.

Lemma lookup_shift_insert:
  forall A x y (o : option A) e,
  lookup (shift y x) (raw_insert y o e) = lookup x e.
(* Hence, [lookup (shift y x) (insert y a e) = lookup x e]. *)
Proof.
  intros. destruct_lift_idx.
  rewrite lookup_insert_old by omega. f_equal. omega.
  rewrite lookup_insert_recent by omega. reflexivity.
Qed.

Ltac lookup_insert :=
  first [
    rewrite lookup_insert_bingo by omega
  | rewrite lookup_insert_old by omega; one_plus_x_minus_one
  | rewrite lookup_insert_recent by omega
  | rewrite lookup_shift_insert
  ].

Ltac lookup_insert_all :=
  first [
    rewrite lookup_insert_bingo in * by omega;
    try match goal with h: Some _ = Some _ |- _ => injection h; intro; subst; clear h end
  | rewrite lookup_insert_old in * by omega; one_plus_x_minus_one
  | rewrite lookup_insert_recent in * by omega
  | rewrite lookup_shift_insert in *
  ].

Hint Extern 1 (lookup _ (raw_insert _ _ _) = _) =>
  lookup_insert
: lookup_insert.

Hint Extern 1 (lookup _ _ = _) =>
  lookup_insert_all
: lookup_insert.

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

(* Interaction between [map] and [empty]. *)

Lemma map_empty:
  forall A B (f : A -> B),
  map f (@empty _) = @empty _.
Proof.
  reflexivity.
Qed.

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

(* Interaction between [lookup] and [map]. *)

Lemma lookup_map_none:
  forall A B x e (f : A -> B),
  lookup x e = None ->
  lookup x (map f e) = None.
Proof.
  induction x; intros; destruct e as [ | [ | ] ? ]; simpl in *; subst;
  solve [ eauto | congruence ].
Qed.

Lemma lookup_map_some:
  forall A B x a e (f : A -> B),
  lookup x e = Some a ->
  lookup x (map f e) = Some (f a).
Proof.
  induction x; intros; destruct e as [ | [ | ] ? ]; simpl in *; subst; try solve [
    congruence
  | eauto
  ].
Qed.

Lemma lookup_map_some_reverse:
  forall A B x b e (f : A -> B),
  lookup x (map f e) = Some b ->
  exists a,
  lookup x e = Some a /\ b = f a.
Proof.
  induction x; intros; destruct e as [ | [ | ] ? ]; simpl in *; subst; try solve [
    congruence
  | eauto
  ].
  eexists. split. reflexivity. congruence.
Qed.

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

(* [insert] commutes with itself, just like [lift] commutes with itself. *)

Lemma insert_insert:
  forall A k s (a b : option A) e,
  k <= s ->
  raw_insert k a (raw_insert s b e) = raw_insert (1 + s) b (raw_insert k a e).
Proof.
  intros ? k s. generalize s k; clear s k. induction s; intros.
  (* Case [s = 0]. *)
  destruct k; [ | elimtype False; omega ]. reflexivity.
  (* Case [s > 0]. *)
  destruct k.
  (* Sub-case [k = 0]. *)
  reflexivity.
  (* Sub-case [k > 0]. *)
  destruct e; replace (1 + S s) with (S (1 + s)) by omega; simpl; f_equal; eauto with omega.
Qed.

(* Even when it is not known which of [k] and [s] is greater, [insert] commutes
   with itself. The formula is slightly horrid, but can be very useful. *)

Lemma insert_insert_always:
  forall A k s (a b : option A) e,
  raw_insert k a (raw_insert s b e) =
  raw_insert (shift k s) b (raw_insert (if le_gt_dec k s then k else k - 1) a e).
Proof.
  intros.
  destruct (le_gt_dec k s).
  rewrite lift_idx_old by assumption. eauto using insert_insert.
  rewrite lift_idx_recent by assumption.
  replace k with (1 + (k - 1)) in * by omega. rewrite <- insert_insert by omega.
  do 2 f_equal. omega.
Qed.

(* Attempting to rewrite in both directions may seem redundant, because of the
   symmetry of the law [insert_insert]. It is not: because [omega] fails in
   the presence of meta-variables, rewriting in one direction may be possible
   while the other direction fails. *)

Ltac insert_insert :=
  first [
    rewrite    insert_insert; [ reflexivity | omega ]
  | rewrite <- insert_insert; [ reflexivity | omega ]
  ].

Hint Extern 1 (raw_insert _ _ _ = _) =>
  insert_insert
: insert_insert.

Hint Extern 1 (_ = raw_insert _ _ _) =>
  insert_insert
: insert_insert.

(* The result of an insertion cannot be nil. *)

Lemma insert_nil:
  forall A x a (e : env A),
  insert x a e = nil ->
  False.
Proof.
  destruct x; destruct e; simpl; congruence.
Qed.

(* Two lemmas about equations of the form [insert x a1 e1 = insert x a2 e2].
   Note that we have [a1 = a2], but not [e1 = e2], due to padding. *)

Lemma insert_eq_insert_1:
  forall A x a1 a2 (e1 e2 : env A),
  insert x a1 e1 = insert x a2 e2 ->
  a1 = a2.
Proof.
  intros.
  assert (lookup x (insert x a1 e1) = Some a1). eauto using lookup_insert_bingo.
  assert (lookup x (insert x a2 e2) = Some a2). eauto using lookup_insert_bingo.
  congruence.
Qed.

Lemma insert_eq_insert_2:
  forall A x a1 a2 (e1 e2 : env A),
  insert x a1 e1 = insert x a2 e2 ->
  forall b,
  insert x b e1 = insert x b e2.
Proof.
  induction x; simpl; intros.
  congruence.
  destruct e1; destruct e2;
  match goal with h: _ = _ |- _ => injection h; clear h; intros end;
  f_equal; try congruence; eauto.
Qed.

(* This is a really crazy diamond lemma that says, roughly, if the equation
    [insert x1 a1 e1 = insert x2 a2 e2] holds, then [e1] and [e2] can be
    constructed out of a common environment [e]. We would like to conclude
    [e1 = insert x2 a2 e /\ e2 = insert x1 a1 e], but this is false, because
    one of the indices is off-by-one in one way or the other. We need to
    adjust, and the arithmetic is a bit painful. *)

Lemma insert_eq_insert_3:
  forall A x1 x2 a1 a2 (e1 e2 : env A),
  insert x1 a1 e1 = insert x2 a2 e2 ->
  x1 <> x2 ->
  exists e y1 y2,
  e1 = insert y1 a2 e /\
  e2 = insert y2 a1 e /\
  shift x1 y1 = x2 /\
  y2 = (if le_gt_dec x1 y1 then x1 else x1 - 1).
Proof.
  induction x1; intros.
  (* Case [x1 = 0]. *)
  destruct x2; [ omega | ].
  rewrite raw_insert_zero in *. rewrite raw_insert_successor in *.
  match goal with h: _ = _ |- _ =>
    injection h; clear h; intros
  end.
  destruct e2; [ congruence | ]. subst. simpl.
  exists e2. exists x2. exists 0. eauto.
  (* Case [x1 > 0]. *)
  destruct x2.
  (* Sub-case [x2 = 0]. *)
  rewrite raw_insert_zero in *. rewrite raw_insert_successor in *.
  match goal with h: _ = _ |- _ =>
    injection h; clear h; intros
  end.
  destruct e1; [ congruence | ]. subst.
  exists e1. exists 0. exists x1.
  split. eauto.
  split. eauto.
  split. eauto.
  dblib_by_cases. omega.
  (* Sub-case [x2 > 0]. *)
  do 2 rewrite raw_insert_successor in *.
  assert (xx: x1 <> x2). omega.
  match goal with h: _ = _ |- _ =>
    injection h; clear h; intros h ?;
    generalize (IHx1 _ _ _ _ _ h xx); intros [ e [ y1 [ y2 [ ? [ ? [ ? ? ]]]]]]
  end.
  (* [e1] and [e2] must be non-nil. *)
  destruct e1; simpl tl in *; [ elimtype False; eauto using insert_nil | ].
  destruct e2; simpl tl in *; [ elimtype False; eauto using insert_nil | ].
  exists (o :: e). exists (S y1). exists (S y2).
  split. simpl. congruence.
  split. simpl. congruence.
  split. eapply translate_lift with (k := 1). eauto.
  dblib_by_cases; omega.
Qed.

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

(* Interaction between [map] and [insert]. *)

Lemma map_insert:
  forall A B (f : A -> B) x a e,
  map f (insert x a e) = insert x (f a) (map f e).
Proof.
  induction x; intros; destruct e; simpl; eauto.
  rewrite IHx. reflexivity.
  match goal with o: option _ |- _ => destruct o end; f_equal; eauto.
Qed.

(* The following variant is easier to use for [eauto]. *)

Lemma map_insert_eq:
  forall A B (f : A -> B) x a b e,
  f a = b ->
  map f (insert x a e) = insert x b (map f e).
Proof.
  intros; subst. eapply map_insert.
Qed.

Ltac map_insert :=
  first [
    rewrite map_insert; reflexivity
  | rewrite <- map_insert; reflexivity
  ].

Hint Extern 1 (map _ (insert _ _ _) = insert _ _ (map _ _)) =>
  map_insert
: map_insert.

Hint Extern 1 (insert _ _ (map _ _) = map _ (insert _ _ _)) =>
  map_insert
: map_insert.

Lemma map_raw_insert:
  forall A B (f : A -> B) x e,
  map f (raw_insert x None e) = raw_insert x None (map f e).
Proof.
  induction x; intros; destruct e; simpl; eauto.
  rewrite IHx. reflexivity.
  match goal with o: option _ |- _ => destruct o end; f_equal; eauto.
Qed.

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

(* [map] composes with itself. *)

Lemma map_map_fuse:
  forall A B C (f : B -> C) (g : A -> B) h e,
  (forall (d : A), f (g d) = h d) ->
  map f (map g e) = map h e.
Proof.
  induction e; intros;
  try match goal with o: option _ |- _ => destruct o end;
  simpl; eauto with f_equal.
Qed.

Lemma map_map_exchange:
  forall A F G B (f1 : F -> B) (f2 : A -> F) (g1 : G -> B) (g2 : A -> G) e,
  (forall (d : A), f1 (f2 d) = g1 (g2 d)) ->
  map f1 (map f2 e) = map g1 (map g2 e).
Proof.
  induction e; intros;
  try match goal with o: option _ |- _ => destruct o end;
  simpl; eauto with f_equal.
Qed.

Lemma map_lift_map_lift:
  forall T k s wk ws (e : env T),
  forall `{Lift T},
  @LiftLift T _ ->
  k <= s ->
  map (lift wk k) (map (lift ws s) e) = map (lift ws (wk + s)) (map (lift wk k) e).
Proof.
  eauto using map_map_exchange, @lift_lift.
Qed.

Lemma map_insert_map:
  forall A (f g h : A -> A) x (a : A) e,
  (forall a, f (g a) = g (h a)) ->
  map f (insert x a (map g e)) =
  insert x (f a) (map g (map h e)).
Proof.
  intros.
  rewrite map_insert. f_equal.
  eapply map_map_exchange.
  eauto.
Qed.

Lemma map_map_vanish:
  forall A B (f : B -> A) (g : A -> B) (e : env A),
  (forall x, f (g x) = x) ->
  map f (map g e) = e.
Proof.
  induction e; intros;
  try match goal with o: option _ |- _ => destruct o end;
  simpl; eauto with f_equal.
Qed.

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

(* Properties of [fold]. *)

(* Interaction between [fold] and [empty]. *)

Lemma fold_empty:
  forall A B (f : option A -> B -> B) accu,
  fold f (@empty _) accu = accu.
Proof.
  reflexivity.
Qed.

(* Interaction between [fold] and [insert]. *)

Lemma fold_insert:
  forall A B (f : option A -> B -> B) o e accu,
  fold f (raw_insert 0 o e) accu = f o (fold f e accu).
Proof.
  reflexivity.
Qed.

(* An induction principle. In order to prove that a property [P] holds of
   [fold f e accu], it suffices to hold that it holds of the initial
   accumulator and that it is preserved by one iteration. The statement is
   expressed in terms of [empty] and [raw_insert], so the fact that
   environments are implemented as lists is not exposed. *)

Lemma fold_invariant:
  forall A B (P : env A -> B -> Prop) f accu,
  P (@empty _) accu ->
  (forall o e accu, P e accu -> P (raw_insert 0 o e) (f o accu)) ->
  forall e,
  P e (fold f e accu).
Proof.
  intros ? ? ? ? ? init step.
  induction e; simpl.
  eapply init.
  eapply step. eauto.
Qed.

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

(* [length e] should be viewed as an upper bound on the true length of the
   environment [e], since there may be useless [None] entries at the end.
   We are careful to always work with hypotheses and goals of the form
   [length e <= k]. *)

Lemma length_monotonic:
  forall A (e : env A) k1 k2,
  length e <= k1 ->
  k1 <= k2 ->
  length e <= k2.
Proof.
  intros. omega.
Qed.

Lemma lookup_beyond_length:
  forall A (e : env A) x,
  length e <= x ->
  lookup x e = None.
Proof.
  induction e; simpl; intros.
  eapply lookup_empty_None.
  destruct x; [ omega | ]. simpl. eapply IHe. omega.
Qed.

(* Every variable that is defined in the environment is less than the
   length of the environment. *)

Lemma defined_implies_below_length:
  forall A (e : env A) x k a,
  length e <= k ->
  lookup x e = Some a ->
  x < k.
Proof.
  intros.
  (* If [x < k] holds, the result is immediate. Consider the other case,
     [k <= x]. *)
  case (le_gt_dec k x); intro; try tauto.
  (* By definition of [length], [lookup x e] is [None]. *)
  assert (lookup x e = None). eapply lookup_beyond_length. omega.
  (* We obtain a contradiction. *)
  congruence.
Qed.

Hint Resolve defined_implies_below_length : lift_idx_hints.

(* The empty environment has zero length. *)

Lemma length_empty:
  forall A k,
  length (@empty A) <= k.
Proof.
  simpl. intros. omega.
Qed.

(* This definition of [max] is much more pleasant to work with than the
   one found in Coq's standard library. It can be easily unfolded, and
   then [omega] takes control. *)

Definition mymax m n :=
  if le_gt_dec m n then n else m.

Ltac mymax :=
  unfold mymax in *; dblib_by_cases; try omega.

Lemma mymax_l:
  forall i j, mymax i j >= i.
Proof.
  intros. mymax.
Qed.

Lemma mymax_r:
  forall i j, mymax i j >= j.
Proof.
  intros. mymax.
Qed.

Hint Resolve mymax_l mymax_r : mymax.

(* Extending an environment increments its length by one, in the usual case.
   It can be extended by more than one if [x] is far away. *)

Lemma length_insert_general:
  forall A x k o (e : env A),
  length e = k ->
  length (raw_insert x o e) = mymax (1 + k) (1 + x).
Proof.
  induction x; simpl; intros; subst.
  mymax.
  destruct e; simpl.
  mymax. erewrite IHx by reflexivity. simpl. mymax.
  erewrite IHx by reflexivity. mymax.
Qed.

(* This should be the usual case. *)

Lemma length_insert:
  forall A x k km1 o (e : env A),
  length e <= km1 ->
  km1 <= k - 1 ->
  x < k ->
  length (raw_insert x o e) <= k.
Proof.
  intros. erewrite length_insert_general by reflexivity. mymax.
Qed.

(* Pain, pain. *)

Lemma length_insert_reverse_1:
  forall A (e : env A) k x a,
  length (insert x a e) <= k ->
  x < k.
Proof.
  intros. erewrite length_insert_general in * by reflexivity. mymax.
Qed.

Lemma length_insert_reverse_2:
  forall A (e : env A) k x a,
  length (insert x a e) <= k + 1 ->
  length e <= k.
Proof.
  intros. erewrite length_insert_general in * by reflexivity. mymax.
Qed.

Lemma length_insert_independent:
  forall A (e : env A) k x a,
  length (insert x a e) <= k ->
  forall y o,
  y < k ->
  length (raw_insert y o e) <= k.
Proof.
  intros. erewrite length_insert_general in * by reflexivity. mymax.
Qed.

(* Applying a transformation to an environment does not affect its length. *)

Lemma length_map_general:
  forall A B (f : A -> B) (e : env A),
  length (map f e) = length e.
Proof.
  induction e as [| [|] ]; simpl; intros; congruence.
Qed.

Lemma length_map:
  forall A B (f : A -> B) (e : env A) k,
  length e <= k ->
  length (map f e) <= k.
Proof.
  intros. rewrite length_map_general. assumption.
Qed.

Hint Resolve length_empty length_insert length_map : length.

Hint Resolve length_insert length_map : construction_closed.

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

(* The definitions and properties that follow should be independent of the
   details of the definitions of [empty], [lookup], [insert], and [map]. *)

Opaque empty lookup raw_insert map.

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

(* A definition of when two environments agree up to length [k]. *)

Definition agree A (e1 e2 : env A) (k : nat) :=
  forall x,
  x < k ->
  lookup x e1 = lookup x e2.

(* A simple consequence of the definition. *)

Lemma agree_below:
  forall A (e1 e2 : env A) x a k,
  lookup x e1 = Some a ->
  x < k ->
  agree e1 e2 k ->
  lookup x e2 = Some a.
Proof.
  do 6 intro. intros hlookup ? ?.
  rewrite <- hlookup. symmetry.
  eauto.
Qed.

(* The empty environment agrees with every environment up to length [0]. *)

Lemma agree_empty_left:
  forall A (e : env A),
  agree (@empty _) e 0.
Proof.
  unfold agree. intros. elimtype False. omega.
Qed.

Lemma agree_empty_right:
  forall A (e : env A),
  agree e (@empty _) 0.
Proof.
  unfold agree. intros. elimtype False. omega.
Qed.

(* If two environments that agree up to [k] are extended with a new variable,
   then they agree up to [k+1]. *)

Lemma agree_insert:
  forall A (e1 e2 : env A) k,
  agree e1 e2 k ->
  forall x o,
  x <= k ->
  agree (raw_insert x o e1) (raw_insert x o e2) (1 + k).
Proof.
  unfold agree. do 8 intro. intros n ?.
  (* Reason by cases: [x = n], [x < n], [x > n]. *)
  case (le_gt_dec x n); [ case (eq_nat_dec x n) | ]; intros;
  (* In each case, [lookup_insert] simplifies the goal. *)
  do 2 lookup_insert; eauto with omega.
Qed.

Hint Resolve defined_implies_below_length agree_below agree_empty_left
agree_empty_right agree_insert : agree.

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

(* A definition of when an environment subsumes another, up to a notion of
   subsumption on environment entries. *)

Section Subsume.

  Variable A : Type.

  Variable sub : A -> A -> Prop.

  Variable sub_reflexive:
    forall a,
    sub a a.

  Variable sub_transitive:
    forall a1 a2 a3,
    sub a1 a2 ->
    sub a2 a3 ->
    sub a1 a3.

  (* Subsumption is first extended to options. *)

  Definition osub (o1 o2 : option A) :=
    forall a2,
    o2 = Some a2 ->
    exists a1,
    o1 = Some a1 /\ sub a1 a2.

  Lemma osub_None:
    forall o,
    osub o None.
  Proof.
    unfold osub. congruence.
  Qed.

  Lemma osub_Some_Some:
    forall a1 a2,
    sub a1 a2 ->
    osub (Some a1) (Some a2).
  Proof.
    unfold osub. intros ? ? ? ? h. injection h; clear h; intro; subst; eauto.
  Qed.

  Lemma osub_None_Some:
    forall a2,
    osub None (Some a2) ->
    False.
  Proof.
    unfold osub. intros ? h.
    generalize (h _ eq_refl). clear h. intros [ a1 [ ? ? ]].
    congruence.
  Qed.

  Lemma osub_Some_inversion:
    forall o1 a2,
    osub o1 (Some a2) ->
    exists a1,
    o1 = Some a1 /\ sub a1 a2.
  Proof.
    intros. destruct o1. eauto. elimtype False. eauto using osub_None_Some.
  Qed.

  (* Then, it is extended pointwise to environments. *)

  Definition subsume (e1 e2 : env A) :=
    forall x,
    osub (lookup x e1) (lookup x e2).

  (* Subsumption of environments is reflexive and transitive. *)

  Lemma osub_reflexive:
    forall o,
    osub o o.
  Proof.
    unfold osub. eauto.
  Qed.

  Lemma subsume_reflexive:
    forall e,
    subsume e e.
  Proof.
    unfold subsume. eauto using osub_reflexive.
  Qed.

  Lemma osub_transitive:
    forall o1 o2 o3,
    osub o1 o2 ->
    osub o2 o3 ->
    osub o1 o3.
  Proof.
    unfold osub. intros ? ? ? hs1 hs2 a3 h3.
    generalize (hs2 _ h3); intros [ a2 [ h2 ? ]].
    generalize (hs1 _ h2); intros [ a1 [ h1 ? ]].
    eauto.
  Qed.

  Lemma subsume_transitive:
    forall e1 e2 e3,
    subsume e1 e2 ->
    subsume e2 e3 ->
    subsume e1 e3.
  Proof.
    unfold subsume. eauto using osub_transitive.
  Qed.

  (* Every environment subsumes the empty environment. *)

  Lemma subsume_empty:
    forall e,
    subsume e (@empty _).
  Proof.
    unfold subsume. intros. rewrite lookup_empty_None. apply osub_None.
  Qed.

  (* Extending two environments with a new variable preserves subsumption. *)

  Lemma subsume_insert:
    forall e1 e2,
    subsume e1 e2 ->
    forall x o1 o2,
    osub o1 o2 ->
    subsume (raw_insert x o1 e1) (raw_insert x o2 e2).
  Proof.
    unfold subsume. do 7 intro. intros n.
    (* Reason by cases: [x = n], [x < n], [x > n]. *)
    case (le_gt_dec x n); [ case (eq_nat_dec x n) | ]; intros;
    (* In each case, [lookup_insert] simplifies the goal. *)
    repeat lookup_insert; eauto.
  Qed.

  Lemma subsume_cons:
    forall o e1 e2,
    osub o (lookup 0 e2) ->
    subsume e1 (tl e2) ->
    subsume (o :: e1) e2.
  Proof.
    do 3 intro. intros h1 h2. intro n. destruct n.
    eauto.
    do 2 rewrite lookup_successor. eauto.
  Qed.

  Lemma subsume_cons_cons_inversion:
    forall o1 o2 e1 e2,
    subsume (o1 :: e1) (o2 :: e2) ->
    osub o1 o2 /\
    subsume e1 e2.
  Proof.
    do 4 intro. intro h.
    split.
    eapply (h 0).
    intro n. eapply (h (1 + n)).
  Qed.

  Lemma subsume_insert_inversion:
    forall e1 x a2 e2,
    subsume e1 (insert x a2 e2) ->
    exists f1 a1,
    e1 = insert x a1 f1 /\
    subsume f1 e2 /\
    sub a1 a2.
  Proof.
    (* Really painful. *)
    induction e1; simpl; intros.
    (* Base. *)
    elimtype False.
    match goal with h: subsume nil _ |- _ =>
      generalize (h x); clear h; intro h;
      rewrite lookup_insert_bingo in h by reflexivity;
      rewrite lookup_empty_None in h
    end.
    solve [ eauto using osub_None_Some ].
    (* Step. *)
    destruct x.
    (* Case [x = 0]. *)
    match goal with h: subsume _ _ |- _ =>
      rewrite raw_insert_zero in h;
      generalize (subsume_cons_cons_inversion h); clear h; intros [ h ? ];
      generalize (osub_Some_inversion h); intros [ ? [ ? ? ]]; subst
    end.
    do 2 eexists.
    rewrite raw_insert_zero.
    solve [ eauto ].
    (* Case [x > 0]. *)
    match goal with h: subsume _ _ |- _ =>
      rewrite raw_insert_successor in h;
      generalize (subsume_cons_cons_inversion h); clear h; intros [ ? h ];
      generalize (IHe1 _ _ _ h); clear IHe1; intros [ f1 [ a1 [ ? [ ? ? ]]]]; subst
    end.
    exists (a :: f1). exists a1.
    rewrite raw_insert_successor. simpl.
    split; [ | split ].
    reflexivity.
    eauto using subsume_cons.
    eauto.
  Qed.

  (* Applying a transformation [f] pointwise to two environments preserves
     environment subsumption, provided [f] preserves [sub]. *)

  Lemma subsume_map:
    forall f,
    (forall a1 a2, sub a1 a2 -> sub (f a1) (f a2)) ->
    forall e1 e2,
    subsume e1 e2 ->
    subsume (map f e1) (map f e2).
  Proof.
    intros ? hf ? ? hs. intros ? b2 hlm2.
    generalize (lookup_map_some_reverse _ _ _ hlm2); intros [ ? [ hl2 ? ]]. subst.
    generalize (hs _ _ hl2); intros [ a1 [ ? ? ]].
    eauto using lookup_map_some.
  Qed.

End Subsume.

Hint Resolve osub_reflexive osub_Some_Some subsume_reflexive
subsume_transitive subsume_empty subsume_insert subsume_map : subsume.

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

(* Extending an environment with a list of bindings found in a pattern. *)

(* Note that we cannot define the concatenation of two environments, because
   we view environments as total functions, so we do not have precise control
   over their domain. Only a list has finite domain. *)

(* Concatenation is just an iterated version of [insert 0]. *)

Fixpoint concat (A : Type) (e1 : env A) (e2 : list A) : env A :=
  match e2 with
  | nil =>
      e1
  | cons a e2 =>
      concat (insert 0 a e1) e2
  end.

(* Concatenation acts upon the length of the environment in an obvious
   manner. *)

Lemma omega_hint_1:
  forall n,
  n <= (n + 1) - 1.
Proof.
  intros. omega.
Qed.

Lemma length_concat:
  forall A (e2 : list A) (e1 : env A) n1 n,
  length e1 <= n1 ->
  n1 + length e2 = n ->
  length (concat e1 e2) <= n.
Proof.
  induction e2; simpl; intros.
  replace n with n1 by omega. assumption.
  eauto using length_insert, omega_hint_1 with omega.
Qed.

Hint Resolve length_concat : length construction_closed.

(* If [e1] and [e2] agree up to depth [k], then, after extending them
   with a common suffix [e], they agree up to depth [k + length e]. *)

Lemma agree_concat:
  forall A (e : list A) (e1 e2 : env A) k n,
  agree e1 e2 k ->
  k + length e = n ->
  agree (concat e1 e) (concat e2 e) n.
Proof.
  induction e; simpl; intros.
  replace n with k by omega. assumption.
  eauto using agree_insert with omega.
Qed.

Hint Resolve agree_concat : agree.

(* Concatenation and insertion commute. *)

Lemma insert_concat:
  forall (A : Type) n x nx (o : option A) e1 e2,
  length e2 = n ->
  n + x = nx ->
  raw_insert nx o (concat e1 e2) = concat (raw_insert x o e1) e2.
Proof.
  induction n; intros; subst; destruct e2; simpl in *; try discriminate; auto.
  rewrite insert_insert by omega.
  erewrite <- (IHn (1 + x)) by first [ congruence | eauto ].
  eauto with f_equal omega.
Qed.

(* [replicate n a] is a list of [n] elements, all of which are
   equal to [a]. *)

Fixpoint replicate (A : Type) (n : nat) (a : A) : list A :=
  match n with
  | 0 =>
      @nil _
  | S n =>
      cons a (replicate n a)
  end.

(* The list [replicate n a] has length [n]. *)

Lemma length_replicate:
  forall (A : Type) n (a : A),
  length (replicate n a) = n.
Proof.
  induction n; simpl; auto.
Qed.

(* A special case of [insert_concat]. *)

Lemma insert_concat_replicate:
  forall (A : Type) n x nx (a : option A) (b : A) e1,
  n + x = nx ->
  raw_insert nx a (concat e1 (replicate n b)) = concat (raw_insert x a e1) (replicate n b).
Proof.
  eauto using insert_concat, length_replicate.
Qed.

(* [concat . (replicate . a)] is just an iterated version of [insert . a]. *)

Lemma concat_replicate_is_iterated_insert:
  forall (A : Type) n (a : A) e,
  insert n a (concat e (replicate n a)) =
  concat e (replicate (S n) a).
Proof.
  intros. simpl. eauto using insert_concat, length_replicate.
Qed.

Hint Resolve insert_concat length_replicate insert_concat_replicate
concat_replicate_is_iterated_insert : insert_concat.

(* A special case of [length_concat]. *)

Lemma length_concat_replicate:
  forall A (a : A) (e1 : env A) n1 n2 n,
  length e1 <= n1 ->
  n1 + n2 = n ->
  length (concat e1 (replicate n2 a)) <= n.
Proof.
  intros. eapply length_concat. eauto. rewrite length_replicate. eauto.
Qed.

Hint Resolve length_concat_replicate : length construction_closed.

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

(* Make some definitions opaque, so that Coq does not over-simplify in
   unexpected (and fragile) ways. *)

Global Opaque empty lookup raw_insert map.


Module M.
  Definition t := nat.
  Definition x := 0.
End M.

Print M.t.

Module Type SIG.
  Parameter t : Set.
  Parameter x : t.
End SIG.

Module F (X: SIG).
  Definition t := X.t -> X.t.
  Definition x : t.
    intro.
    exact X.x.
  Defined.
  Definition y := X.x.
End F.

Module N := F M.

Print N.t.
Eval compute in N.t.

Module N' : SIG := N.

Print N'.t.
Eval compute in N'.t.

Module N'' <: SIG := F N.

Print N''.t.
Eval compute in N''.t.

Eval compute in N''.x.

Module N''' : SIG with Definition t := nat -> nat := N.

Print N'''.t.
Eval compute in N'''.t.

Print N'''.x.

Import N'''.

Print t.


Set Warnings "-notation-overridden,-parsing".
Add LoadPath "lf/".
Require Import numbers.
Require Import induction.
Require Import lists.
Require Import poly.
Require Import List.
Require Import Coq.Arith.Mult.
Import ListNotations.

Theorem silly1: forall (n m o p : nat),
  n = m ->
  [n;o] = [n;p] ->
  [n;o] = [m;p].

Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  (* instead of: rewrite -> eq2. reflexivity. *)
  apply eq2. Qed.

Theorem silly2: forall (n m o p : nat),
  n = m ->
  (forall (q r : nat), q = r -> [q;o] = [r;p]) ->
    [n;o] = [m;p].

Proof.
  intros m n o p eq1 eq2.
  apply eq2. apply eq1.
  Qed.

Theorem silly2a: forall (n m : nat),
  (n, n) = (m, m) ->
  (forall (q r : nat), (q, q) = (r, r) -> [q] = [r]) ->
    [n] = [m].

Proof.
  intros n m eq1 eq2.
  (* apply eq2 instantiates q to n, r to m *)
  apply eq2. apply eq1.
  Qed.

(* Exercise *)
Theorem silly_ex:
  (forall n, even n = true -> odd (S n) = true) ->
    odd 3 = true ->
    even 4 = true.

Proof.
  intros eq1 eq2.
  apply eq2.
  Qed.

(* conclusion and goal must line up for `apply` *)
(* here, we use `symmetry` to switch lhs/rhs *)
Theorem silly3: forall (n : nat),
  true = beq_nat n 5 ->
  beq_nat (S (S n)) 7 = true.

Proof.
  intros n H.
  symmetry.
  apply H. Qed.

(* Exercise *)
Lemma rev_injective: forall m n : list nat,
  rev m = rev n -> m = n.

Proof.
  intros.
  rewrite <- rev_involutive.
  rewrite <- H.
  rewrite -> rev_involutive.
  reflexivity.
  Qed.

Theorem rev_exercise_1: forall (l l' : list nat),
  l = rev l' ->
  l' = rev l.

Proof.
  intros l l' H.
  apply rev_injective.
  symmetry.
  rewrite rev_involutive.
  apply H.
  Qed.

(* Demonstrating `apply ... with` *)
Example trans_eq_example:
  forall (a b c d e f : nat),
  [a;b] = [c;d] ->
  [c;d] = [e;f] ->
  [a;b] = [e;f].

Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity.
  Qed.

(* The above has 2 rewrites, and is a common pattern *)
(* which can be expressed as *)
Theorem trans_eq: forall (X : Type) (n m o : X),
  n = m -> m = o -> n = o.

Proof.
  intros X n m o eq1 eq2.
  rewrite -> eq1. rewrite -> eq2.
  reflexivity.
  Qed.

Example trans_eq_example':
  forall (a b c d e f : nat),
  [a;b] = [c;d] ->
  [c;d] = [e;f] ->
  [a;b] = [e;f].

Proof.
  intros a b c d e f eq1 eq2.
  apply trans_eq with (m := [c;d]).
  apply eq1. apply eq2. Qed.

(* Exercise *)
Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Example trans_eq_exercise: forall (n m o p : nat),
  m = (minustwo o) ->
  (n + p) = m ->
  (n + p) = (minustwo o).

Proof.
  intros n m o p eq1 eq2.
  apply trans_eq with (m := minustwo o).
  - rewrite -> eq2. apply eq1.
  - reflexivity.
  Qed.

(* Demonstrating `inversion` *)
Theorem S_injective: forall (n m : nat),
  S n = S m ->
  n = m.

Proof.
  intros n m H.
  inversion H. (* this amounts to adding H1: n = m, replacing n by m *)
  reflexivity.
  Qed.

Theorem inversion_ex_1: forall (n m o : nat),
  [n;m] = [o;o] ->
  [n] = [m].

Proof.
  intros n m o H.
  inversion H.
  reflexivity.
  Qed.

(* Exercise *)
Example inversion_ex_3:
  forall (X : Type) (x y z w : X) (l j : list X),
  x :: y :: l = w :: z :: j ->
  x :: l = z :: j ->
  x = y.

Proof.
  intros X x y z w l j eq1 eq2.
  inversion eq2. inversion eq1. reflexivity.
  Qed.

(* Principle of explosion *)
Theorem inversion_ex_4: forall (n : nat),
  S n = 0 ->
  2 + 2 = 5.

Proof.
  intros n contra.
  inversion contra.
  Qed.

Theorem inversion_ex5 : forall (n m : nat),
  false = true ->
  [n] = [m].
Proof.
  intros n m contra. inversion contra. Qed.

(* Exercise *)
Example inversion_ex_6:
  forall (X : Type) (x y z : X) (l j : list X),
  x :: y :: l = [] ->
  y :: l = z :: j ->
  x = z.

Proof.
  intros X x y z l j eq1.
  inversion eq1.
  Qed.

(* Tactics on hypotheses *)

(* `simpl in H` performs simplication in the hypothesis H *)
Theorem S_inj: forall (n m : nat) (b : bool),
  beq_nat (S n) (S m) = b ->
  beq_nat n m = b.

Proof.
  intros n m b H.
  simpl in H.
  apply H.
  Qed.

(* Similarly, `apply L in H` matches some conditional statement L against H *)
(* This gives us a form of "forward reasoning" *)
(* In contrast, `apply L` is backward reasoning *)

(* Demonstrating forward reasoning *)
Theorem silly3': forall (n : nat),
  (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
  true = beq_nat n 5 ->
  true = beq_nat (S (S n)) 7.

Proof.
  intros n eq H.
  symmetry in H.
  apply eq in H. (* matches q in p -> q, matching against p *)
  symmetry in H.
  apply H.
  Qed.

(* Exercise *)
Check plus_n_Sm.
(* plus_n_Sm : forall n m : nat, S (n + m) = n + S m *)

Lemma eq_imp_succ: forall n m,
  n = m -> S n = S m.
  intros n m eq.
  rewrite eq.
  reflexivity.
Qed.

Theorem plus_n_n_injective: forall n m,
  n + n = m + m ->
  n = m.

Proof.
  intros n.
  induction n as [| n' ].
  destruct m.
  intro H. reflexivity.
  simpl. intro contra. inversion contra.
  destruct m as [| m' ].
  intro H.
  - simpl in H. inversion H.
  - intro H.
    apply eq_imp_succ.
    apply IHn'.
    simpl in H.
    inversion H.
    rewrite <- plus_n_Sm in H1.
    rewrite <- plus_n_Sm in H1.
    inversion H1.
    reflexivity.
  Qed.

(* Exercise *)
Theorem beq_nat_true:
  forall n m,
  beq_nat n m = true ->
  n = m.

Proof.
  intros n.
  induction n as [| n' IHn' ].
  - simpl. destruct m.
    + intro H. reflexivity.
    + intro contra. inversion contra.
  - intro m. destruct m as [| m' ].
    + simpl. intro contra. inversion contra.
    + simpl. intro H.
      apply eq_imp_succ.
      apply IHn'. inversion H.
      reflexivity.
  Qed.

(* Demonstrating `generalize independent` *)
(* Pattern: introduce all quantified variables, *)
(* then re-generalize one or more of them, *)
(* selectively taking variables out of the context *)
(* and putting them back at the beginning of the goal *)
Theorem double_injective:
  forall n m,
  double n = double m ->
  n = m.

Proof.
  intros n m.
  (* n and m are both in the context *)
  generalize dependent n.
  (* n is back in goal, and we can do induction on m *)
  (* and get a sufficiently general IH *)
  induction m as [| m' ].
  - simpl. intros n eq. destruct n as [| n' ].
    + reflexivity.
    + inversion eq.
  - simpl. intros n eq. destruct n as [| n' ].
    + inversion eq.
    + apply f_equal.  apply IHm'. inversion eq. reflexivity.
  Qed.

(* needed in later chapters *)
Theorem beq_id_true:
  forall x  y,
  NatList.beq_id x y = true ->
  x = y.

Proof.
  intros [m] [n].
  simpl. intros H.
  assert (H' : m = n).
    - apply beq_nat_true. apply H.
    - rewrite H'. reflexivity.
  Qed.

(* Exercise *)
Check nth_error.

Theorem nth_error_after_last:
  forall (n : nat) (X : Type) (l : list X),
  length l = n ->
  nth_error l n = None.

Proof.
  intros n X l.
  generalize dependent n.
  induction l as [| l' ].
  - simpl. intros n eq. destruct n as [| n' ].
    + simpl. reflexivity.
    + inversion eq.
  - simpl. intros n eq. destruct n as [| n' ].
    + simpl. inversion eq.
    + simpl. rewrite IHl.
      * reflexivity.
      * inversion eq. reflexivity.
  Qed.

(* Demonstrating unfolding of definitions *)
Definition square n := n * n.

Lemma square_mult:
  forall n m,
  square (n * m) = square n * square m.

Proof.
  intros n m.
  unfold square.
  rewrite mult_assoc.
  assert (H: n * m * n = n * n * m).
  - rewrite mult_comm. apply mult_assoc.
  - rewrite H.  rewrite mult_assoc. reflexivity.
  Qed.


(* Some results about real numbers *)

From intuitionism Require Import lib set seq spr fan func classic choice.
From intuitionism Require Import bcp bar.

(*
Describing intervals of real numbers as binary sequences
--------------------------------------------------------
We can describe the real numbers in [a_0, b_0] as binary sequences. At each step
the interval [a_n, b_n] is split into [a_n, (a_n+2b_h)/3], [(2a_n+b_n)/3, b_n].
A sequence α ∈ Bin selects in which intervals a point is located. Note that
splitting in half would require exact knowledge about the upper/lower bound of
some numbers, which is a problem for some constructions.
The next definitions use [a_0, b_0] = [0, 1].
*)

(* Compute left endpoint of the n-th interval of α with denominator 3^(n+1). *)
Fixpoint lbound α n :=
  (if α n =? 0 then 0 else 2^n) +
  match n with
  | 0 => 0
  | S m => 3 * lbound α m
  end.

(* Distance between m and n. *)
Definition distance m n := (m - n) + (m - n).

(* α and β are within distance 1/(2^δ) of each other. *)
Definition within (δ : nat) (α β : dom Bin) :=
  ∃n, 2^δ * distance (lbound α n) (lbound β n) < 3^n.

(* Continuity of f : [0,1] -> [0,1] at x. *)
Definition point_continuous f x ε :=
  ∃δ, ∀x', within δ x x' -> within ε (f x) (f x').

(* Pointwise continuity of f : [0,1] -> [0,1]. *)
Definition pointwise_continuous f :=
  ∀x ε, point_continuous f x ε.

(* Uniform continuity of f : [0,1] -> [0,1]. *)
Definition uniform_continuous f :=
  ∀ε, ∃δ, ∀x x', within δ x x' -> within ε (f x) (f x').

(* The intermediate value theorem. *)
Definition IntermediateValueTheorem :=
  ∀f, pointwise_continuous f /\ f (0^ω) = 0^ω /\ f (1^ω) = 1^ω ->
  ∀y, ∃x, f x = y.

(* Simple form of Brouwers fixed-point theorem. *)
Definition FixedPointTheorem :=
  ∀f, uniform_continuous f -> ∃x, f x = x.

(*
It would be nice if we can show that both the intermediate value theorem and
Brouwers fixed-point theorem imply LPO without resorting to a full definition
of real numbers. However it seems the binary sequences are not particularly
easy to reason about either, or do arithmetic with.
*)


Set Implicit Arguments.
Require Import Arith.

Print sum.
(* Inductive sum (A B : Type) : Type :=  inl : A -> A + B | inr : B -> A + B *)

Check (sum nat bool). (* Set *)

Check (inl bool 4). (* nat + bool *)


Require Import Coq.micromega.Lia.
Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Structures.Orders.
Require Import Coq.Structures.OrdersEx.
Require Import Coq.MSets.MSetInterface.
Require Import Coq.MSets.MSetPositive.
Require Import Coq.NArith.NArith.
Require Import Crypto.Util.MSets.MSetIso.
Require Import Crypto.Util.Structures.Equalities.Iso.
Require Import Crypto.Util.Structures.Orders.Iso.

Local Set Implicit Arguments.

(* TODO: Swap out for the version in Util/Structures/OrdersEx.v, and profile to see if there are any perf implications *)
Module NIsoPositive <: IsoOrderedType PositiveSet.E.
  Definition t := N.
  Definition eq : t -> t -> Prop := eq.
  Definition eq_equiv : Equivalence eq := _.
  Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y} := N.eq_dec.
  Definition to_ : t -> PositiveSet.E.t := N.succ_pos.
  Definition of_ : PositiveSet.E.t -> t := Pos.pred_N.
  Lemma Proper_to_ : Proper (eq ==> PositiveSet.E.eq) to_.
  Proof. cbv [eq]; repeat intro; subst; reflexivity. Qed.
  Lemma Proper_of_ : Proper (PositiveSet.E.eq ==> eq) of_.
  Proof. cbv [PositiveSet.E.eq]; repeat intro; subst; reflexivity. Qed.
  Lemma of_to : forall x : t, eq (of_ (to_ x)) x.
  Proof. cbv [eq of_ to_]; intros; now rewrite N.pos_pred_succ. Qed.
  Lemma to_of : forall x : PositiveSet.E.t, PositiveSet.E.eq (to_ (of_ x)) x.
  Proof.
    intro x.
    cut (N.pos (to_ (of_ x)) = N.pos x); [ congruence | ].
    cbv [PositiveSet.E.eq of_ to_].
    rewrite N.pos_pred_spec, N.succ_pos_spec.
    lia.
  Qed.
  Definition lt (x y : t) : Prop := PositiveSet.E.lt (to_ x) (to_ y).
  Global Instance lt_strorder : StrictOrder lt | 100.
  Proof.
    split; hnf; cbv [lt complement]; intros *;
      apply PositiveSet.E.lt_strorder.
  Qed.
  Definition lt_compat : Proper (eq ==> eq ==> iff) lt := _.
  Definition compare (x y : t) : comparison := PositiveSet.E.compare (to_ x) (to_ y).
  Lemma compare_spec (x y : t) : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
  Proof.
    cbv [eq lt compare].
    destruct (PositiveSet.E.compare_spec (to_ x) (to_ y)); constructor; try assumption.
    cbv [PositiveSet.E.eq] in *.
    rewrite <- (of_to x), <- (of_to y).
    congruence.
  Qed.
  Global Instance Proper_to_lt : Proper (lt ==> PositiveSet.E.lt) to_ | 100.
  Proof. cbv [lt Proper respectful]; trivial. Qed.
  Global Instance Proper_of_lt : Proper (PositiveSet.E.lt ==> lt) of_ | 100.
  Proof. cbv [lt Proper respectful]; intros *; rewrite !to_of; trivial. Qed.
End NIsoPositive.

Module NSet <: S := IsoSets PositiveSet NIsoPositive.