(* Measures as integrators, a la diFinetti/Shan *)

Require Import LiftedTypes.
Require Import Weights.
Require Import MyReals.

Definition Measure (A : Type) : Type
  := ((A -> real) -> real).

(* Not every such function is a legitimate measure, but this *)
(* characterization, along with the Lebesgue axioms below, is good *)
(* enough for us *)

(* A better version would insist that the expectation function (A -> *)
(* Real) be measurable. *)

Parameter uniform_dist : Measure real.

(* The Lebesgue integral *)
Parameter mu_L : Measure Unit.

(* Axioms about the integral *)

Axiom mu_L_const : forall (c : real) (f : Unit -> real),
    (forall u, f u = c) -> mu_L f = c.

Axiom mu_L_linear : forall c f,
    mu_L (fun u => (times c (f u))) = (times c (mu_L f)).

Axiom split_entropy : forall f,
    mu_L (fun u1 => mu_L (fun u2 => f u1 u2))
    = mu_L (fun u => f (left_half u) (right_half u)).

Axiom mu_L_extensional : forall f g,
    (forall u, f u = g u) -> mu_L f = mu_L g.

Lemma strict0_mu_L : forall {X : Type} (m : lifted X) h,
    mu_L (fun u => strict0 m (fun x => h x u))
    =
    strict0 m (fun x => mu_L (fun u => h x u)).
Proof.
  destruct m; simpl; auto.
  rewrite (mu_L_const zero); auto.
Qed.

(* An arbitrary family of real-valued measure, indexed by the reals
   and drawn from by 'distval'.  The first argument p is the index.
   Think of (mu_1 p) as (normal p 1.0) *)

Parameter mu_1 : real -> Measure real.
Parameter density_1 : real -> real -> Weight.

Axiom mu_1_density_1 :
  forall (p: real)(k : real -> real),
    mu_1 p k = mu_L (fun u =>
                     (times (density_1 p (unit_real u)) (k (unit_real u)))).

Lemma strict20_mu_L : forall {A W : Type} (m : lifted (A * W)) h,
    mu_L (fun u => strict20 m (fun x w => h x w u))
    =
    strict20 m (fun x w => mu_L (fun u => (h x w u))).
Proof.
  destruct m; simpl; auto.
  rewrite (mu_L_const zero); auto.
  destruct p; auto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    * rewrite 2 drop_Cons. rewrite <- IHx1.
      rewrite IHx2. rewrite 2 drop_Cons.
      induction l.
      - rewrite IHx1. reflexivity.
      - rewrite 3 drop_Nil. reflexivity.
    * simpl. rewrite 2 drop_Nil. reflexivity.
  + intros. simpl. destruct (drop x1 l); reflexivity.
  + intros. simpl. destruct (drop x2 l); reflexivity.
Qed.

Theorem drop_assoc : forall (x : natural) (y : natural) (z : lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
  + rewrite 2 drop_Cons_assoc. reflexivity.
  + rewrite 3 drop_Nil. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (w : natural) (z : lst), eq (drop w (drop x (drop y z))) (drop y (drop x (drop w z))).
Proof.
  intros.
  rewrite (drop_assoc w x).
  rewrite (drop_assoc w y).
lfind.
Admitted.


Require Export Instances.Cat.Product.

Definition Exp (T S: Category) := Fun S T.

Program Definition Eval (T S: Category): Exp T S × S ~> T := {|
  fobj p := fst p (snd p);
  fmap (p q: Exp T S × S) f := fst f (snd q) ∘ fmap (fst p) (snd f);
|}.
Next Obligation.
  simpl.
  rewrite comp_id_l.
  apply fmap_id.
Qed.
Next Obligation.
  simpl.
  rewrite <- !comp_assoc.
  f_equal.
  rewrite fmap_comp, !comp_assoc.
  f_equal.
  apply naturality.
Qed.

Program Definition Transpose {T S C: Category} (F: C × S ~> T): C ~> Exp T S := {|
  fobj x := {|
    fobj y := F (x, y);
    fmap a b f := fmap F (id x, f);
  |};
  fmap x y f := {|
    transform a := fmap F (f, id a);
  |}
|}.
Next Obligation.
  f_equal.
  apply (@fmap_id _ _ F).
Qed.
Next Obligation.
  rewrite <- (comp_id_l (id x)) at 1.
  apply (fmap_comp ((id x, f): (_, _) ~> (_, _)) ((id x, g): (_, _) ~> (_, _))).
Qed.
Next Obligation.
  rewrite <- !fmap_comp.
  f_equal.
  apply Prod.hom_eq; simpl; split.
  all: now rewrite comp_id_l, comp_id_r.
Qed.
Next Obligation.
  natural_eq x.
  apply (@fmap_id _ _ F).
Qed.
Next Obligation.
  natural_eq x.
  rewrite <- fmap_comp.
  f_equal.
  unfold comp at 2; simpl.
  f_equal.
  symmetry.
  apply comp_id_l.
Qed.

Lemma Transpose_ump (T S C: Category) (F: C × S ~> T) (G: C ~> Exp T S): Eval T S ∘ (G (×) id S) = F <-> Transpose F = G.
Proof.
  split; intros H.
  + subst F.
    fun_eq x y f.
    fun_eq a b f.
    rewrite fmap_id.
    apply comp_id_l.
    natural_eq a.
    etransitivity.
    etransitivity.
    apply (f_equal (fun f => f ∘ _)).
    3: apply f_equal.
    3: symmetry.
    1, 3: apply is_eq_refl.
    1: apply (transform_is_eq (eq_iso H0)).
    2: apply (transform_is_eq (eq_iso H)).
    1, 2: apply eq_iso_is_eq.
    clear.
    rewrite comp_id_l.
    f_equal.
    apply fmap_id.
  + subst G.
    fun_eq p q f.
    now destruct x.
    destruct p as [x y], q as [x' y'], f as [f g].
    simpl in *.
    rewrite !eq_iso_refl.
    simpl.
    rewrite comp_id_l, comp_id_r.
    rewrite <- fmap_comp.
    f_equal.
    apply Prod.hom_eq; simpl; split.
    apply comp_id_r.
    apply comp_id_l.
Qed.

Definition CatExp_mixin: ExpCategory.mixin_of CatProd :=
  ExpCategory.Mixin CatProd Exp Eval (@Transpose) Transpose_ump.

Canonical CatExp: ExpCategory :=
  ExpCategory.Pack Cat (ExpCategory.Class Cat CatProd_mixin CatExp_mixin).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

(*i $Id: Int31.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import NaryFunctions.
Require Import Wf_nat.
Require Export ZArith.
Require Export DoubleType.

Unset Boxed Definitions.

(** * 31-bit integers *)

(** This file contains basic definitions of a 31-bit integer
  arithmetic. In fact it is more general than that. The only reason
  for this use of 31 is the underlying mecanism for hardware-efficient
  computations by A. Spiwack. Apart from this, a switch to, say,
  63-bit integers is now just a matter of replacing every occurences
  of 31 by 63. This is actually made possible by the use of
  dependently-typed n-ary constructions for the inductive type
  [int31], its constructor [I31] and any pattern matching on it.
  If you modify this file, please preserve this genericity.  *)

Definition size := 31%nat.

(** Digits *)

Inductive digits : Type := D0 | D1.

(** The type of 31-bit integers *)

(** The type [int31] has a unique constructor [I31] that expects
   31 arguments of type [digits]. *)

Definition digits31 t := Eval compute in nfun digits size t.

Inductive int31 : Type := I31 : digits31 int31.

(* spiwack: Registration of the type of integers, so that the matchs in
   the functions below perform dynamic decompilation (otherwise some segfault
   occur when they are applied to one non-closed term and one closed term). *)
Register digits as int31 bits in "coq_int31" by True.
Register int31 as int31 type in "coq_int31" by True.

Delimit Scope int31_scope with int31.
Bind Scope int31_scope with int31.
Local Open Scope int31_scope.

(** * Constants *)

(** Zero is [I31 D0 ... D0] *)
Definition On : int31 := Eval compute in napply_cst _ _ D0 size I31.

(** One is [I31 D0 ... D0 D1] *)
Definition In : int31 := Eval compute in (napply_cst _ _ D0 (size-1) I31) D1.

(** The biggest integer is [I31 D1 ... D1], corresponding to [(2^size)-1] *)
Definition Tn : int31 := Eval compute in napply_cst _ _ D1 size I31.

(** Two is [I31 D0 ... D0 D1 D0] *)
Definition Twon : int31 := Eval compute in (napply_cst _ _ D0 (size-2) I31) D1 D0.

(** * Bits manipulation *)

(** [sneakr b x] shifts [x] to the right by one bit.
   Rightmost digit is lost while leftmost digit becomes [b].
   Pseudo-code is
    [ match x with (I31 d0 ... dN) => I31 b d0 ... d(N-1) end ]
*)

Definition sneakr : digits -> int31 -> int31 := Eval compute in
 fun b => int31_rect _ (napply_except_last _ _ (size-1) (I31 b)).

(** [sneakl b x] shifts [x] to the left by one bit.
   Leftmost digit is lost while rightmost digit becomes [b].
   Pseudo-code is
    [ match x with (I31 d0 ... dN) => I31 d1 ... dN b end ]
*)

Definition sneakl : digits -> int31 -> int31 := Eval compute in
 fun b => int31_rect _ (fun _ => napply_then_last _ _ b (size-1) I31).

(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct
    consequences of [sneakl] and [sneakr]. *)

Definition shiftl := sneakl D0.
Definition shiftr := sneakr D0.
Definition twice := sneakl D0.
Definition twice_plus_one := sneakl D1.

(** [firstl x] returns the leftmost digit of number [x].
    Pseudo-code is [ match x with (I31 d0 ... dN) => d0 end ] *)

Definition firstl : int31 -> digits := Eval compute in
 int31_rect _ (fun d => napply_discard _ _ d (size-1)).

(** [firstr x] returns the rightmost digit of number [x].
    Pseudo-code is [ match x with (I31 d0 ... dN) => dN end ] *)

Definition firstr : int31 -> digits := Eval compute in
 int31_rect _ (napply_discard _ _ (fun d=>d) (size-1)).

(** [iszero x] is true iff [x = I31 D0 ... D0]. Pseudo-code is
    [ match x with (I31 D0 ... D0) => true | _ => false end ] *)

Definition iszero : int31 -> bool := Eval compute in
 let f d b := match d with D0 => b | D1 => false end
 in int31_rect _ (nfold_bis _ _ f true size).

(* NB: DO NOT transform the above match in a nicer (if then else).
   It seems to work, but later "unfold iszero" takes forever. *)

(** [base] is [2^31], obtained via iterations of [Zdouble].
   It can also be seen as the smallest b > 0 s.t. phi_inv b = 0
   (see below) *)

Definition base := Eval compute in
 iter_nat size Z Zdouble 1%Z.

(** * Recursors *)

Fixpoint recl_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A)
 (i:int31) : A :=
  match n with
  | O => case0
  | S next =>
          if iszero i then
             case0
          else
             let si := shiftl i in
             caserec (firstl i) si (recl_aux next A case0 caserec si)
  end.

Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A)
 (i:int31) : A :=
  match n with
  | O => case0
  | S next =>
          if iszero i then
             case0
          else
             let si := shiftr i in
             caserec (firstr i) si (recr_aux next A case0 caserec si)
  end.

Definition recl := recl_aux size.
Definition recr := recr_aux size.

(** * Conversions *)

(** From int31 to Z, we simply iterates [Zdouble] or [Zdouble_plus_one]. *)

Definition phi : int31 -> Z :=
 recr Z (0%Z)
  (fun b _ => match b with D0 => Zdouble | D1 => Zdouble_plus_one end).

(** From positive to int31. An abstract definition could be :
      [ phi_inv (2n) = 2*(phi_inv n) /\
        phi_inv 2n+1 = 2*(phi_inv n) + 1 ] *)

Fixpoint phi_inv_positive p :=
  match p with
    | xI q => twice_plus_one (phi_inv_positive q)
    | xO q => twice (phi_inv_positive q)
    | xH => In
  end.

(** The negative part : 2-complement  *)

Fixpoint complement_negative p :=
  match p with
    | xI q => twice (complement_negative q)
    | xO q => twice_plus_one (complement_negative q)
    | xH => twice Tn
  end.

(** A simple incrementation function *)

Definition incr : int31 -> int31 :=
 recr int31 In
   (fun b si rec => match b with
     | D0 => sneakl D1 si
     | D1 => sneakl D0 rec end).

(** We can now define the conversion from Z to int31. *)

Definition phi_inv : Z -> int31 := fun n =>
 match n with
 | Z0 => On
 | Zpos p => phi_inv_positive p
 | Zneg p => incr (complement_negative p)
 end.

(** [phi_inv2] is similar to [phi_inv] but returns a double word
    [zn2z int31] *)

Definition phi_inv2 n :=
  match n with
  | Z0 => W0
  | _ => WW (phi_inv (n/base)%Z) (phi_inv n)
  end.

(** [phi2] is similar to [phi] but takes a double word (two args) *)

Definition phi2 nh nl :=
  ((phi nh)*base+(phi nl))%Z.

(** * Addition *)

(** Addition modulo [2^31] *)

Definition add31 (n m : int31) := phi_inv ((phi n)+(phi m)).
Notation "n + m" := (add31 n m) : int31_scope.

(** Addition with carry (the result is thus exact) *)

(* spiwack : when executed in non-compiled*)
(* mode, (phi n)+(phi m) is computed twice*)
(* it may be considered to optimize it *)

Definition add31c (n m : int31) :=
  let npm := n+m in
  match (phi npm ?= (phi n)+(phi m))%Z with
  | Eq => C0 npm
  | _ => C1 npm
  end.
Notation "n '+c' m" := (add31c n m) (at level 50, no associativity) : int31_scope.

(**  Addition plus one with carry (the result is thus exact) *)

Definition add31carryc (n m : int31) :=
  let npmpone_exact := ((phi n)+(phi m)+1)%Z in
  let npmpone := phi_inv npmpone_exact in
  match (phi npmpone ?= npmpone_exact)%Z with
  | Eq => C0 npmpone
  | _ => C1 npmpone
  end.

(** * Substraction *)

(** Subtraction modulo [2^31] *)

Definition sub31 (n m : int31) := phi_inv ((phi n)-(phi m)).
Notation "n - m" := (sub31 n m) : int31_scope.

(** Subtraction with carry (thus exact) *)

Definition sub31c (n m : int31) :=
  let nmm := n-m in
  match (phi nmm ?= (phi n)-(phi m))%Z with
  | Eq => C0 nmm
  | _ => C1 nmm
  end.
Notation "n '-c' m" := (sub31c n m) (at level 50, no associativity) : int31_scope.

(** subtraction minus one with carry (thus exact) *)

Definition sub31carryc (n m : int31) :=
  let nmmmone_exact := ((phi n)-(phi m)-1)%Z in
  let nmmmone := phi_inv nmmmone_exact in
  match (phi nmmmone ?= nmmmone_exact)%Z with
  | Eq => C0 nmmmone
  | _ => C1 nmmmone
  end.

(** Opposite *)

Definition opp31 x := On - x.
Notation "- x" := (opp31 x) : int31_scope.

(** Multiplication *)

(** multiplication modulo [2^31] *)

Definition mul31 (n m : int31) := phi_inv ((phi n)*(phi m)).
Notation "n * m" := (mul31 n m) : int31_scope.

(** multiplication with double word result (thus exact) *)

Definition mul31c (n m : int31) := phi_inv2 ((phi n)*(phi m)).
Notation "n '*c' m" := (mul31c n m) (at level 40, no associativity) : int31_scope.

(** * Division *)

(** Division of a double size word modulo [2^31] *)

Definition div3121 (nh nl m : int31) :=
  let (q,r) := Zdiv_eucl (phi2 nh nl) (phi m) in
  (phi_inv q, phi_inv r).

(** Division modulo [2^31] *)

Definition div31 (n m : int31) :=
  let (q,r) := Zdiv_eucl (phi n) (phi m) in
  (phi_inv q, phi_inv r).
Notation "n / m" := (div31 n m) : int31_scope.

(** * Unsigned comparison *)

Definition compare31 (n m : int31) := ((phi n)?=(phi m))%Z.
Notation "n ?= m" := (compare31 n m) (at level 70, no associativity) : int31_scope.

Definition eqb31 (n m : int31) :=
 match n ?= m with Eq => true | _ => false end.

(** Computing the [i]-th iterate of a function:
    [iter_int31 i A f = f^i] *)

Definition iter_int31 i A f :=
  recr (A->A) (fun x => x)
   (fun b si rec => match b with
      | D0 => fun x => rec (rec x)
      | D1 => fun x => f (rec (rec x))
    end)
    i.

(** Combining the [(31-p)] low bits of [i] above the [p] high bits of [j]:
    [addmuldiv31 p i j = i*2^p+j/2^(31-p)]  (modulo [2^31]) *)

Definition addmuldiv31 p i j :=
 let (res, _ ) :=
 iter_int31 p (int31*int31)
  (fun ij => let (i,j) := ij in (sneakl (firstl j) i, shiftl j))
  (i,j)
 in
 res.

Register add31 as int31 plus in "coq_int31" by True.
Register add31c as int31 plusc in "coq_int31" by True.
Register add31carryc as int31 pluscarryc in "coq_int31" by True.
Register sub31 as int31 minus in "coq_int31" by True.
Register sub31c as int31 minusc in "coq_int31" by True.
Register sub31carryc as int31 minuscarryc in "coq_int31" by True.
Register mul31 as int31 times in "coq_int31" by True.
Register mul31c as int31 timesc in "coq_int31" by True.
Register div3121 as int31 div21 in "coq_int31" by True.
Register div31 as int31 div in "coq_int31" by True.
Register compare31 as int31 compare in "coq_int31" by True.
Register addmuldiv31 as int31 addmuldiv in "coq_int31" by True.

Definition gcd31 (i j:int31) :=
  (fix euler (guard:nat) (i j:int31) {struct guard} :=
   match guard with
   | O => In
   | S p => match j ?= On with
            | Eq => i
            | _ => euler p j (let (_, r ) := i/j in r)
            end
   end)
  (2*size)%nat i j.

(** Square root functions using newton iteration
    we use a very naive upper-bound on the iteration
    2^31 instead of the usual 31.
**)

Definition sqrt31_step (rec: int31 -> int31 -> int31) (i j: int31)  :=
Eval lazy delta [Twon] in
  let (quo,_) := i/j in
  match quo ?= j with
    Lt => rec i (fst ((j + quo)/Twon))
  | _ =>  j
  end.

Fixpoint iter31_sqrt (n: nat) (rec: int31 -> int31 -> int31)
          (i j: int31) {struct n} : int31 :=
  sqrt31_step
   (match n with
      O =>  rec
   | S n => (iter31_sqrt n (iter31_sqrt n rec))
   end) i j.

Definition sqrt31 i :=
Eval lazy delta [On In Twon] in
  match compare31 In i with
    Gt => On
  | Eq => In
  | Lt => iter31_sqrt 31 (fun i j => j) i (fst (i/Twon))
  end.

Definition v30 := Eval compute in (addmuldiv31 (phi_inv (Z_of_nat size - 1)) In On).

Definition sqrt312_step (rec: int31 -> int31 -> int31 -> int31)
   (ih il j: int31)  :=
Eval lazy delta [Twon v30] in
  match ih ?= j with Eq => j | Gt => j | _ =>
  let (quo,_) := div3121 ih il j in
  match quo ?= j with
    Lt => let m := match j +c quo with
                    C0 m1 => fst (m1/Twon)
                  | C1 m1 => fst (m1/Twon) + v30
                  end in rec ih il m
  | _ =>  j
  end end.

Fixpoint iter312_sqrt (n: nat)
          (rec: int31  -> int31 -> int31 -> int31)
          (ih il j: int31) {struct n} : int31 :=
  sqrt312_step
   (match n with
      O =>  rec
   | S n => (iter312_sqrt n (iter312_sqrt n rec))
   end) ih il j.

Definition sqrt312 ih il :=
Eval lazy delta [On In] in
  let s := iter312_sqrt 31 (fun ih il j => j) ih il Tn in
           match s *c s with
            W0 => (On, C0 On) (* impossible *)
          | WW ih1 il1 =>
             match il -c il1 with
                C0 il2 =>
                  match ih ?= ih1 with
                    Gt => (s, C1 il2)
                  | _  => (s, C0 il2)
                  end
              | C1 il2 =>
                  match (ih - In) ?= ih1 with (* we could parametrize ih - 1 *)
                    Gt => (s, C1 il2)
                  | _  => (s, C0 il2)
                  end
              end
          end.

Fixpoint p2i n p : (N*int31)%type :=
  match n with
    | O => (Npos p, On)
    | S n => match p with
               | xO p => let (r,i) := p2i n p in (r, Twon*i)
               | xI p => let (r,i) := p2i n p in (r, Twon*i+In)
               | xH => (N0, In)
             end
  end.

Definition positive_to_int31 (p:positive) := p2i size p.

(** Constant 31 converted into type int31.
    It is used as default answer for numbers of zeros
    in [head0] and [tail0] *)

Definition T31 : int31 := Eval compute in phi_inv (Z_of_nat size).

Definition head031 (i:int31) :=
  recl _ (fun _ => T31)
   (fun b si rec n => match b with
     | D0 => rec (add31 n In)
     | D1 => n
    end)
   i On.

Definition tail031 (i:int31) :=
  recr _ (fun _ => T31)
   (fun b si rec n => match b with
     | D0 => rec (add31 n In)
     | D1 => n
    end)
   i On.

Register head031 as int31 head0 in "coq_int31" by True.
Register tail031 as int31 tail0 in "coq_int31" by True.


Require Import List.
Import ListNotations.

Inductive HList (a:Type) (b:a -> Type) : list a -> Type :=
| HNil  : HList a b nil
| HCons : forall (x:a) (xs:list a), b x -> HList a b xs -> HList a b (x :: xs)
.

Arguments HList {a}.
Arguments HNil {a} {b}.
Arguments HCons {a} {b} {x} {xs}.

Inductive Elem (a:Type) (x:a) : list a -> Type :=
| HFirst : forall (xs:list a), Elem a x (x :: xs)
| HNext  : forall (xs:list a) (y:a), Elem a x xs -> Elem a x (y ::xs)
.

Arguments Elem {a}.
Arguments HFirst {a} {x} {xs}.
Arguments HNext  {a} {x} {xs} {y}.


From LF Require Export Poly.
Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).
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. rewrite -> eq2. reflexivity.
Qed.

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. apply eq2.
Qed.

Theorem silly2 : forall (n m o p : nat),
    n = m ->
    (n = m -> [n;o] = [m;p]) ->
    [n;o] = [m;p].
Proof.
  intros n m 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. apply eq1. Qed.

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     evenb 4 = true ->
     oddb 3 = true.
Proof.
  intros eq1 eq2.
  apply eq1. apply eq2. Qed.

Notation "x = y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <= y" := (leb x y) (at level 70) : nat_scope.
Theorem silly3_firsttry : forall (n : nat),
     true = (n = 5) ->
     ((S (S n)) = 7) = true.
Proof.
  intros n H.
  symmetry.
  apply H. Qed.

Print prod.
Theorem rev_exercise1 : forall (l l' : list nat),
     l = rev l' ->
     l' = rev l.
Proof.
  intros. induction l.
  - induction l'.
    + simpl. reflexivity.
    + rewrite -> H. rewrite -> rev_involutive. reflexivity.
  - induction l'.
    + rewrite -> H. rewrite -> rev_involutive. reflexivity.
    + rewrite -> H. rewrite -> rev_involutive. 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.
  rewrite -> eq1. rewrite -> eq2. reflexivity. Qed.

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 [c;d].
  apply eq1. apply eq2.
Qed.

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.
  apply eq2. apply eq1.
Qed.

Theorem S_injective : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H1.
  assert (H2: n = pred (S n)). { reflexivity. }
  rewrite H2. rewrite H1. reflexivity.
Qed.

Theorem S_injective' : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H.
  injection H as Hnm. apply Hnm.
Qed.

Theorem injection_ex1 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  intros n m o H.
  (* 课上已完成 *)
  injection H as H1 H2.
  rewrite H1. rewrite H2. reflexivity.
Qed.

Theorem injection_ex2 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  intros n m o H.
  injection H.
  (* 课上已完成 *)
  intros H1 H2. rewrite H1. rewrite H2. reflexivity.
Qed.

Theorem eqb_0_l : forall n,
   ((0 = n) = true) -> n = 0.
Proof.
  intros n. destruct n as [| n'] eqn:E.
  - (* n = 0 *)
    intros H. reflexivity.
  - (* n = S n' *)
    simpl. intros H. discriminate H.
Qed.

Theorem discriminate_ex1 : forall (n : nat),
  S n = O ->
  2 + 2 = 5.
Proof.
  intros n contra. discriminate contra. Qed.
Theorem discriminate_ex2 : forall (n m : nat),
  false = true ->
  [n] = [m].
Proof.
  intros n m contra. discriminate contra. Qed.

Example discriminate_ex3 :
  forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] ->
    x = z.
Proof.
  intros. discriminate H.
Qed.

Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
  x = y -> f x = f y.
Proof. intros A B f x y eq. rewrite eq. reflexivity. Qed.
Theorem eq_implies_succ_equal : forall (n m : nat),
    n = m -> S n = S m.
Proof. intros n m H. apply f_equal. apply H. Qed.

Theorem eq_implies_succ_equal' : forall (n m : nat),
    n = m -> S n = S m.
Proof. intros n m H. f_equal. apply H. Qed.

Theorem S_inj : forall (n m : nat) (b : bool),
     ((S n) = (S m)) = b ->
     (n = m) = b.
Proof.
  intros n m b H. simpl in H. apply H. Qed.

Theorem silly3' : forall (n : nat),
  ((n = 5) = true -> ((S (S n)) = 7) = true) ->
  true = (n = 5) ->
  true = ((S (S n)) = 7).
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H. Qed.

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

Theorem double_injective_FAILED: forall n m,
         double n = double m -> n = m.
Proof.
  intros n m. induction n as [| n' IHn'].
  - (* n = O *) simpl. intros eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *) discriminate eq.
  - (* n = S n' *) intros eq. destruct m as [| m'] eqn:E.
    + (* m = O *) discriminate eq.
    + (* m = S m' *) apply f_equal.
Abort.

Theorem double_injective: forall n m,
         double n = double m -> n = m.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* n = O *) simpl. intros m eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *) discriminate eq.
  - (* n = S n' *) simpl. intros m eq. destruct m as [| m'] eqn:E.
    + (* m = O *) simpl. discriminate eq.
    + (* m = S m' *)
      apply f_equal. apply IHn'. injection eq as goal. apply goal.
Qed.

(*
  - (* n = O *)
    + (* m = O *)
    + (* m = S m' *)
  - (* n = S n' *)
    + (* m = O *)
    + (* m = S m' *)
*)
Theorem eqb_true : forall n m,
    (n = m) = true -> n = m.
(*Proof.
  intros n m eq. induction n as [| n' IHn'].
  - (* n = O *) destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *)simpl in eq. discriminate eq.
  - (* n = S n' *) destruct m as [| m'] eqn:E.
    + (* m = O *) simpl in eq. discriminate eq.
    + (* m = S m' *)simpl in eq.
Abort.*)

Proof.
  intros n. induction n as [| n' IHn'].
  - (* n = O *) intros m eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *)simpl in eq. discriminate eq.
  - (* n = S n' *) intros m eq. destruct m as [| m'] eqn:E.
    + (* m = O *) simpl in eq. discriminate eq.
    + (* m = S m' *) simpl in eq. apply IHn' in eq.
      apply f_equal. apply eq.
Qed.

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

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  - (* n = O *) intros m eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *) simpl in eq. discriminate eq.
  - (* n = S n' *) intros m eq. destruct m as [| m'] eqn:E.
    + (* m = O *) simpl in eq. discriminate eq.
    + (* m = S m' *) apply f_equal. apply IHn'. injection eq as goal.
      rewrite <- plus_n_Sm in goal. rewrite <- plus_n_Sm in goal.
      injection goal as Hsm. apply Hsm.
Qed.

Theorem double_injective_take2_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction m as [| m' IHm'].
  - (* m = O *) simpl. intros eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.
        (* 和前面一样，又卡在这儿了。 *)
Abort.

Theorem double_injective_take2 : 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 回到了目标中，我们可以对 m 进行归纳并得到足够一般的归纳假设了。 *)
  induction m as [| m' IHm'].
  - (* m = O *) simpl. intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.
      apply IHm'. injection eq as goal. apply goal. Qed.

Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     nth_error l n = None.
Proof.
  intros. generalize dependent n. induction l.
  - simpl. intros. reflexivity.
  - intros. induction n.
    + simpl in H. discriminate H.
    + simpl. apply IHl. simpl in H. injection H as Hsm. apply Hsm.
Qed.

Definition square n := n * n.

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  (* 请在此处解答 *) Admitted.

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  (* 请在此处解答 *) Admitted.

Lemma square_mult : forall n m, square (n * m) = square n * square m.
Proof.
  intros n m.
  simpl. 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.

Definition foo (x: nat) := 5.

Fact silly_fact_1 : forall m, foo m + 1 = foo (m + 1) + 1.
Proof.
  intros m.
  simpl.
  reflexivity.
Qed.

Definition bar x :=
  match x with
  | O => 5
  | S _ => 5
  end.

Fact silly_fact_2_FAILED : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  simpl. (* 啥也没做！ *)
Abort.

Fact silly_fact_2 : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  destruct m eqn:E.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Fact silly_fact_2' : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  unfold bar.
  destruct m eqn:E.
  - reflexivity.
  - reflexivity.
Qed.

Definition sillyfun (n : nat) : bool :=
  if (n = 3) then false
  else if (n = 5) then false
  else false.
Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (n = 3) eqn:E1.
    - (* n =? 3 = true *) reflexivity.
    - (* n =? 3 = false *) destruct (n = 5) eqn:E2.
      + (* n =? 5 = true *) reflexivity.
      + (* n =? 5 = false *) reflexivity. Qed.

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

Lemma tail_eq : forall {X : Type} (x : X) (l1 l2: list X), l1 = l2 -> x :: l1 = x :: l2.
Proof.
  intros. rewrite -> H. reflexivity.
Qed.

Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.

Proof.
  intros X Y l. induction l.
  - intros. inversion H. reflexivity.
  - intros. inversion H. destruct x. destruct (split l).
    simpl in H1. inversion H1. simpl. apply tail_eq. apply IHl.
    reflexivity.
Qed.

Definition sillyfun1 (n : nat) : bool :=
  if n = 3 then true
  else if n = 5 then true
  else false.

Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n = 3) eqn:Heqe3.
  (* 现在我们的状态和前面卡住的地方一样了，除了上下文中包含了额外的相等关系假设，
     它就是我们继续推进所需要的。 *)
    - (* e3 = true *) apply eqb_true in Heqe3.
      rewrite -> Heqe3. reflexivity.
    - (* e3 = false *)
     (* 当我们到达正在推理的函数体中第二个相等关系测试时，我们可以再次使用
        eqn:，以便结束此证明。 *)
      destruct (n = 5) eqn:Heqe5.
        + (* e5 = true *)
          apply eqb_true in Heqe5.
          rewrite -> Heqe5. reflexivity.
        + (* e5 = false *) discriminate eq. Qed.

Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros. destruct b.
  - destruct (f true) eqn:eq1.
    + destruct (f true) eqn:eq2.
      * destruct (f true) eqn:eq3.
       -- reflexivity.
       -- discriminate eq2.
      * destruct (f false) eqn:eq4.
       -- reflexivity.
       -- discriminate eq1.
    + destruct (f false) eqn:eq5.
      * destruct (f true) eqn:eq3.
       -- discriminate eq1.
       -- reflexivity.
      * destruct (f false) eqn:eq4.
       -- discriminate eq5.
       -- reflexivity.
  - destruct (f false) eqn:eq1.
    + destruct (f true) eqn:eq2.
      * destruct (f true) eqn:eq3.
       -- reflexivity.
       -- discriminate eq2.
      * destruct (f false) eqn:eq4.
       -- reflexivity.
       -- discriminate eq1.
    + destruct (f false) eqn:eq5.
      * destruct (f true) eqn:eq3.
       -- discriminate eq1.
       -- reflexivity.
      * destruct (f false) eqn:eq4.
       -- discriminate eq5.
       -- reflexivity.
Qed.

Theorem eqb_sym : forall (n m : nat),
  (n = m) = (m = n).
Proof.
  intros n. induction n.
  - intros m. induction m.
    + reflexivity.
    + injection IHm.
  (* 请在此处解答 *) Admitted.


Require Import full_angle.

Section hypothesis_t_rules.

  (*Generalizable Variables Tpoint Quad_tpoint p_para p_perp Col p_med Concyclic
                is_circumcenter p_midp build_FA FZero FOne Fadd
                FMinus FEq.*)
  Context `{F:FA_Full_angle_ax}.

  Definition fp_Foot (O C A B : FA_Point) : Prop :=
    (FA_P_col O A B) /\ (FA_P_perp O C A B).

  (*Definition fp_Cong (A B C D : FA_Point) *)

End hypothesis_t_rules.

Print fp_Foot.


Require Import List.
Require Import Arith.
Import ListNotations.

Definition serializer (A: Type) := A -> list bool.
Definition deserializer (A: Type) := list bool -> option (A * nat).
Definition ser_deser_spec (A: Type) (ser : serializer A) (deser : deserializer A) :=
  forall a : A, forall bools : list bool,
      deser (ser a ++ bools) = Some (a, length (ser a)).

Class Serializer (A : Type) : Type :=
  {
    serialize : A -> list bool;
    deserialize : list bool -> option (A * nat);
    deser_ser_identity : ser_deser_spec A serialize deserialize
  }.

(* I couldn't find a suitable theorem in the coq standard library *)
Theorem skipn_length : forall (A : Type) (l1 l2 : list A),
  skipn (length l1) (l1 ++ l2) = l2.
Proof.
induction l1; intros.
- trivial.
- simpl.
  apply IHl1.
Qed.

Section BoolSerializer.
Definition bool_serialize (b : bool): list bool := [b].

Definition bool_deserialize (bools : list bool): option(bool * nat) :=
  match bools with
  | [] => None
  | h :: t => Some(h, 1)
  end.

Lemma bool_deser_ser_identity : ser_deser_spec bool bool_serialize bool_deserialize.
Proof.
  unfold ser_deser_spec.
  intros.
  simpl.
  reflexivity.
Qed.

Instance BoolSerializer : Serializer bool.
Proof.
exact {| serialize := bool_serialize;
         deserialize := bool_deserialize;
         deser_ser_identity := bool_deser_ser_identity;
       |}.
Defined.
End BoolSerializer.

Section PairSerializer.
Variable A B : Type.
Variable serA : Serializer A.
Variable serB : Serializer B.

Definition pair_serialize (p : A * B) : list bool :=
  serialize (fst p) ++ serialize (snd p).

Definition pair_deserialize (bools : list bool) : option ((A * B) * nat) :=
  match (deserialize bools) with
  | Some (a, amt1) =>
    match (deserialize (skipn amt1 bools)) with
    | Some (b, amt2) => Some( (a, b), amt1 + amt2)
    | None => None
    end
  | None => None
  end.

Theorem pair_ser_deser_identity :
  ser_deser_spec (A * B) pair_serialize pair_deserialize.
Proof.
  unfold ser_deser_spec.
  intros.
  unfold pair_serialize.
  rewrite app_ass.
  unfold pair_deserialize.
  rewrite deser_ser_identity.
  rewrite skipn_length.
  rewrite deser_ser_identity.
  rewrite <- surjective_pairing.
  rewrite app_length.
  reflexivity.
Qed.

End PairSerializer.

Section NatSerializer.

Fixpoint nat_serialize (n : nat) : list bool :=
  match n with
  | O => [false]
  | S n => [true] ++ (nat_serialize n)
  end.

Fixpoint nat_deserialize (bools : list bool) : option (nat * nat) :=
  match bools with
  | true :: bools =>
    match (nat_deserialize bools) with
    | None => None
  (* Remark: n = remaining + 1 here for this specific deser/ser pair *)
    | Some (n, amt) => Some (S n, S amt)
    end
  | false :: bools => Some (O, 1)
  | [] => None
  end.

Theorem nat_ser_deser_identity :
  ser_deser_spec nat nat_serialize nat_deserialize.
Proof.
  unfold ser_deser_spec.
  induction a; intros.
  - trivial.
  - simpl.
    rewrite IHa.
    reflexivity.
Qed.

End NatSerializer.

Section ListSerializer.
Variable A : Type.
Variable serA : Serializer A.

Fixpoint list_serialize (l : list A) : list bool :=
  match l with
  | [] => [false]
  | h :: t => [true] ++ serialize h ++ list_serialize t
  end.

Fixpoint list_deserialize (bools : list bool) :  option (list A * nat) :=
  match bools with
  | false :: _ => Some ([], 1)
  | true :: bools =>
    match (deserialize bools) with
    | None => None
    | Some (n, amtElem) =>
      match (list_deserialize (skipn amtElem bools)) with
      | None => None
      | Some (tail, amtRest) => Some (n :: tail, amtElem + amtRest)
      end
    end
  | _ => None
  end.

Theorem list_ser_deser_identity :
  ser_deser_spec_ (list nat) list_serialize list_deserialize.
Proof.
  unfold ser_deser_spec_.
  intros.
  unfold list_serialize, list_deserialize.
  rewrite app_ass.
  rewrite nat_ser_deser_identity.
  induction a as [|h t]. (* TODO was l, now a *)
  - trivial.
  - simpl.
    rewrite app_ass.
    rewrite nat_ser_deser_identity. (* Element ser/deser identity *)
    rewrite IHt.
    reflexivity.
Qed.

End ListSerializer.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__betweennotequal.
Require Export lemma__equalitysymmetric.
Require Export lemma__extension.
Require Export logic.
Definition lemma__layoff : forall A B C D, (euclidean__axioms.neq A B) -> ((euclidean__axioms.neq C D) -> (exists X, (euclidean__defs.Out A B X) /\ (euclidean__axioms.Cong A X C D))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
intro H0.
assert (* Cut *) (~(B = A)) as H1.
- intro H1.
assert (* Cut *) (A = B) as H2.
-- apply (@lemma__equalitysymmetric.lemma__equalitysymmetric A B H1).
-- apply (@H H2).
- assert (* Cut *) (exists E, (euclidean__axioms.BetS B A E) /\ (euclidean__axioms.Cong A E C D)) as H2.
-- apply (@lemma__extension.lemma__extension B A C D H1 H0).
-- destruct H2 as [E H3].
destruct H3 as [H4 H5].
assert (* Cut *) (euclidean__axioms.BetS E A B) as H6.
--- apply (@euclidean__axioms.axiom__betweennesssymmetry B A E H4).
--- assert (* Cut *) (euclidean__axioms.neq E A) as H7.
---- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq E A) /\ (euclidean__axioms.neq E B))) as H7.
----- apply (@lemma__betweennotequal.lemma__betweennotequal E A B H6).
----- destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exact H10.
---- assert (euclidean__axioms.BetS E A B) as H8 by exact H6.
assert (* Cut *) (exists P, (euclidean__axioms.BetS E A P) /\ (euclidean__axioms.Cong A P C D)) as H9.
----- apply (@lemma__extension.lemma__extension E A C D H7 H0).
----- destruct H9 as [P H10].
destruct H10 as [H11 H12].
assert (* Cut *) (euclidean__defs.Out A B P) as H13.
------ exists E.
split.
------- exact H11.
------- exact H8.
------ exists P.
split.
------- exact H13.
------- exact H12.
Qed.


(* 二つの自然数の和を返す *)
(* Definition plus (n m : nat) : nat := n + m. *)

Definition plus n m := n + m.

Definition plus' : nat -> nat -> nat := fun n m => n + m.

Definition id (A : Type)(x : A) : A := x.

Definition id' : forall (A : Type), A -> A := fun A x => x.

Definition prop0' : forall (A : Prop), A -> A := fun A x => x.

Definition prop1 : forall (A B C : Prop), (B -> C) -> (A -> B) -> (A -> C) := fun A B C f g x => f (g x).

(* Definition prop2 : forall (A : Type)(l1 l2 l3 : List A), app l1 l3 = app l2 l3 -> l1 = l2 := ここに定義が入る. *)

Definition prop2 : forall (A B : Prop), A -> (A -> B) -> B := fun A B a b => b a.

(*
Definition prop3 : forall (A B C : Prop), ((A -> B) -> C) -> ((B -> A) -> C) := fun
 *)

(*
Goal forall (A B C : Prop), ((A -> B) -> C) -> ((B -> A) -> C).
  intros.
  apply H.
  intro.
 *)

(*
Goal forall (A B C : Prop), ((A -> B) -> C) -> ((B -> A) -> C) := fun A B C D (a b) (c d) =>
 *)

Definition problem0 : forall (A B : Prop), A -> (A -> B) -> B :=
  fun A B x f => f x.

(*
Definition problem1 : forall (A B C : Prop), (A -> B -> C) -> (B -> A -> C) :=
  fun A B C f b a => f a b.
 *)


Load Common.

Require Import FormulaFacts.
Require Export Derivations.
Require Export Encoding.
Require Export Diophantine.
Require Import UserTactics.
Require Import MiscFacts.
Require Import Psatz. (*lia : linear integer arithmetic*)

Require Import ListFacts.
Import Encoding.

(*Notation "x ==> y" := (arr x y) (at level 0).*)

Lemma instantiate_quant (m : nat) : forall (Γ : list formula) (s : formula),
  derivation Γ (quant s) -> derivation Γ (instantiate (represent_nat m) 0 s).
Proof.
intros.
apply : elim_quant; first eassumption.
apply : (contains_trans (s := represent_nat m)); constructor.
Qed.

Fixpoint rev_seq (last len:nat) : list nat :=
    match len with
      | 0 => nil
      | Datatypes.S len' => last :: rev_seq (Nat.pred last) len'
    end.

Lemma in_rev_seq : forall (last len n : nat), n <= last -> n > (last-len) -> In n (rev_seq last len).
Proof.
move => last len.
elim : len last.
intros; omega.

move => len IH last n *.
have : n = last \/ n < last by omega.
case; cbn; first auto.
intros; right; apply : IH; omega.
Qed.

(*representations of numbers 1 .. (1+bound)*)
Definition universe (bound : nat) := map (fun m => (U (represent_nat m))) (rev_seq (1+bound) (1+bound)).

(*representations of sums*)
Notation "x |+| y" := (S (represent_nat x) (represent_nat y) (represent_nat (y+x))) (at level 0).
(*representations of products*)
Notation "x |*| y" := (P (represent_nat x) (represent_nat y) (represent_nat (y*x))) (at level 0).
(*representations of successor equalities 1+1=2 .. bound+1='bound+1'*)
Definition successors (bound : nat) := map (fun m' => m' |+| 1) (rev_seq bound bound).
Definition product_identities (bound : nat) := map (fun m' => (m' |*| 1)) (rev_seq (1+bound) (1+bound)).

Definition represent_diophantine_eval (f : nat -> nat) (d : diophantine) : formula :=
  match d with
  | dio_one x => P (represent_nat (1 + f x)) (represent_nat (1 + f x)) one
  | dio_sum x y z => S (represent_nat (1 + f x)) (represent_nat (1 + f y)) (represent_nat (1 + f z))
  | dio_prod x y z => P (represent_nat (1 + f x)) (represent_nat (1 + f y)) (represent_nat (1 + f z))
  end.

Definition represent_diophantine_f (f : nat -> nat) (d : diophantine) (t : formula) : formula :=
  match d with
  | dio_one x => arr (U (represent_nat (1 + f x))) (arr (P (represent_nat (1 + f x)) (represent_nat (1 + f x)) one) t)
  | dio_sum x y z => arr (U (represent_nat (1 + f x))) (arr (U (represent_nat (1 + f y))) (arr (U (represent_nat (1 + f z))) (arr (S (represent_nat (1 + f x)) (represent_nat (1 + f y)) (represent_nat (1 + f z))) t)))
  | dio_prod x y z => arr (U (represent_nat (1 + f x))) (arr (U (represent_nat (1 + f y))) (arr (U (represent_nat (1 + f z))) (arr (P (represent_nat (1 + f x)) (represent_nat (1 + f y)) (represent_nat (1 + f z))) t)))
  end.

Fixpoint represent_diophantines_f (f : nat -> nat) (ds : list diophantine) : formula :=
  match ds with
  | [] => triangle
  | d :: ds' => represent_diophantine_f f d (represent_diophantines_f f ds')
  end.

Lemma instantiate_diophantine_representation : forall (f : nat -> nat) (ds : list diophantine), contains (s_x_d ds) (arr (arr triangle triangle) (represent_diophantines_f f ds)).
Proof.
move => f ds.
set g := fun x => Some (represent_nat (1 + f x)).

have : (arr (arr triangle triangle) (represent_diophantines_f f ds)) = instantiate_prenex g (arr (arr triangle triangle) (represent_diophantines ds)).
unfold instantiate_prenex. f_equal. fold instantiate_prenex.
revert dependent ds.
elim; [auto | case ].

1-3 : intros; cbn; do ? f_equal.
1-3 : eauto using lc_represent_diophantines.

move => ->.
apply : contains_prenex_instantiation.
eauto using lc, lc_represent_diophantines.
move => m Hm.
exists (represent_nat (1 + f m)).
eauto using lc.
Qed.

Lemma diophantine_bound_lt : forall (ds : list diophantine) (d : diophantine), In d ds ->
  match d with
  | dio_one x => x < diophantine_variable_bound ds
  | dio_sum x y z | dio_prod x y z =>
    x < diophantine_variable_bound ds /\ y < diophantine_variable_bound ds /\ z < diophantine_variable_bound ds
  end.
Proof.
elim. done.

move => d' ds IH.
case => [x|x y z|x y z].
1-3: move /(@in_cons_iff diophantine).

1-3: case; first (move => ->; cbn; lia).
1-3: move => Hd.
2-3: split; last split.
all : have : forall (d : diophantine) (ds : list diophantine) (x : nat),
  x < diophantine_variable_bound ds ->
  x < diophantine_variable_bound (d :: ds) by case; intros; cbn; lia.
all : apply.
all : have := (IH _ Hd); tauto.
Qed.

Lemma diophantine_restricted_eval : forall (ds : list diophantine) (f : nat -> nat),
  let g := fun x => if x <? diophantine_variable_bound ds then f x else 0 in
  forall (ds' : list diophantine), (forall (d : diophantine), In d ds' -> In d ds) ->
  forall (d : diophantine), In d ds' -> Diophantine.eval g d = Diophantine.eval f d.
Proof.
move => ds f g.
elim.
cbn. done.

case.
1: move => x'.
2-3:  move => x' y' z'.
1-3: move => ds' IH Hds' d'.
1-3: move /(@in_cons_iff diophantine).
1-3: case; last ((apply : IH); auto using in_cons).
1-3: move => <-; cbn.

1: have Hd' : In (dio_one x') ds by (apply : Hds'; list_inclusion).
2: have Hd' : In (dio_sum x' y' z') ds by (apply : Hds'; list_inclusion).
3: have Hd' : In (dio_prod x' y' z') ds by (apply : Hds'; list_inclusion).

1-3: have := diophantine_bound_lt Hd'.
1-3: subst g.

1: move /Nat.ltb_lt => ->.
2-3: move => [Hx' [Hy' Hz']].
2-3: move /Nat.ltb_lt : Hz' => ->.
2-3: move /Nat.ltb_lt : Hy' => ->.
2-3: move /Nat.ltb_lt : Hx' => ->.
1-3: auto.
Qed.

Lemma diophantine_restricted_bound : forall (f : nat -> nat) (n : nat),
  let g := fun x => if x <? n then f x else 0 in
  exists (bound : nat), forall (x : nat), g x <= bound.
Proof.
move => f.
elim.
cbn.
exists 0. auto.

intros.
move : H => [b' Hb'].
exists (b' + f n).
move => x. subst g.
have : x = n \/ x < n \/ ~(x < Datatypes.S n) by omega.
(case; last case) => Hx.
have : x < Datatypes.S n by omega.
move /Nat.ltb_lt => ->; subst; lia.
move : (Hb' x).
move /Nat.ltb_lt : (Hx) => ->.
(have : x < Datatypes.S n by omega); move /Nat.ltb_lt => ->.
lia.
move : Hx.
rewrite <- Nat.ltb_lt.
case : (x <? Datatypes.S n); [done | intros; omega].
Qed.

Lemma finite_solution : forall (ds : list diophantine), Diophantine.solvable ds ->
  exists (bound : nat) (g : nat -> nat), Forall (fun d => Diophantine.eval g d = true) ds /\ (forall (x : nat), g x <= bound).
Proof.
move => ds. case. move => [f Hf].
have := diophantine_restricted_bound f (diophantine_variable_bound ds).
set g := fun x => if x <? diophantine_variable_bound ds then f x else 0.
move => [bound Hg2].
exists bound, g.
split; auto.
have : forall (d : diophantine), In d ds -> Diophantine.eval g d = Diophantine.eval f d.
apply : diophantine_restricted_eval; auto.
move : Hf.
rewrite -> ? Forall_forall; eauto.
Qed.

Lemma in_successors : forall (bound : nat) (m : nat), m > 0 ->  m <= bound -> In (m |+| 1) (successors bound).
Proof.
elim.
intros; omega.
move => bound IH m ? ?.
have : m = 1 + bound \/ m < 1 + bound by omega.
case; move => ?; subst; cbn.
by left.
right. apply : IH; omega.
Qed.

Lemma in_product_identities : forall (bound : nat) (m : nat), m > 0 ->  m <= 1+bound -> In (m |*| 1) (product_identities bound).
Proof.
elim.
intros.
have ? : m = 1 by omega. subst.
cbn; auto.

move => bound IH m ? ?.
have : m = 2 + bound \/ m < 2 + bound by omega.
case; move => ?; subst; cbn.
by left.
right. apply : IH; omega.
Qed.

Lemma in_universe : forall (bound : nat) (m : nat), m >= 1 -> m <= 1+bound -> In (U (represent_nat m)) (universe bound).
Proof.
elim.
intros.
left.
do ? f_equal. omega.
move => bound IH m ? ?.
have : m = 2 + bound \/ m < 2 + bound by omega.
case; move => ?; subst; cbn.
by left.
right. apply : IH; omega.
Qed.

(*to derive triangle from simpler ΓU, suffices to derive triangle from more complex ΓU. phase 1*)
Theorem completeness_U (ds : list diophantine) : forall (bound : nat),
  let ΓS := successors bound in
  let ΓP := product_identities bound in
  derivation (ΓI ds ++ universe bound ++ ΓS ++ ΓP) triangle ->
  derivation (ΓI ds ++ [U one; P one one one]) triangle.
Proof.
elim.
move => ΓS ΓP.
apply.
set ΓI_ds := ΓI ds.

move => bound IH ΓS ΓP HD.
apply : (IH); try reflexivity.
set ΓU' := universe bound.
set ΓS' := successors bound.
set ΓP' := product_identities bound.
set Γ' := ΓI_ds ++ ΓU' ++ ΓS' ++ ΓP'.

have : derivation (Γ') s_x_u by derivation_rule.
move /(instantiate_quant (1+bound)).

autorewrite with simplify_formula.

move /elim_arr.
nip.

have ? : In (U (represent_nat (1 + bound))) ΓU' by subst; list_inclusion.
derivation_rule.

move /elim_arr.
nip; last done.

apply : (intro_quant_fresh (a:=get_label (represent_nat (2 + bound)))).
(*finniky*)
subst Γ'.
apply Forall_app; split.

(*ΓI*) subst ΓI_ds; clear.
inspect_freshness.
elim ds.
inspect_freshness.
intros; gimme diophantine; case; intros; cbn; inspect_freshness; auto.

have : 2 + bound > 1 + bound by omega.
move : (2 + bound) => n Hn.
apply Forall_app; split.

(*ΓU*) move : Hn; subst ΓU'; clear.
elim : bound n; cbn; intros; (constructor; [inspect_freshness | auto with arith]).

apply Forall_app; split.

(*ΓS*) move : Hn; subst ΓS'; clear.
elim : bound n; cbn; intros; constructor; [inspect_freshness | auto with arith].

(*ΓP*) move : Hn; subst ΓP'; clear.
elim : bound n; cbn; intros; (constructor; [inspect_freshness | auto with arith]).

(*freshness in goal*)
inspect_freshness.

have : atom (get_label (represent_nat (2 + bound))) = represent_nat (2 + bound) by reflexivity.
move => ->.
autorewrite with simplify_formula.
do 3 (apply : intro_arr).
apply : (weakening HD).

have : ΓP = P (represent_nat (2 + bound)) one (represent_nat (2 + bound)) :: ΓP' by cbn; (do ? f_equal); omega.
move => ->.
list_inclusion.
Qed.

Theorem completeness_S (ds : list diophantine) : forall (bound : nat) (m1 m2 : nat) (Γ' : list formula),
  (1+m1)+(1+m2) <= 1+bound ->
  let ΓS := successors bound in
  let ΓP := product_identities bound in
  derivation (ΓI ds ++ (universe bound) ++ ΓS ++ ΓP ++ (((1+m1) |+| (1+m2)) :: Γ')) triangle ->
  derivation (ΓI ds ++ (universe bound) ++ ΓS ++ ΓP ++ Γ') triangle.
Proof.
move => bound m1 m2.
elim : m2 m1 => [|m2 IH] => m1 Γ' Hm1m2 ΓS ΓP HD.
apply : (weakening HD).
move => s.
have : In ((1 + m1) |+| (1 + 0)) ΓS by apply : in_successors; omega.
list_inclusion.

apply : IH.
have : 1 + m1 + (1 + m2) ≤ 1 + bound by omega. apply.
fold ΓS.
set Γ := ΓI ds ++ universe bound ++ ΓS ++ ΓP ++ ((1 + m1) |+| (1 + m2) :: Γ').
have : derivation Γ s_x_s by derivation_rule.

move /(instantiate_quant (1+m1)).
move /(instantiate_quant (1+m2)).
move /(instantiate_quant (1 + m2 + (1 + m1))).
move /(instantiate_quant (2+m2)).
move /(instantiate_quant ((2+m2)+(1+m1))).
autorewrite with simplify_formula.

do_first 9 (move /elim_arr; nip; first last).
apply.

apply /intro_arr.
apply : (weakening HD).
list_inclusion.

1-2 : apply : ax.
1-2 : apply : (in_sub (A := successors bound)); try list_inclusion.
1-2 : apply /in_successors; omega.

apply : ax. list_inclusion.

1-5 : apply : ax.
1-5 : apply : (in_sub (A := universe bound)); try list_inclusion.
1-5 : apply /in_universe; omega.
Qed.

Theorem completeness_P (ds : list diophantine) : forall (bound : nat) (m1 m2 : nat) (Γ' : list formula),
  (1+m1)*(1+m2) <= 1+bound ->
  let ΓS := successors bound in
  let ΓP := product_identities bound in
  derivation (ΓI ds ++ (universe bound) ++ ΓS ++ ΓP ++ (((1+m1) |*| (1+m2)) :: Γ')) triangle ->
  derivation (ΓI ds ++ (universe bound) ++ ΓS ++ ΓP ++ Γ') triangle.
Proof.
move => bound m1 m2.
elim : m2 m1 => [|m2 IH] => m1 Γ' Hm1m2 ΓS ΓP HD.
apply : (weakening HD).
move => s.
have : In ((1 + m1) |*| (1 + 0)) ΓP by apply : in_product_identities; omega.
list_inclusion.

apply : IH.
have : (1 + m1) * (1 + m2) ≤ 1 + bound by nia. apply.
fold ΓS ΓP.
apply : (completeness_S (m1:=m1+m2+m1*m2) (m2:=m1)).
nia.
set Γ := ΓI ds ++ universe bound ++ ΓS ++ ΓP ++ ((1 + (m1 + m2 + m1 * m2)) |+| (1 + m1) :: (1 + m1) |*| (1 + m2) :: Γ').
have : derivation Γ s_x_p by derivation_rule.

move /(instantiate_quant (1+m1)).
move /(instantiate_quant (1+m2)).
move /(instantiate_quant ((1 + m2) * (1 + m1))).
move /(instantiate_quant (2+m2)).
move /(instantiate_quant ((2+m2)*(1+m1))).
autorewrite with simplify_formula.

do_first 9 (move /elim_arr; nip; first last).
move => H'.
apply : (weakening H').
list_inclusion.

apply /intro_arr.
apply : (weakening HD).
list_inclusion.

apply : ax.
apply : (in_sub (A := [(1 + (m1 + m2 + m1 * m2)) |+| (1 + m1)])); [left | list_inclusion].
f_equal; f_equal; nia.

apply : ax.
apply : (in_sub (A := successors bound)); try list_inclusion.
apply /in_successors; nia.

apply : ax. list_inclusion.

1-5 : apply : ax.
1-5 : apply : (in_sub (A := universe bound)); try list_inclusion.
1-5 : apply /in_universe; nia.
Qed.

Lemma completeness : forall (ds : list diophantine), Diophantine.solvable ds ->
  derivation (ΓI ds ++ [U one; P one one one]) triangle.
Proof.
move => ds.
move /finite_solution => [bound [g [Hg1 Hg2]]].
apply : (completeness_U (bound:=bound)).
set Γ' := map (represent_diophantine_eval g) ds.
set ΓU := universe bound.
set ΓS := successors bound.
set ΓP := product_identities bound.

(*extent type environment by necessary assumptions*)
suff : derivation (ΓI ds ++ ΓU ++ ΓS ++ ΓP ++ Γ') triangle.

move : (ds) => ds'.
revert dependent ds.
elim.
move => ? ? HD.
apply : (weakening HD). list_inclusion.
case.

1 : move => x ds IH.
2-3 : move => x y z ds IH.
1-3 : move /(@Forall_cons diophantine) => [Hd ?].
1-3 : move /Nat.eqb_eq in Hd.
1-3 : move => Γ' HD.
1-3 : apply : (IH); try assumption.
1-3 : cbn in Γ'.

2-3 : have ? := (Hg2 z).
1 : have ? : (1 + g x) * (1 + g x) ≤ 1 + bound by nia.
2 : have ? : (1 + g x) + (1 + g y) ≤ 1 + bound by nia.
3 : have ? : (1 + g x) * (1 + g y) ≤ 1 + bound by nia.
1 : apply : (completeness_P); try eassumption.
2 : apply : (completeness_S); try eassumption.
3 : apply : (completeness_P); try eassumption.

1 : have : (1 + g x) |*| (1 + g x) = P (represent_nat (Datatypes.S (g x))) (represent_nat (Datatypes.S (g x))) one
  by cbn; unfold one; (do ? f_equal); nia.
2 : have : (1 + g x) |+| (1 + g y) = S (represent_nat (Datatypes.S (g x))) (represent_nat (Datatypes.S (g y))) (represent_nat (Datatypes.S (g z)))
  by cbn; unfold one; (do ? f_equal); nia.
3 : have : (1 + g x) |*| (1 + g y) = P (represent_nat (Datatypes.S (g x))) (represent_nat (Datatypes.S (g y))) (represent_nat (Datatypes.S (g z)))
  by cbn; unfold one; (do ? f_equal); nia.
1-3 : move => ->; assumption.

(*show derivability in extgended environment*)
have : derivation (ΓI ds ++ ΓU ++ ΓS ++ ΓP ++ Γ') (s_x_d ds) by derivation_rule.

move /(elim_quant).
move /(_ _ (instantiate_diophantine_representation g ds)).

move /elim_arr; nip; first derivation_rule.
move : (ΓI ds) => ΓI_ds.
have : forall s, In s (map (represent_diophantine_eval g) ds) -> In s Γ' by auto.
move : (Γ') => {Γ'} Γ'.
(*induction not entirely clear, Gamma' changes?*)
revert dependent ds.
elim; first auto.
case.

1 : move => x ds IH.
2-3 : move => x y z ds IH.
2-3 : have ? := Hg2 z.
1-3 : move /(@Forall_cons diophantine) => [Hd ?] HΓ' HD.
1-3 : move /Nat.eqb_eq in Hd.
1-3 : cbn in HΓ'.
1-3 : apply : IH; try assumption + auto.
1-3 : gimme derivation.
1-3 : unfold represent_diophantines_f; fold represent_diophantines_f; unfold represent_diophantine_f.

1 : (do_first 2 (move /elim_arr; nip; first last)); first apply.
3-4 : (do_first 4 (move /elim_arr; nip; first last)); first apply.

all : match goal with
  | [ |- derivation _ (U _) ] => apply (weakening (Γ:=ΓU)); last list_inclusion
  | [ |- derivation _ (P _ _ _) ] => apply (weakening (Γ:=Γ')); last list_inclusion
  | [ |- derivation _ (S _ _ _) ] => apply (weakening (Γ:=Γ')); last list_inclusion
end.

all : apply ax; auto.
all : apply : in_universe; lia + nia.
Qed.


Require Import Nijn.Nijn.

Open Scope poly_scope.

(** The base types *)
Inductive base_types :=
| TBtype
| TList.

Global Instance decEq_base_types : decEq base_types.
Proof.
  decEq_finite.
Defined.

Definition Btype := Base TBtype.
Definition List := Base TList.

(** The function symbols and their arities *)
Inductive fun_symbols :=
| TNil
| TCons
| TMap.

Global Instance decEq_fun_symbols : decEq fun_symbols.
Proof.
  decEq_finite.
Defined.

Definition map_ar f
  := match f with
     | TNil => List
     | TCons => Btype ⟶ List ⟶ List
     | TMap => (Btype ⟶ Btype) ⟶ List ⟶ List
     end.

Definition Nil {C} : tm map_ar C _ := BaseTm TNil.
Definition Cons {C} : tm map_ar C _ := BaseTm TCons.
Definition Map {C} : tm map_ar C _ := BaseTm TMap.

(** The rewrite rules *)
Program Definition map_nil :=
  make_rewrite
    (_ ,, ∙) _
    (Map · V 0 · Nil)
    Nil.

Program Definition map_cons :=
  make_rewrite
    (_ ,, _ ,, _ ,, ∙) _
    (Map · V 0 · (Cons · V 1 · V 2))
    (Cons · (V 0 · V 1) · (Map · V 0 · V 2)).

(** The AFS *)
Definition map_afs :=
  make_afs
    map_ar
    (map_nil :: map_cons :: nil).

(** The polynomials *)
Definition map_fun_poly f : poly ∙ (arity map_afs f) :=
  match f with
  | TNil => to_Poly (P_const 2)
  | TCons =>
    λP let y0 := P_var (Vz) in
    λP let y1 := P_var (Vs Vz) in
    to_Poly (P_const 3 + y0 + y1)
  | TMap =>
    λP let y0 := P_var Vz in
    λP let G1 := P_var (Vs Vz) in
    to_Poly (P_const 3 + P_const 3 * y0 + G1 ·P y0 + P_const 3 * y0 * G1 ·P y0)
  end.

(** Strong normalization *)
Theorem map_isSN : isSN map_afs.
Proof.
  certificate_SN.
  rule_removal_certificate (0 :: nil).
  { poly_certificate map_fun_poly. }
  rule_removal_certificate (0 :: nil).
  { poly_certificate map_fun_poly. }
  empty_certificate.
Qed.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 12: Hoare Logic: Verifying Imperative Programs
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

(** * Syntax and semantics of a simple imperative language *)

(* Here's some appropriate syntax for expressions (side-effect-free) of a simple
 * imperative language with a mutable memory. *)
Inductive exp :=
| Const (n : nat)
| Var (x : string)
| Read (e1 : exp)
| Plus (e1 e2 : exp)
| Minus (e1 e2 : exp)
| Mult (e1 e2 : exp).

(* Those were the expressions of numeric type.  Here are the Boolean
 * expressions. *)
Inductive bexp :=
| Equal (e1 e2 : exp)
| Less (e1 e2 : exp)
| Or (e1 e2 : bexp).

Definition heap := fmap nat nat.
Definition valuation := fmap var nat.
Definition assertion := heap -> valuation -> Prop.

(* Here's the syntax of side-effecting commands, where we attach an assertion to
 * every "while" loop, for reasons that should become clear later.  The
 * assertion is ignored in the operational semantics! *)
Inductive cmd :=
| Skip
| Assign (x : var) (e : exp)
| Write (e1 e2 : exp)
| Seq (c1 c2 : cmd)
| If_ (be : bexp) (then_ else_ : cmd)
| While_ (inv : assertion) (be : bexp) (body : cmd)

(* And one more, which we'll use to characterize program correctness more
 * simply: *)
| Assert (a : assertion).

(* Shorthand notation for looking up in a finite map, returning zero if the key
 * is not found *)
Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).

(* Start of expression semantics: meaning of expressions *)
Fixpoint eval (e : exp) (h : heap) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x => v $! x
  | Read e1 => h $! eval e1 h v
  | Plus e1 e2 => eval e1 h v + eval e2 h v
  | Minus e1 e2 => eval e1 h v - eval e2 h v
  | Mult e1 e2 => eval e1 h v * eval e2 h v
  end.

(* Meaning of Boolean expressions *)
Fixpoint beval (b : bexp) (h : heap) (v : valuation) : bool :=
  match b with
  | Equal e1 e2 => if eval e1 h v ==n eval e2 h v then true else false
  | Less e1 e2 => if eval e2 h v <=? eval e1 h v then false else true
  | Or e1 e2 => beval e1 h v || beval e2 h v
  end.

(* A big-step operational semantics for commands *)
Inductive exec : heap -> valuation -> cmd -> heap -> valuation -> Prop :=
| ExSkip : forall h v,
  exec h v Skip h v
| ExAssign : forall h v x e,
  exec h v (Assign x e) h (v $+ (x, eval e h v))
| (* XXX *) ExWrite : forall h v e1 e2,
  exec h v (Write e1 e2) (h $+ (eval e1 h v, eval e2 h v)) v
| ExSeq : forall h1 v1 c1 h2 v2 c2 h3 v3,
  exec h1 v1 c1 h2 v2
  -> exec h2 v2 c2 h3 v3
  -> exec h1 v1 (Seq c1 c2) h3 v3
| ExIfTrue : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = true
  -> exec h1 v1 c1 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExIfFalse : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = false
  -> exec h1 v1 c2 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExWhileFalse : forall I h v b c,
  beval b h v = false
  -> exec h v (While_ I b c) h v
| ExWhileTrue : forall I h1 v1 b c h2 v2 h3 v3,
  beval b h1 v1 = true
  -> exec h1 v1 c h2 v2
  -> exec h2 v2 (While_ I b c) h3 v3
  -> exec h1 v1 (While_ I b c) h3 v3

(* Assertions execute only when they are true.  They provide a way to embed
 * proof obligations within programs. *)
| ExAssert : forall h v (a : assertion),
  a h v
  -> exec h v (Assert a) h v.

(** * Hoare logic *)

(* Here's an inductive predicate capturing a class of *proved* specifications
 * for commands.  The intuition is that, when [hoare_triple P c Q], we know
 * that, when we start [c] in a state satisfying [P], if [c] finishes, its final
 * state satisfies [Q]. *)

Inductive hoare_triple : assertion -> cmd -> assertion -> Prop :=
| HtSkip : forall P, hoare_triple P Skip P
| (* XXX *) HtAssign : forall (P : assertion) x e,
  hoare_triple P (Assign x e) (fun h v => exists v', P h v' /\ v = v' $+ (x, eval e h v'))
| HtWrite : forall (P : assertion) (e1 e2 : exp),
  hoare_triple P (Write e1 e2) (fun h v => exists h', P h' v /\ h = h' $+ (eval e1 h' v, eval e2 h' v))
| HtSeq : forall (P Q R : assertion) c1 c2,
  hoare_triple P c1 Q
  -> hoare_triple Q c2 R
  -> hoare_triple P (Seq c1 c2) R
| HtIf : forall (P Q1 Q2 : assertion) b c1 c2,
  hoare_triple (fun h v => P h v /\ beval b h v = true) c1 Q1
  -> hoare_triple (fun h v => P h v /\ beval b h v = false) c2 Q2
  -> hoare_triple P (If_ b c1 c2) (fun h v => Q1 h v \/ Q2 h v)
| HtWhile : forall (I P : assertion) b c,
  (forall h v, P h v -> I h v)
  -> hoare_triple (fun h v => I h v /\ beval b h v = true) c I
  -> hoare_triple P (While_ I b c) (fun h v => I h v /\ beval b h v = false)
| HtAssert : forall P I : assertion,
  (forall h v, P h v -> I h v)
  -> hoare_triple P (Assert I) P
| (* XXX *) HtConsequence : forall (P Q P' Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, P' h v -> P h v)
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P' c Q'.

(* Let's prove that the intuitive description given above really applies to this
 * predicate.  First, a lemma, which is difficult to summarize intuitively!
 * More or less precisely this obligation shows up in the main proof below. *)
Lemma hoare_triple_big_step_while: forall (I : assertion) b c,
  (forall h v h' v', exec h v c h' v'
                     -> I h v
                     -> beval b h v = true
                     -> I h' v')
  -> forall h v h' v', exec h v (While_ I b c) h' v'
                       -> I h v
                       -> I h' v' /\ beval b h' v' = false.
Proof.
  induct 2; eauto.
Qed.

(* That main theorem statement literally translates our intuitive description of
 * [hoare_triple] from above. *)
Theorem hoare_triple_big_step : forall pre c post,
    hoare_triple pre c post
    -> forall h v h' v', exec h v c h' v'
                         -> pre h v
                         -> post h' v'.
Proof.
  induct 1; eauto; invert 1; eauto.

  simplify.
  eapply hoare_triple_big_step_while; eauto.
Qed.

(* BEGIN syntax macros that won't be explained *)
Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
Notation "*[ e ]" := (Read e) : cmd_scope.
Infix "+" := Plus : cmd_scope.
Infix "-" := Minus : cmd_scope.
Infix "*" := Mult : cmd_scope.
Infix "=" := Equal : cmd_scope.
Infix "<" := Less : cmd_scope.
Definition set (dst src : exp) : cmd :=
  match dst with
  | Read dst' => Write dst' src
  | Var dst' => Assign dst' src
  | _ => Assign "Bad LHS" 0
  end.
Infix "<-" := set (no associativity, at level 70) : cmd_scope.
Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
Notation "'when' b 'then' then_ 'else' else_ 'done'" := (If_ b then_ else_) (at level 75, b at level 0).
Notation "{{ I }} 'while' b 'loop' body 'done'" := (While_ I b body) (at level 75).
Notation "'assert' {{ I }}" := (Assert I) (at level 75).
Delimit Scope cmd_scope with cmd.

Infix "+" := plus : reset_scope.
Infix "-" := Init.Nat.sub : reset_scope.
Infix "*" := mult : reset_scope.
Infix "=" := eq : reset_scope.
Infix "<" := lt : reset_scope.
Delimit Scope reset_scope with reset.
Open Scope reset_scope.
(* END macros *)

(* We should draw some attention to the next notation, which defines special
 * lambdas for writing assertions. *)
Notation "h & v ~> e" := (fun h v => e%reset) (at level 85, v at level 0).

(* And here's the classic notation for Hoare triples. *)
Notation "{{ P }} c {{ Q }}" := (hoare_triple P c%cmd Q) (at level 90, c at next level).

(* Special case of consequence: keeping the precondition; only changing the
 * postcondition. *)
Lemma HtStrengthenPost : forall (P Q Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P c Q'.
Proof.
  simplify; eapply HtConsequence; eauto.
Qed.

(* Finally, three tactic definitions that we won't explain.  The overall tactic
 * [ht] tries to prove Hoare triples, essentially by rote application of the
 * rules.  Some other obligations are generated, generally of implications
 * between assertions, and [ht] also makes a best effort to solve those. *)

Ltac ht1 := apply HtSkip || apply HtAssign || apply HtWrite || eapply HtSeq
            || eapply HtIf || eapply HtWhile || eapply HtAssert
            || eapply HtStrengthenPost.

Ltac t := cbv beta; propositional; subst;
          repeat match goal with
                 | [ H : ex _ |- _ ] => invert H; propositional; subst
                 end;
          simplify;
          repeat match goal with
                 | [ _ : context[?a <=? ?b] |- _ ] => destruct (a <=? b); try discriminate
                 | [ H : ?E = ?E |- _ ] => clear H
                 end; simplify; propositional; auto; try equality; try linear_arithmetic.

Ltac ht := simplify; repeat ht1; t.

(** * Some examples of verified programs *)

(** ** Swapping the values in two variables *)

(* First, let's prove it with more manual applications of the Hoare-logic
 * rules. *)
Theorem swap_ok : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    "tmp" <- "x";;
    "x" <- "y";;
    "y" <- "tmp"
  {{_&v ~> v $! "x" = b /\ v $! "y" = a}}.
Proof.
  simplify.
  eapply HtSeq.
  apply HtAssign.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  apply HtAssign.
  simplify.
  t.
Qed.

(* We can also automate the proof easily. *)
Theorem swap_ok_snazzy : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    "tmp" <- "x";;
    "x" <- "y";;
    "y" <- "tmp"
  {{_&v ~> v $! "x" = b /\ v $! "y" = a}}.
Proof.
  ht.
Qed.

(** ** Computing the maximum of two variables *)

Theorem max_ok : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    when "x" < "y" then
      "m" <- "y"
    else
      "m" <- "x"
    done
  {{_&v ~> v $! "m" = max a b}}.
Proof.
  simplify.
  eapply HtStrengthenPost.
  apply HtIf.
  (* Every branch causes duplication of constraints. We will come back to this when we look at F*. *)
  apply HtAssign.
  apply HtAssign.
  simplify.
  t.
Qed.

Theorem max_ok_snazzy : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    when "x" < "y" then
      "m" <- "y"
    else
      "m" <- "x"
    done
  {{_&v ~> v $! "m" = max a b}}.
Proof.
  ht.
Qed.

Theorem reduce_to_zero:
  {{_&_ ~> True}}

  {{_&_ ~> True}} (* Loop invariant *)
  while 0 < "x" loop
    "x" <- "x" - 1
  done
  {{_&v ~> v $! "x" = 0}}.
Proof.
  simplify.
  eapply HtStrengthenPost.
  eapply HtWhile.
  simplify.
  equality.
  eapply HtStrengthenPost.
  eapply HtAssign.
  simplify. equality.
  t.
Qed.

Theorem reduce_to_zero_snazzy:
  {{_&_ ~> True}}

  {{_&_ ~> True}}
  while 0 < "x" loop
    "x" <- "x" - 1
  done
  {{_&v ~> v $! "x" = 0}}.
Proof.
  ht.
Qed.

Theorem division': forall m n,
  {{_&v ~> v $! "x" = m /\ v $! "y" = n }}
  "q" <- 0;;
  {{_&_ ~> True}}
  while Or ("y" < "x") ("y" = "x") loop
    "x" <- "x" - "y";;
    "q" <- "q" + 1
  done
  {{_&v ~> v $! "q" = m / (v $! "y")}}.
Proof.
  ht.
  cases (v $! "y" ==n v $! "x").
  equality.
Abort.

Lemma lem1: forall x y q,
  y < x -> (y * (q + 1)) + (x - y) = (y * q) + x.
Proof.
  simplify.
  SearchRewrite (_ * (_ + _)).
  rewrite Nat.mul_add_distr_l.
  SearchRewrite ( _ * 1).
  rewrite Nat.mul_1_r.
  assert (y < x -> y <= x). linear_arithmetic.
  apply H0 in H.
  SearchRewrite ((_ + (_ - _))).
  apply le_plus_minus in H.
  SearchRewrite ((_ + _) + _).
  rewrite <- Nat.add_assoc.
  rewrite <- H.
  equality.
Qed.

Theorem division: forall m n,
  {{_&v ~> v $! "x" = m /\ v $! "y" = n }}
  "q" <- 0;;
  {{_&v ~> (v $! "y") * (v $! "q") + (v $! "x") = m}}
  while Or ("y" < "x") ("y" = "x") loop
    "x" <- "x" - "y";;
    "q" <- "q" + 1
  done
  {{_&v ~> v $! "q" = m / (v $! "y")}}.
Proof.
  ht.

  + cases (x0 $! "y" ==n x0 $! "x").
    - rewrite e.
      SearchRewrite(_ - _).
      rewrite Nat.sub_diag.
      ring.
    - equality.
  + apply lem1.
    assumption.
  + cases (v $! "y" ==n v $! "x").
    - equality.
    - assert ( v $! "x" < v $! "y").
      linear_arithmetic.
      Search (_ = _ / _).
      eapply Nat.div_unique.
      eassumption.
      equality.
Qed.

(** ** Iterative factorial *)

(* These two rewrite rules capture the definition of functional [fact], in
 * exactly the form useful in our Hoare-logic proof. *)
Lemma fact_base : forall n,
  n = 0
  -> fact n = 1.
Proof.
  simplify; subst; auto.
Qed.

Hint Rewrite <- minus_n_O.

Lemma fact_rec : forall n,
  n > 0
  -> fact n = n * fact (n - 1).
Proof.
  simplify; cases n; simplify; linear_arithmetic.
Qed.

Hint Rewrite fact_base fact_rec using linear_arithmetic.

(* Note the careful choice of loop invariant below.  It may look familiar from
 * earlier chapters' proofs! *)
Theorem fact_ok : forall n,
  {{_&v ~> v $! "n" = n}}
    "acc" <- 1;;
    {{_&v ~> v $! "acc" * fact (v $! "n") = fact n}}
    while 0 < "n" loop
      "acc" <- "acc" * "n";;
      "n" <- "n" - 1
    done
  {{_&v ~> v $! "acc" = fact n}}.
Proof.
  simplify.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  eapply HtWhile.
  simplify.
  t.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  apply HtAssign.
  simplify.
  t.
  ring [H0].
  (* This variant of [ring] suggests a hypothesis to use in the proof. *)
  simplify.
  t.
Qed.

Theorem fact_ok_snazzy : forall n,
  {{_&v ~> v $! "n" = n}}
    "acc" <- 1;;
    {{_&v ~> v $! "acc" * fact (v $! "n") = fact n}}
    while 0 < "n" loop
      "acc" <- "acc" * "n";;
      "n" <- "n" - 1
    done
  {{_&v ~> v $! "acc" = fact n}}.
Proof.
  ht.
  ring [H0].
Qed.

(** ** Selection sort *)

(* This is our one example of a program reading/writing memory, which holds the
 * representation of an array that we want to sort in-place. *)

(* One simple lemma turns out to be helpful to guide [eauto] properly. *)
Lemma leq_f : forall A (m : fmap A nat) x y,
  x = y
  -> m $! x <= m $! y.
Proof.
  ht.
Qed.

Hint Resolve leq_f.
Hint Extern 1 (@eq nat _ _) => linear_arithmetic.
Hint Extern 1 (_ < _) => linear_arithmetic.
Hint Extern 1 (_ <= _) => linear_arithmetic.
(* We also register [linear_arithmetic] as a step to try during proof search. *)

(* These invariants are fairly hairy, but probably the best way to understand
 * them is just to spend a while reading them.  They generally talk about
 * sortedness of subsets of the array.  See the final postcondition for how we
 * interpret a part of memory as an array.  Also note that we only prove here
 * that the final array is sorted, *not* that it's a permutation of the original
 * array!  (Exercise for the reader?  I'm not sure how much work it would
 * take.) *)
Theorem selectionSort_ok :
  {{_&_ ~> True}}
    "i" <- 0;;
    {{h&v ~> v $! "i" <= v $! "n"
        /\ (forall i j, i < j < v $! "i" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j))
        /\ (forall i j, i < v $! "i" -> v $! "i" <= j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)) }}
    while "i" < "n" loop
      "j" <- "i"+1;;
      "best" <- "i";;
      {{h&v ~> v $! "i" < v $! "j" <= v $! "n"
         /\ v $! "i" <= v $! "best" < v $! "n"
         /\ (forall k, v $! "i" <= k < v $! "j" -> h $! (v $! "a" + v $! "best") <= h $! (v $! "a" + k))
         /\ (forall i j, i < j < v $! "i" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j))
         /\ (forall i j, i < v $! "i" -> v $! "i" <= j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)) }}
      while "j" < "n" loop
        when *["a" + "j"] < *["a" + "best"] then
          "best" <- "j"
        else
          Skip
        done;;
        "j" <- "j" + 1
      done;;
      "tmp" <- *["a" + "best"];;
      *["a" + "best"] <- *["a" + "i"];;
      *["a" + "i"] <- "tmp";;
      "i" <- "i" + 1
    done
  {{h&v ~> forall i j, i < j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)}}.
Proof.
  ht; repeat match goal with
             | [ |- context[_ $+ (?a + ?x, _) $! (?a + ?y)] ] =>
               cases (x ==n y); ht
             end.

  cases (k ==n x0 $! "j"); ht.
  specialize (H k); ht.

  cases (k ==n x $! "j"); ht.
Qed.

(** * An alternative correctness theorem for Hoare logic, with small-step semantics *)

(* In case you were worried that this chapter is too far removed from the
 * pattern of program reasoning we've seen recur again and again, help is here!
 * We can also characterize Hoare triples in terms of invariants of transition
 * systems.  To start with, here's a small-step semantics for our running
 * language. *)
Inductive step : heap * valuation * cmd -> heap * valuation * cmd -> Prop :=
| StAssign : forall h v x e,
  step (h, v, Assign x e) (h, v $+ (x, eval e h v), Skip)
| StWrite : forall h v e1 e2,
  step (h, v, Write e1 e2) (h $+ (eval e1 h v, eval e2 h v), v, Skip)
| StStepSkip : forall h v c,
  step (h, v, Seq Skip c) (h, v, c)
| StStepRec : forall h1 v1 c1 h2 v2 c1' c2,
  step (h1, v1, c1) (h2, v2, c1')
  -> step (h1, v1, Seq c1 c2) (h2, v2, Seq c1' c2)
| StIfTrue : forall h v b c1 c2,
  beval b h v = true
  -> step (h, v, If_ b c1 c2) (h, v, c1)
| StIfFalse : forall h v b c1 c2,
  beval b h v = false
  -> step (h, v, If_ b c1 c2) (h, v, c2)
| StWhileFalse : forall I h v b c,
  beval b h v = false
  -> step (h, v, While_ I b c) (h, v, Skip)
| StWhileTrue : forall I h v b c,
  beval b h v = true
  -> step (h, v, While_ I b c) (h, v, Seq c (While_ I b c))
| StAssert : forall h v (a : assertion),
  a h v
  -> step (h, v, Assert a) (h, v, Skip).

Hint Constructors step.

Definition trsys_of (st : heap * valuation * cmd) := {|
  Initial := {st};
  Step := step
|}.

(* We'll characterize *unstuckness* in roughly the same way as we did for
 * lambda-calculus type soundness: the program is done (reached [Skip]) or can
 * take a step. *)
Definition unstuck (st : heap * valuation * cmd) :=
  snd st = Skip
  \/ exists st', step st st'.

(* A convenient property of Hoare triples: they rule out stuckness, regardless
 * of the specs we choose, so long as the precondition accurately describes the
 * real execution state!
 *
 * Note that the only real possibility for stuckness in
 * the semantics is via [Assert], which is why we included it.  We reduce
 * arbitrary correctness checks, on intermediate program states, to stuckness or
 * lack thereof in program execution. *)
Lemma progress : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v, P h v
                 -> unstuck (h, v, c).
Proof.

  induct 1; unfold unstuck; simplify; propositional.

  eauto.

  eauto.

  apply IHhoare_triple1 in H1.
  unfold unstuck in H1.
  simplify. propositional. subst. right. eexists. constructor.
  invert H2. cases x. cases p. right. eexists. econstructor. eauto.

  cases (beval b h v).
  right. eexists. econstructor. eassumption.
  right. eexists. eapply StIfFalse. eassumption.

  cases (beval b h v); eauto.

  apply H in H0. right. eexists. econstructor. assumption.

  apply H0 in H2.
  apply IHhoare_triple in H2.
  unfold unstuck in H2. simplify. first_order.
Qed.

(* Another basic property: [Skip] has no effect on program state, and the set of
 * derivable specs for [Skip] reflects that fact. *)
Lemma hoare_triple_Skip : forall P Q,
  {{P}} Skip {{Q}}
  -> forall h v, P h v -> Q h v.
Proof.
  induct 1; auto.
Qed.

(* Finally, our main inductive proof: small steps preserve the existence of
 * Hoare triples.  We even give the concrete specification for the new command
 * [c'] that was stepped to.  It keeps the old postcondition, and we give it a
 * very specific precondition saying "the state is exactly this." *)
Lemma preservation : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v h' v' c',
      step (h, v, c) (h', v', c')
      -> P h v
      -> {{h''&v'' ~> h'' = h' /\ v'' = v'}} c' {{Q}}.
Proof.
  (* Skip *)
  induct 1.

  invert 1. (* you cannot step a [Skip] command *)

  invert 1; ht; eauto.

  invert 1; ht; eauto.

  invert 1; simplify.

  eapply HtConsequence; eauto.
  propositional; subst.
  eapply hoare_triple_Skip; eauto.

  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto; equality.
  eapply HtConsequence; eauto; equality.

  invert 1; simplify.
  eapply HtConsequence with (P := h'' & v'' ~> h'' = h' /\ v'' = v').
  apply HtSkip.
  auto.
  simplify; propositional; subst; eauto.

  econstructor.
  eapply HtConsequence; eauto.
  simplify; propositional; subst; eauto.
  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto.
  econstructor.
  simplify; propositional; subst; eauto.

  simplify.
  eapply HtConsequence.
  eapply IHhoare_triple; eauto.
  simplify; propositional; subst; eauto.
  auto.
Qed.

(* Oh, what a coincidence! ;-)  As with type-safety proofs, we find that the
 * reasonably intuitive properties we just proved are precisely the hard parts
 * of a standard proof by invariant strengthening and invariant induction. *)
Theorem invariant_safety : forall P c Q h v,
  {{P}} c {{Q}}
  -> P h v
  -> invariantFor (trsys_of (h, v, c)) unstuck.
Proof.
  simplify.
  apply invariant_weaken
    with (invariant1 :=
            fun st => {{h&v ~> h = fst (fst st) (* h *) /\ v = snd (fst st) (* v *) }}
                      snd st (* c *)
                      {{_&_ ~> True}}).

  apply invariant_induction; simplify.

  propositional; subst; simplify.
  eapply HtConsequence; eauto.
  equality.

  cases s.
  cases s'.
  cases p.
  cases p0.
  simplify.
  eapply preservation; eauto.
  simplify; auto.

  simplify.
  cases s.
  cases p.
  simplify.
  eapply progress; eauto.
  simplify; auto.
Qed.

(* A very simple example, just to show all this in action *)
Definition forever := (
  "i" <- 1;;
  "n" <- 1;;
  {{h&v ~> v $! "i" > 0}}
  while 0 < "i" loop
    "i" <- "i" * 2;;
    "n" <- "n" + "i";;
    assert {{h&v ~> v $! "n" >= 1}}
  done;;

  assert {{_&_ ~> False}}
  (* Note that this last assertion implies that the program never terminates! *)
)%cmd.

(* The program will not terminate, but the assertion holds forever *)
Theorem forever_ok : {{_&_ ~> True}} forever {{_&_ ~> False}}.
Proof.
  ht.
Qed.

Theorem forever_invariant : invariantFor (trsys_of ($0, $0, forever)) unstuck.
Proof.
  eapply invariant_safety.
  apply forever_ok.
  simplify; trivial.
Qed.


Require Import Coq.Lists.List.
Require Import FunCombinators.All.

Import ListNotations.
Local Open Scope list.

Module Red.
  Definition t (A B : Type) : Type := A -> B -> A.
End Red.

Module List.
  Fixpoint fold {A B : Type} (a : A) (red : Red.t A B) (l : list B) : A :=
    match l with
    | [] => a
    | x :: l => fold (red a x) red l
    end.

  Definition cons {A : Type} (a : list A) (x : A) : list A :=
    x :: a.
End List.

Definition map {A B C : Type} (f : B -> C) (red : Red.t A C) : Red.t A B :=
  fun a x =>
    red a (f x).

Definition filter {A B : Type} (f : B -> bool) (red : Red.t A B) : Red.t A B :=
  fun a x =>
    if f x then
      red a x
    else
      a.

Definition take {A B : Type} (red : Red.t A B) : Red.t (A * nat) B :=
  fun a x =>
    match a with
    | (a, S n) => (red a x, n)
    | (a, O) => (a, O)
    end.

Definition transduce {A B C D : Type} {T : Type -> Type}
  (transducer : Red.t C D -> Red.t A B) (red : Red.t C D) (a : A)
  (fold : A -> Red.t A B -> T B -> A) (stream : T B) : A :=
  fold a (transducer red) stream.

Module Test.
  Definition l := [Some 1; None; Some 2; Some 3].

  Definition of_option n :=
    match n with
    | None => 1
    | Some n => n
    end.

  Definition is_some {A : Type} (x : option A) : bool :=
    match x with
    | None => false
    | Some _ => true
    end.

  Compute l |> List.fold 0 (map of_option plus).
  Compute l |> List.fold 0 (plus |> map of_option |> filter is_some).
  Compute l |> List.fold (0, 3) (plus |> map of_option |> filter is_some |> take).
  Compute l |> List.fold ([], 3) (List.cons |> map of_option |> filter is_some |> take).

  Compute transduce (map of_option) plus 0 List.fold l.
  Compute [1; 2; 3] |> List.fold 0 plus.
  Compute [1; 2; 3] |> List.fold 0 (map S plus).
  Compute l |> List.fold (0, 3) (
    take @@
    filter is_some @@
    map of_option @@
    map S @@
    plus).
End Test.