Set Implicit Arguments.

Require Import Bvector.
Require Import List.
Require Import Arith.

Require Import HMAC_functional_prog.
Require Import Integers.
Require Import Coqlib.

(* Require Import List. Import ListNotations. *)

Definition Blist := list bool.

Fixpoint splitVector (A : Set) (n m : nat) :
  Vector.t A (n + m) -> (Vector.t A n * Vector.t A m) :=
  match n with
    | 0%nat =>
      fun (v : Vector.t A (O + m)) => (@Vector.nil A, v) (* why the function? TODO *)
    | S n' =>
      fun (v : Vector.t A (S n' + m)) =>
        let (v1, v2) := splitVector _ _ (Vector.tl v) in
          (Vector.cons _ (Vector.hd v) _ v1, v2)
  end.

Eval compute in splitVector 1 2 [true; true; true].

Section HMAC.

SearchAbout Bvector.
Print Bvector.
Check Bvector 10.
Check [true].
Print Vector.

(* b = block size
   c = digest (output) size
   p = padding = b - c (fixed) *)
  Variable c p : nat.
  Definition b := (c + p)%nat.

  (* The compression function *)
  Variable h : Bvector c -> Bvector b -> Bvector c.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Bvector c.
  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : list (Bvector b)) :=
    fold_left h m k.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  Definition hash_words := h_star iv.

  (* TODO check how this corresponds to SHA
     Seems that h = SHA compression function
     hash_words with SHA's iv is SHA
   *)
  Check hash_words.
  Check h_star.

  Variable splitAndPad : Blist -> list (Bvector b).

  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  (* constant-length padding. *)
  Variable fpad : Bvector p.

  Definition app_fpad (x : Bvector c) : Bvector b :=
    (Vector.append x fpad).
  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitVector c c k in
    h k_Out (app_fpad (h_star k_In m)).

Check hash_words.

  (* The "two-key" version of GHMAC and HMAC. *)
  (* Concatenate (K xor opad) and (K xor ipad) *)
  Definition GHMAC_2K (k : Bvector (b + b)) m :=
    let (k_Out, k_In) := splitVector b b k in (* concat earlier, then split *)
      let h_in := (hash_words (k_In :: m)) in
        hash_words (k_Out :: (app_fpad h_in) :: nil).

SearchAbout Bvector.

  Definition HMAC_2K (k : Bvector (b + b)) (m : Blist) :=
    GHMAC_2K k (splitAndPad m).

Check HMAC_2K.
(* HMAC_2K
     : Bvector (b + b) -> Blist -> Bvector c *)

(* opad and ipad are constants defined in the HMAC spec. *)
Variable opad ipad : Bvector b.
Definition GHMAC (k : Bvector b) :=
  GHMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

Print BVxor.

Definition HMAC (k : Bvector b) :=
  HMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

Check HMAC.                     (*  : Bvector b -> Blist -> Bvector c *)

End HMAC.

(* ----------------------------------------------------------- Theorem definitions *)

Check HMAC_SHA256.HMAC.            (* list Z -> list Z -> list Z *)

  (* Bvector is little-endian (least significant bit at head; list Z are just translated
from the string (ascii -> nat -> Z); but Int are packed big-endian (with 4 Z -> 1 Int)

each Z is one byte (8 bits) *)

(* TODO: add isbyteZ (from SHA256.v), 0 <= i <= 256 *)

(* *************** byte/bit computational *)

(* TODO: finish this

The term "Vector.append (iterate n' num_new) [bool_digit]" has type
 "Vector.t bool (n' + 1)" while it is expected to have type
"Bvector (S n')".

Function with proof of equivalence? see hash_blocks  *)

(*
Fixpoint iterate (n : nat) (byte : nat) : Bvector n :=
  match n as x return Bvector x with
    | O => Vector.nil bool
    | S n' =>
      let byte_subtract := (byte - NPeano.pow 2 n')%nat in
      let bool_digit := negb (leb byte_subtract 0) in
      let num_new := if bool_digit then byte_subtract else byte in
      Vector.append (iterate n' num_new) [bool_digit] (* could reverse instead *)
  end.

*)

Lemma add_1_r_S : forall (n : nat), (n + 1)%nat = S n.
Proof.
  induction n.
    reflexivity.
    simpl. rewrite -> IHn. reflexivity.
Defined.

(* TODO step through this *)
Locate leb. Check negb.
(* little-endian *)
Fixpoint iterate (n : nat) (byte : nat) : Bvector n.
Proof.
  destruct n.
     apply (Vector.nil bool).
  remember ((byte - NPeano.pow 2 n)%nat) as byte_subtract.
  remember (negb (leb byte_subtract 0)) as bool_digit. (* changed from leb: gt now *)
  remember (if bool_digit then byte_subtract else byte) as num_new.
  rewrite <- add_1_r_S.
  apply (Vector.append (iterate n num_new) [bool_digit]). (* n' *)
Defined.

Print iterate.
Eval compute in iterate 1 255.
Check eq_rec. Print eq_rec. Print eq_rect. Check eq_rect.
Print NPeano.Nat.add_1_r.

(* TODO: fix the latter + 1 *)
Fixpoint byte_to_bits (byte : Z) : Bvector 8 :=
  let max_pow_two := 7%nat in
  iterate (max_pow_two + 1) (nat_of_Z byte + 1).

  Print add_1_r_S.
Eval compute in iterate 8 2.
Eval compute in byte_to_bits 0.
Eval compute in byte_to_bits 1.
Eval compute in byte_to_bits 2.

Eval compute in byte_to_bits 127.
Eval compute in byte_to_bits 128.
Eval compute in byte_to_bits 129.
Eval compute in byte_to_bits 200.
Eval compute in byte_to_bits 255.
Eval compute in byte_to_bits 256. (* not valid *)

(* Parameter byte_to_bits : Z -> Bvector 8. *)

(* Or: concatMap byte_to_bit bytes *)
Check Bvector.
SearchAbout Bvector.
Print Vector.t.

(* how to prove that it's length bytes * 8? *)
(* list of bytes? (type) *)
Fixpoint bytes_to_bits (bytes : list Z) : Bvector (length bytes * 8) :=
  match bytes as x return Bvector (length x * 8) with (* CPDT *)
    | nil => Vector.nil bool
    | x :: xs => Vector.append (byte_to_bits x) (bytes_to_bits xs)
  end.

(* ************* inductive defs *)

SearchAbout Bvector.

Definition asZ (x : bool) : Z := if x then 1 else 0.

(* TODO: maybe prefer b : byte, with Byte.repr? *)
Definition convertByteBits (b : Z) (B : Bvector 8) : Prop :=
  exists (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
   B = [b0; b1; b2; b3; b4; b5; b6; b7] /\
   b =  (1 * (asZ b0) + 2 * (asZ b1) + 4 * (asZ b2) + 8 * (asZ b3)
         + 16 * (asZ b4) + 32 * (asZ b5) + 64 * (asZ b6) + 128 * (asZ b7)).

(* *** *)

(* relating list Z to Blist
bytes_to_bits m = length M

TODO: big-endian, little-endian?
*)
Inductive bytes_bits_lists : list Z -> Blist -> Prop :=
  | eq_empty : bytes_bits_lists nil nil
  | eq_cons : forall (bytes : list Z) (bits : Blist)
                     (byte : Z) (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
                bytes_bits_lists bytes bits ->
                convertByteBits byte [b0; b1; b2; b3; b4; b5; b6; b7] ->
                bytes_bits_lists (byte :: bytes)
                                (b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: bits).

(*
Inductive bytes_bits_vector' (l : list Z) : Bvector (8 * length l) -> Prop :=
  | eq_empty_v : forall (bits : Bvector (8 * length nil)),
                   bytes_bits_vector' nil bits
  (* TODO: might want to use Vector.nil bool? *)
  | eq_cons_v : forall (bytes : list Z) (bits : Bvector (8 * length bytes))
                       (byte : Z) (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
                  bytes_bits_vector' bytes bits ->
                  convertByteBits byte [b0; b1; b2; b3; b4; b5; b6; b7] ->
                  bytes_bits_vector' (byte :: bytes)
                                     (* TODO: is this the right endianness? *)
                                     (Vector.append [b0; b1; b2; b3; b4; b5; b6; b7] bits)
.
*)

Lemma list_cons_len {A : Type} :
      forall (x : A) (xs : list A), length (x :: xs) = (1 + length xs)%nat.
Proof. intros. reflexivity. Defined.

Lemma mul_dist : forall (n m : nat), (n * (1 + m))%nat = (n + n * m)%nat.
Proof.
  intros. simpl.
  rewrite -> mult_succ_r. rewrite -> plus_comm. reflexivity.
Defined.

Print mult_succ_r.
Print plus_comm.

Fixpoint squash_list_vector
         (bits_list : list (Bvector 8)) : Bvector (8 * length bits_list).
Proof.
  destruct bits_list.
    apply (Vector.nil bool).
    rewrite -> list_cons_len.
    rewrite -> mul_dist.
    (* TODO watch out for endianness *)
  apply (Vector.append b0 (squash_list_vector bits_list)).
Defined.

SearchAbout Vector.cons.
Check Vector.cons.
Check Vector.cons bool true 1 [false].

(* TODO: how to write a better dependent pattern match? doesn't use the equality of their len
writing it as a proof and destructing n or b1/b2 doesn't work
*)
Fixpoint bvector_eq (n : nat) (m : nat) (b1 : Bvector n) (b2 : Bvector m) : bool :=
  match b1, b2 with             (*  match n as n0 return (Bvector n0) with *)
    | Vector.nil, Vector.nil => true
    | Vector.cons x1 _ xs1, Vector.cons x2 _ xs2 =>
      eqb x1 x2 && bvector_eq xs1 xs2
    | _, _ => false
  end.

(* TODO watch out for endianness *)

Definition bytes_bits_vector_comp
         (n : nat) (bytes : list Z) (bits : Bvector n) : bool.
Proof.
  remember (map byte_to_bits bytes) as bits_list_vector.
  remember (squash_list_vector bits_list_vector) as bvector.
  apply (bvector_eq bvector bits).
Defined.

Print bytes_bits_vector_comp.
(* Seems hard to use in a proof... *)

(* TODO: get this to be required *)
Eval compute in
    bytes_bits_vector_comp (0 :: nil) [true; true; true; true; true; true; true; true].

Lemma bytes_bits_vector_comp_len : forall (n : nat) (bytes : list Z) (bits : Bvector n),
                                     bytes_bits_vector_comp bytes bits = true
                                     -> n = (8 * length bytes)%nat.
Proof.
  (* TODO: bvector_eq is true iff the vectors are the same length *)
Admitted.

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

(* Lennart's definitions: *)

Definition bveqF :=
fix bveqF (n : nat) (b1 b2 : Bvector n) {struct n} : bool :=
  match n as n0 return (Bvector n0 -> Bvector n0 -> bool) with
  | 0%nat => fun _ _ : Bvector 0 => true
  | S n0 =>
      fun b3 b4 : Bvector (S n0) =>
      eqb (Vector.hd b3) (Vector.hd b4) &&
      bveqF n0 (Vector.tl b3) (Vector.tl b4)
  end b1 b2.

Fixpoint bveq (n:nat) (b1 b2:Bvector n): bool.
  destruct n; intros. apply true. remember (S n) as m.
destruct b1. inversion Heqm. inversion Heqm. subst.  inversion b2. subst.
  apply (eqb h h0 && bveq _ b1 H0).
(*  apply (eqb (Vector.hd b1) (Vector.hd b2) && (bveq _ (Vector.tl b1) (Vector.tl b2))).*)
Defined.
Print bveq.

Definition bveq1 (n:nat) (b1 b2:Bvector n): bool.
  induction n; intros. apply true.
  apply (eqb (Vector.hd b1) (Vector.hd b2) && (IHn (Vector.tl b1) (Vector.tl b2))).
Defined.

Definition bveqD :=
fun (n : nat) (b1 b2 : Bvector n) =>
nat_rec (fun n0 : nat => Bvector n0 -> Bvector n0 -> bool)
  (fun _ _ : Bvector 0 => true)
  (fun (n0 : nat) (IHn : Bvector n0 -> Bvector n0 -> bool)
     (b3 b4 : Bvector (S n0)) =>
   eqb (Vector.hd b3) (Vector.hd b4) && IHn (Vector.tl b3) (Vector.tl b4)) n
  b1 b2.

Eval compute in (bveqD [true; true; false] [true; true; false]).

(* TODO watch out for endianness *)
Search Bvector.

(* TODO replace bytes_bits_vector_comp with bytes_bits_vector *)

Inductive bytes_bits_vector : forall n
         (bytes : list Z) (bits : Bvector n), Prop :=
| bvv_nil: bytes_bits_vector nil []
| bvv_cons: forall n bytes1 bits1
                   (bt : Z) (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
              @bytes_bits_vector n bytes1 bits1 ->
              convertByteBits bt [b0; b1; b2; b3; b4; b5; b6; b7] ->
              @bytes_bits_vector (8 + n) (bt :: bytes1)
                                     (* TODO: is this the right endianness? *)
                                     (Vector.append [b0; b1; b2; b3; b4; b5; b6; b7] bits1).

Definition bytes_bits_vector_comp'
         (bytes : list Z) (bits : Bvector (8 * length bytes)) : bool.
Proof.
  remember (map byte_to_bits bytes) as bits_list_vector.
  remember (squash_list_vector bits_list_vector) as bvector.
  assert (len_eq: length bytes = length bits_list_vector).
    rewrite -> Heqbits_list_vector.
    rewrite -> list_length_map.
    reflexivity.
  rewrite -> len_eq in bits.
  apply (bvector_eq bvector bits).
Defined.

(* ----------------------------------------- Theorem and parameters *)

Check HMAC_SHA256.HMAC.         (* ? *)
Check HMAC.
(* HMAC
     : forall c p : nat,
       (Bvector c -> Bvector (b c p) -> Bvector c) ->   // compression function h
       Bvector c ->                          // iv, h's initialization vector
       (Blist -> list (Bvector (b c p))) ->  // splitAndPad (e.g. generate_and_pad)
       Bvector p ->                          // fpad, constant-length padding
       Bvector (b c p) ->                    // opad
       Bvector (b c p) ->                    // ipad

^ Note: this has to do with the internals of SHA256 and HMAC too
SHA's compression function, iv, generate_and_pad (with block vectors),
HMAC's key padding function, HMAC's opad and ipad.
How to convert?

       Bvector (b c p) -> Blist -> Bvector c        // key, message, outputted hash

k is of length b
b = block size
c = output size
p = padding = b - c

why pad the key? why not just let it be size b?
 *)

(* want Bvector b = 512 bits *)
Print Byte.int.
Print Byte.repr.
Check Byte.unsigned.
Check HMAC_SHA256.sixtyfour.

Definition opad_test :=
     bytes_to_bits
                     (map Byte.unsigned (HMAC_SHA256.sixtyfour (Byte.repr 52))).
Check opad_test.
(* Definition ipad_test := bytes_to_bits
                     (map Byte.unsigned (HMAC_SHA256.sixtyfour HMAC_SHA256.Ipad)). *)

Check HMAC.

(* ------------------------------------- *)
Module Equiv.

Definition c:nat := (SHA256_.DigestLength * 8)%nat.
(*Variable p:nat.
Locate HMAC.
Check @HMAC. Check @sha_h.
Check (@HMAC _ p (@sha_h _ p plus) sha_iv (sha_splitandpad_vector p) (fpad p)).
Check (HMAC (sha_h p plus) sha_iv).
*)
Definition p:=(32 * 8)%nat.

Parameter sha_iv : Bvector (SHA256_.DigestLength * 8).

(* Definition sha_h : list Z -> list Z := SHA256_.Hash. *)
Parameter sha_h : Bvector c -> Bvector (c + p) -> Bvector c.

(* corresponds to block size. b = plus *)

(*  "Blist -> list (Bvector (b SHA256_.DigestLength c))" *)
Parameter sha_splitandpad_vector :
  Blist -> list (Bvector (SHA256_.DigestLength * 8 + p)).

Parameter fpad : Bvector p.

(* Is this the theorem we want? Is it useful for the rest of the proofs?
Should it be more abstract? *)

(* TODO: opad <> ipad? *)
Locate sixtyfour.

Definition bytes_bits_conv_vector'
           (byte_pad : byte) (bits_pad : Bvector (c + p)) : Prop :=
  let bytes_pad := map Byte.unsigned (HMAC_SHA256.sixtyfour byte_pad) in
  bytes_bits_vector bytes_pad bits_pad.

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

(*  (let (k_Out, k_In) :=
                       splitVector (b 256 256) (b 256 256)
                         (Vector.append (BVxor (b 256 256) K OP)
                            (BVxor (b 256 256) K IP)) in
Possibly try n = m -> splitVector n m...
*)

SearchAbout Bvector.
(* SearchAbout Vector. *)

Lemma empty_vector : forall (v : Bvector 0),
                       v = [].
Proof.
  intros v.
  (* destruct v. *)

Admitted.

Lemma split_append_id : forall (len : nat) (v1 v2 : Bvector len),
                          splitVector len len (Vector.append v1 v2) = (v1, v2).
Proof.
  induction len; intros v1 v2.
  (* Case len = 0 *)
    (* simpl. rewrite -> empty_vector. *)

    Admitted.

(* TODO: 10/25/14

- add lemma for xor **
   - lennart: B2b (Byte.xor B1 B2) = Vector.map2 xorb (B2b B1) (B2b B2)
- fill in parameters: sha_h, sha_iv, sha_splitandpad_vector, (fpad) **
- step through theorem
  - figure out how to use relations in theorem: compositional? f property? **

- clean up file
- look at ASCII library
   - rewrite iterate to emulate their conversion
- check bytes_bits_vector' fixpoint
   - look at new definitions, inductive?
   - see if induction works with it

- figure out how to get split lemmas to work
- skim Bellare proof and Adam's proof
- some other paper with a good approach?
- generalize technique for crypto
 *)

(* Options:
bytes_bits_vector (inductive, returns prop)
bytes_bits_vector_comp (returns bool)
bytes_bits_vector_comp' (returns bool) *)

Theorem HMAC_unfold : forall
                            (k m h : list Z)
                            (K : Bvector (plus c p)) (M : Blist) (H : Bvector c)
                            (op ip : byte) (OP IP : Bvector (plus c p)),
  ((length k) * 8)%nat = (c + p)%nat ->
  bytes_bits_vector k K ->
  bytes_bits_lists m M ->
  bytes_bits_conv_vector' op OP ->
  bytes_bits_conv_vector' ip IP ->
  HMAC sha_h sha_iv sha_splitandpad_vector fpad OP IP K M = H ->
  HMAC_SHA256.HMAC op ip m k = h -> (* m k, not k m *)
  bytes_bits_vector h H.
Proof.
  intros k m h K M H op ip OP IP.
  intros padded_key_len padded_keys_eq msgs_eq ops_eq ips_eq.
  intros HMAC_abstract HMAC_concrete.
  unfold p, c in *.
  simpl in *.

  unfold HMAC in *. simpl in *.
  rewrite <- HMAC_abstract.
  unfold HMAC_2K.
  unfold GHMAC_2K.
  rewrite -> split_append_id.
  (* simpl. *)

Abort.

Theorem HMAC_spec_equiv : forall
                            (k m h : list Z)
                            (K : Bvector (plus c p)) (M : Blist) (H : Bvector c)
                            (op ip : byte) (OP IP : Bvector (plus c p)),
  ((length k) * 8)%nat = (c + p)%nat ->
  bytes_bits_vector k K ->
  bytes_bits_lists m M ->
  bytes_bits_conv_vector' op OP ->
  bytes_bits_conv_vector' ip IP ->
  HMAC sha_h sha_iv sha_splitandpad_vector fpad OP IP K M = H ->
  HMAC_SHA256.HMAC op ip m k = h -> (* m k, not k m *)
  bytes_bits_vector h H.
Proof.
  intros k m h K M H op ip OP IP.
  intros padded_key_len padded_keys_eq msgs_eq ops_eq ips_eq.
  intros HMAC_abstract HMAC_concrete.
  unfold p, c in *.
  simpl in *.

  unfold HMAC in *. simpl in *.
  unfold HMAC_SHA256.HMAC in *.

  unfold HMAC_2K in *. unfold GHMAC_2K in *. (* unfold splitVector in *. *)
  (* Still abstract: sha_h, sha_splitandpad_vector, fpad *)
  Check sha_h.
  rewrite -> split_append_id in HMAC_abstract.

  unfold HMAC_SHA256.OUTER in *. unfold HMAC_SHA256.INNER in *.
    unfold HMAC_SHA256.outerArg in *. unfold HMAC_SHA256.innerArg in *.
    unfold HMAC_SHA256.mkArgZ in *. unfold HMAC_SHA256.mkArg in *.

    unfold SHA256_.Hash in *. unfold functional_prog.SHA_256' in *.
    Print SHA256_.Hash.
    Print functional_prog.SHA_256'.
Print functional_prog.generate_and_pad'.
    simpl in *.
    Check hash_words. Print hash_words. Print h_star. Print fold_left.
    (*  : forall c p : nat,
       (Bvector c -> Bvector (b c p) -> Bvector c) ->
       Bvector c -> list (Bvector (b c p)) -> Bvector c  *)
    Check sha_h.    (*  : Bvector c -> Bvector (c + p) -> Bvector c *)

  unfold BVxor in *. unfold xorb in *. (* unfold Vector.map2 in *. *)
  unfold Byte.xor in *. unfold Z.lxor in *.

    (* Lemma:

BVxor (b 256 256) K OP = Vector.map2 xorb K OP (can unfold xorb)
     ~
                          (map
                          (fun p0 : byte * byte => Byte.xor (fst p0) (snd p0))
                          (combine (map Byte.repr (HMAC_SHA256.mkKey k))
                             (HMAC_SHA256.sixtyfour ip)))

probably want a meta-lemma for composition of relations
r1 x X -> r2 y Y -> ?f ? -> f x y ~ F X Y

try with smaller examples first

figure out how to approach proof: avoid 4-way induction
 *)

  rewrite <- HMAC_abstract.
  rewrite <- HMAC_concrete.

  induction msgs_eq.

Abort.


Set Implicit Arguments.

Require Import ZArith.
Require Import Div2.
Require Import Recdef.
Require Import Mat.
Require Import Arith.

Class Monoid {A:Type}(dot : A -> A -> A)(one : A) : Type := {
  dot_assoc : forall x y z:A, dot x (dot y z)= dot (dot x y) z;
  one_left : forall x, dot one x = x;
  one_right : forall x, dot x one = x}.

(*
Print Monoid.

Record Monoid (A : Type) (dot : A -> A -> A) (one : A) : Type := Build_Monoid
  { dot_assoc : forall x y z : A, dot x (dot y z) = dot (dot x y) z;
    one_left : forall x : A, dot one x = x;
    one_right : forall x : A, dot x one = x }

For Monoid: Argument A is implicit
For Build_Monoid: Argument A is implicit
For Monoid: Argument scopes are [type_scope _ _]
For Build_Monoid: Argument scopes are [type_scope _ _ _ _ _]
*)

Open Scope Z_scope.

#[export] Instance ZMult : Monoid  Zmult 1.
Proof. split;intros;ring. Qed.

(*
About one_right.

one_right :
forall (A : Type) (dot : A -> A -> A) (one : A),
Monoid dot one -> forall x : A, dot x one = x

Arguments A, dot, one, Monoid are implicit and maximally inserted
Argument scopes are [type_scope _ _ _ _]
one_right is transparent
Expands to: Constant Top.one_right
*)

Generalizable Variables A dot one.

Fixpoint power `{M: Monoid A dot one}(a:A)(n:nat) :=
  match n with 0%nat => one
             | S p => dot a (power a p)
  end.

Function binary_power_mult (A:Type) (dot:A->A->A) (one:A) (M: @Monoid A dot one)
     (acc x:A)(n:nat){measure (fun i=>i) n} : A
  (* acc * (x ** n) *) :=
  match n with 0%nat => acc
             | _ => if  Even.even_odd_dec n
                    then binary_power_mult  _   acc (dot x x) (div2 n)
                    else binary_power_mult   _ (dot acc  x) (dot  x  x) (div2 n)
  end.
Proof.
- intros;apply lt_div2; auto with arith.
- intros; apply lt_div2; auto with arith.
Defined.

Definition binary_power `{M:Monoid} x n := binary_power_mult M one x n.

(* Example : 2 x 2 Matrices on some ring  *)

Section M2_def.
Variables (A:Type)
           (zero one : A)
           (plus mult minus : A -> A -> A)
           (sym : A -> A).
 Notation "0" := zero.
 Notation "1" := one.
 Notation "x + y" := (plus x y).
 Notation "x * y " := (mult x y).

 Variable rt : ring_theory  zero one plus mult minus sym (@eq A).
 Add  Ring Aring : rt.

#[export] Instance M2_Monoid : Monoid   (M2_mult  plus mult ) (Id2 0 1).
Proof.
 split.
 - destruct x;destruct y;destruct z;simpl.
   unfold M2_mult;apply M2_eq_intros;simpl;  ring.
 - destruct x;simpl;
   unfold M2_mult; apply M2_eq_intros; simpl; ring.
 - destruct x;simpl;
   unfold M2_mult;apply M2_eq_intros;simpl;ring.
Qed.

End M2_def.

#[export] Instance M2Z : Monoid  _ _ := M2_Monoid Zth.

(** Tests:
Compute power (Build_M2  1 1 1 0) 40.

*)

Definition fibonacci (n:nat) :=
  c00 (power  (Build_M2  1 1 1 0) n).

(* Generic study of power functions *)

Section About_power.

 Context `(M:Monoid A dot one ).

Ltac monoid_rw :=
    rewrite (@one_left A dot one M) ||
    rewrite (@one_right A dot one M)||
    rewrite (@dot_assoc A dot one M).

  Ltac monoid_simpl := repeat monoid_rw.

  Local Infix "*" := dot.
  Local Infix "**" := power (at level 30, no associativity).

  Lemma power_x_plus : forall x n p, x ** (n + p) =  x ** n *  x ** p.
  Proof.
    induction n as [| p IHp];simpl.
    -  intros;  monoid_simpl;trivial.
    - intro q;rewrite (IHp q);  monoid_simpl;trivial.
  Qed.

 Ltac power_simpl := repeat (monoid_rw || rewrite <- power_x_plus).

  Lemma power_commute : forall x n p,
               x ** n * x ** p = x ** p * x ** n.
  Proof.
   intros x n p;power_simpl; rewrite (plus_comm n p);trivial.
 Qed.

 Lemma power_commute_with_x : forall x n ,
        x * x ** n = x ** n * x.
 Proof.
  induction n;simpl;power_simpl;trivial.
  repeat rewrite <- (@dot_assoc A dot one M); rewrite IHn; trivial.
 Qed.

 Lemma power_of_power : forall x n p,  (x ** n) ** p = x ** (p * n).
 Proof.
   induction p;simpl;[| rewrite power_x_plus; rewrite IHp]; trivial.
Qed.

Lemma power_S : forall x n, x *  x ** n = x ** S n.
Proof. intros;simpl;auto. Qed.

Lemma sqr : forall x, x ** 2 =  x * x.
Proof.
 simpl;intros;monoid_simpl;trivial.
Qed.

Ltac factorize := repeat (
                rewrite <- power_commute_with_x ||
                rewrite  <- power_x_plus  ||
                rewrite <- sqr ||
                rewrite power_S ||
                rewrite power_of_power).

 Lemma power_of_square : forall x n, (x * x) ** n = x ** n * x ** n.
  induction n;simpl;monoid_simpl;trivial.
  repeat rewrite dot_assoc;rewrite IHn; repeat rewrite dot_assoc.
 factorize; simpl;trivial.
 Qed.

Lemma binary_power_mult_ok :
  forall n a x,  binary_power_mult  M  a x n = a * x ** n.
Proof.
  intro n; pattern n;apply lt_wf_ind.
  clear n; intros n Hn;   destruct n.
   intros;simpl; rewrite binary_power_mult_equation;monoid_simpl;
    trivial.
  intros;
    rewrite binary_power_mult_equation; destruct (Even.even_odd_dec (S n)).
  rewrite Hn, power_of_square;  factorize.
  pattern (S n) at 3;replace (S n) with (div2 (S n) + div2 (S n))%nat;auto.
  generalize (even_double _ e);simpl;auto.
  apply lt_div2;auto with arith.
  rewrite Hn.
  rewrite power_of_square ; factorize.
  pattern (S n) at 3;replace (S n) with (S (div2 (S n) + div2 (S n)))%nat;auto.
  rewrite <- dot_assoc; factorize;auto.
  generalize (odd_double _ o);intro H;auto.
  apply lt_div2;auto with arith.
Qed.

Lemma binary_power_ok : forall (x:A) (n:nat), binary_power x n = x ** n.
Proof.
  intros n x;unfold binary_power;rewrite binary_power_mult_ok;
  monoid_simpl;auto.
Qed.

End About_power.

(*

binary_power_ok :
forall (A : Type) (dot : A -> A -> A) (one : A) (M : @Monoid A dot one)
  (x : A) (n : nat),
@binary_power A dot one (x:A) (n:nat) = @power A dot one M x n

Arguments A, dot, one are implicit and maximally inserted
Argument scopes are [type_scope _ _ _ _ nat_scope]
binary_power_ok is opaque
Expands to: Constant Top.binary_power_ok

*)

Class Abelian_Monoid `(M:Monoid ):= {
  dot_comm : forall x y, dot x  y = dot y  x}.
(**

Print Abelian_Monoid.

Record Abelian_Monoid (A : Type) (dot : A -> A -> A)
(one : A) (M : Monoid dot one) : Prop := Build_Abelian_Monoid
  { dot_comm : forall x y : A, dot x y = dot y x }

For Abelian_Monoid: Arguments A, dot, one are implicit and maximally inserted
For Build_Abelian_Monoid: Arguments A, dot, one are implicit
For Abelian_Monoid: Argument scopes are [type_scope _ _ _]
For Build_Abelian_Monoid: Argument scopes are [type_scope _ _ _ _]

*)

#[export] Instance ZMult_Abelian : Abelian_Monoid ZMult.
Proof. split; exact Zmult_comm. Qed.

Section Power_of_dot.
 Context `{M: Monoid A} {AM:Abelian_Monoid M}.

Theorem power_of_mult :
   forall n x y,
    power (dot x y)  n =  dot (power x  n) (power y n).
Proof.
 induction n;simpl.
 -  rewrite one_left;auto.
 -  intros; rewrite IHn; repeat rewrite dot_assoc.
    rewrite <- (dot_assoc  x y (power x n)); rewrite (dot_comm y (power x n)).
    repeat rewrite dot_assoc;trivial.
Qed.

End Power_of_dot.


Set Warnings "-notation-overridden,-parsing".
Require Import maps.
Require Import types.
Require Import smallstep.
Require Import stlc.
From Coq Require Import Strings.String.

Module STLCExtended.

(*letの導入*)
(*
構文:
       t ::=                項
           | ...               （前と同じ他の項）
           | let x=t in t      let束縛

簡約:
                                 t1 --> t1'
                     ----------------------------------               (ST_Let1)
                     let x=t1 in t2 --> let x=t1' in t2

                        ----------------------------              (ST_LetValue)
                        let x=v1 in t2 --> [x:=v1]t2
型付け:
             Gamma |- t1 \in T1      x|->T1; Gamma |- t2 \in T2
             --------------------------------------------------        (T_Let)
                        Gamma |- let x=t1 in t2 \in T2
 *)

(*
対 射影 直積
*)

(*
構文:
       t ::=                項
           | ...
           | (t,t)             対
           | t.fst             第1射影
           | t.snd             第2射影

       v ::=                値
           | ...
           | (v,v)             対値

       T ::=                型
           | ...
           | T * T             直積型

簡約：
                              t1 --> t1'
                         --------------------                        (ST_Pair1)
                         (t1,t2) --> (t1',t2)

                              t2 --> t2'
                         --------------------                        (ST_Pair2)
                         (v1,t2) --> (v1,t2')

                              t1 --> t1'
                          ------------------                          (ST_Fst1)
                          t1.fst --> t1'.fst

                          ------------------                       (ST_FstPair)
                          (v1,v2).fst --> v1

                              t1 --> t1'
                          ------------------                          (ST_Snd1)
                          t1.snd --> t1'.snd

                           ------------------                       (ST_SndPair)
                          (v1,v2).snd --> v2

型付け：
               Gamma |- t1 \in T1     Gamma |- t2 \in T2
               -----------------------------------------               (T_Pair)
                       Gamma |- (t1,t2) \in T1*T2

                        Gamma |- t \in T1*T2
                        ---------------------                          (T_Fst)
                        Gamma |- t.fst \in T1

                        Gamma |- t \in T1*T2
                        ---------------------                          (T_Snd)
                        Gamma |- t.snd \in T2

 *)

(*1要素の型Unit*)
(*
構文:
       t ::=                項
           | ...               （前と同様）
           | unit              unit値

       v ::=                値
           | ...
           | unit              unit

       T ::=                型
           | ...
           | Unit              Unit型
型付け:
                         ----------------------                        (T_Unit)
                         Gamma |- unit \in Unit

 *)
(*
 Unitが本当に便利なのはよりリッチな言語で副作用(side effects)を持つ場合です。 例えば、変更可能な変数やポインタについての代入文や、例外その他のローカルではないコントロール機構を持つ場合、などです。 そのような言語では、副作用のためだけに評価される式の(どうでもよい)結果のための型が便利なのです。
 *)

(*直和型*)
(*
構文:
       t ::=                項
           | ...               （前と同様）
           | inl T t           タグ付け（左）
           | inr T t           タグ付け（右）
           | case t of         case
               inl x => t
             | inr x => t

       v ::=                値
           | ...
           | inl T v           タグ付き値（左）
           | inr T v           タグ付き値（右）

       T ::=                型
           | ...
           | T + T             直和型

簡約:
                               t1 --> t1'
                        ------------------------                       (ST_Inl)
                        inl T2 t1 --> inl T2 t1'

                               t2 --> t2'
                        ------------------------                       (ST_Inr)
                        inr T1 t2 --> inr T1 t2'

                               t0 --> t0'
               -------------------------------------------            (ST_Case)
                case t0 of inl x1 => t1 | inr x2 => t2 -->
               case t0' of inl x1 => t1 | inr x2 => t2

            -----------------------------------------------        (ST_CaseInl)
            case (inl T2 v1) of inl x1 => t1 | inr x2 => t2
                           -->  [x1:=v1]t1

            -----------------------------------------------        (ST_CaseInr)
            case (inr T1 v2) of inl x1 => t1 | inr x2 => t2
                           -->  [x2:=v1]t2

型付け:
                          Gamma |- t1 \in T1
                   ------------------------------                       (T_Inl)
                   Gamma |- inl T2 t1 \in T1 + T2

                          Gamma |- t2 \in T2
                   -------------------------------                      (T_Inr)
                    Gamma |- inr T1 t2 \in T1 + T2

                        Gamma |- t \in T1+T2
                     x1|->T1; Gamma |- t1 \in T
                     x2|->T2; Gamma |- t2 \in T
         ----------------------------------------------------          (T_Case)
         Gamma |- case t of inl x1 => t1 | inr x2 => t2 \in T

inlとinrに型を付記する理由は、関数に対して行ったのと同様、型付け規則を単純にするためです。
*)

(*リスト*)
(*
構文:
       t ::=                項
           | ...
           | nil T
           | cons t t
           | lcase t of nil  => t
                      | x::x => t

       v ::=                値
           | ...
           | nil T             nil値
           | cons v v          cons値

       T ::=                型
           | ...
           | List T            Tのリスト

簡約:
                                t1 --> t1'
                       --------------------------                    (ST_Cons1)
                       cons t1 t2 --> cons t1' t2

                                t2 --> t2'
                       --------------------------                    (ST_Cons2)
                       cons v1 t2 --> cons v1 t2'

                              t1 --> t1'
                -------------------------------------------         (ST_Lcase1)
                 (lcase t1 of nil => t2 | xh::xt => t3) -->
                (lcase t1' of nil => t2 | xh::xt => t3)

               -----------------------------------------          (ST_LcaseNil)
               (lcase nil T of nil => t2 | xh::xt => t3)
                                --> t2

            ------------------------------------------------     (ST_LcaseCons)
            (lcase (cons vh vt) of nil => t2 | xh::xt => t3)
                          --> [xh:=vh,xt:=vt]t3

型付け:
                        -------------------------                       (T_Nil)
                        Gamma |- nil T \in List T

             Gamma |- t1 \in T      Gamma |- t2 \in List T
             ---------------------------------------------             (T_Cons)
                    Gamma |- cons t1 t2 \in List T

                        Gamma |- t1 \in List T1
                        Gamma |- t2 \in T
                (h|->T1; t|->List T1; Gamma) |- t3 \in T
          ---------------------------------------------------         (T_Lcase)
          Gamma |- (lcase t1 of nil => t2 | h::t => t3) \in T

*)

(*一般再帰*)
(*
      fact = \x:Nat.
                test x=0 then 1 else x * (fact (pred x)))
のように書く代わりに、次のように書きます。
      fact =
          fix
            (\f:Nat->Nat.
               \x:Nat.
                  test x=0 then 1 else x * (f (pred x)))
*)

(*
構文:
       t ::=                項
           | ...
           | fix t             不動点演算子
簡約:
                                t1 --> t1'
                            ------------------                        (ST_Fix1)
                            fix t1 --> fix t1'

               --------------------------------------------         (ST_FixAbs)
               fix (\xf:T1.t2) --> [xf:=fix (\xf:T1.t2)] t2
型付け:
                           Gamma |- t1 \in T1->T1
                           ----------------------                       (T_Fix)
                           Gamma |- fix t1 \in T1
*)

(*レコード*)
(*
構文:
       t ::=                          項
           | ...
           | {i1=t1, ..., in=tn}         レコード
           | t.i                         射影

       v ::=                          値
           | ...
           | {i1=v1, ..., in=vn}         レコード値

       T ::=                          型
           | ...
           | {i1:T1, ..., in:Tn}         レコード型

簡約:
                              ti --> ti'
                 ------------------------------------                  (ST_Rcd)
                     {i1=v1, ..., im=vm, in=ti , ...}
                 --> {i1=v1, ..., im=vm, in=ti', ...}

                              t1 --> t1'
                            --------------                           (ST_Proj1)
                            t1.i --> t1'.i

                      -------------------------                    (ST_ProjRcd)
                      {..., i=vi, ...}.i --> vi

型付け；
            Gamma |- t1 \in T1     ...     Gamma |- tn \in Tn
          ----------------------------------------------------          (T_Rcd)
          Gamma |- {i1=t1, ..., in=tn} \in {i1:T1, ..., in:Tn}

                    Gamma |- t \in {..., i:Ti, ...}
                    -------------------------------                    (T_Proj)
                          Gamma |- t.i \in Ti

*)

(*構文*)
Inductive ty : Type :=
  | Arrow : ty -> ty -> ty
  | Nat : ty
  | Sum : ty -> ty -> ty (*直和*)
  | List : ty -> ty
  | Unit : ty
  | Prod : ty -> ty -> ty (*直積*) .

Inductive tm : Type :=
  (*puree*)
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  (*数値*)
  | const : nat -> tm
  | scc : tm -> tm
  | prd : tm -> tm
  | mlt : tm -> tm -> tm
  | test0 : tm -> tm -> tm -> tm
  (*直和*)
  | tinl : ty -> tm -> tm
  | tinr : ty -> tm -> tm
  | tcase : tm -> string -> tm -> string -> tm -> tm
  (*リスト*)
  | tnil : ty -> tm
  | tcons : tm -> tm -> tm
  | tlcase : tm -> tm -> string -> string -> tm -> tm
  (*Unit*)
  | unit : tm
  (*直積*)
  | pair : tm -> tm -> tm
  | fst : tm -> tm
  | snd : tm -> tm
  (*let*)
  | tlet : string -> tm -> tm -> tm
  (*fix*)
  | tfix : tm -> tm.

(*置換*)
Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with

  | var y =>
      if eqb_string x y then s else t
  | abs y T t1 =>
      abs y T (if eqb_string x y then t1 else (subst x s t1))
  | app t1 t2 =>
      app (subst x s t1) (subst x s t2)

  | const n =>
      const n
  | scc t1 =>
      scc (subst x s t1)
  | prd t1 =>
      prd (subst x s t1)
  | mlt t1 t2 =>
      mlt (subst x s t1) (subst x s t2)
  | test0 t1 t2 t3 =>
      test0 (subst x s t1) (subst x s t2) (subst x s t3)

  | tinl T t1 =>
      tinl T (subst x s t1)
  | tinr T t1 =>
      tinr T (subst x s t1)
  | tcase t0 y1 t1 y2 t2 =>
      tcase (subst x s t0)
         y1 (if eqb_string x y1 then t1 else (subst x s t1))
         y2 (if eqb_string x y2 then t2 else (subst x s t2))

  | tnil T =>
      tnil T
  | tcons t1 t2 =>
      tcons (subst x s t1) (subst x s t2)
  | tlcase t1 t2 y1 y2 t3 =>
      tlcase (subst x s t1) (subst x s t2) y1 y2
        (if eqb_string x y1 then
           t3
         else if eqb_string x y2 then t3
              else (subst x s t3))

  | unit => unit

  | _ => t
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(*簡約*)

Inductive value : tm -> Prop :=
  (*pure*)
  | v_abs : forall x T11 t12,
      value (abs x T11 t12)
  (*数値*)
  | v_nat : forall n1,
      value (const n1)
  (*直和*)
  | v_inl : forall v T,
      value v ->
      value (tinl T v)
  | v_inr : forall v T,
      value v ->
      value (tinr T v)
  (*リスト*)
  | v_lnil : forall T, value (tnil T)
  | v_lcons : forall v1 vl,
      value v1 ->
      value vl ->
      value (tcons v1 vl)
  (*unit*)
  | v_unit : value unit
  (*直積*)
  | v_pair : forall v1 v2,
      value v1 ->
      value v2 ->
      value (pair v1 v2).

Hint Constructors value.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  (*pure*)
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (app (abs x T11 t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         (app t1 t2) --> (app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         (app v1 t2) --> (app v1 t2')
  (*数値*)
  | ST_Succ1 : forall t1 t1',
       t1 --> t1' ->
       (scc t1) --> (scc t1')
  | ST_SuccNat : forall n1,
       (scc (const n1)) --> (const (S n1))
  | ST_Pred : forall t1 t1',
       t1 --> t1' ->
       (prd t1) --> (prd t1')
  | ST_PredNat : forall n1,
       (prd (const n1)) --> (const (pred n1))
  | ST_Mult1 : forall t1 t1' t2,
       t1 --> t1' ->
       (mlt t1 t2) --> (mlt t1' t2)
  | ST_Mult2 : forall v1 t2 t2',
       value v1 ->
       t2 --> t2' ->
       (mlt v1 t2) --> (mlt v1 t2')
  | ST_Mulconsts : forall n1 n2,
       (mlt (const n1) (const n2)) --> (const (mult n1 n2))
  | ST_Test01 : forall t1 t1' t2 t3,
       t1 --> t1' ->
       (test0 t1 t2 t3) --> (test0 t1' t2 t3)
  | ST_Test0Zero : forall t2 t3,
       (test0 (const 0) t2 t3) --> t2
  | ST_Test0Nonzero : forall n t2 t3,
       (test0 (const (S n)) t2 t3) --> t3
  (*直和*)
  | ST_Inl : forall t1 t1' T,
        t1 --> t1' ->
        (tinl T t1) --> (tinl T t1')
  | ST_Inr : forall t1 t1' T,
        t1 --> t1' ->
        (tinr T t1) --> (tinr T t1')
  | ST_Case : forall t0 t0' x1 t1 x2 t2,
        t0 --> t0' ->
        (tcase t0 x1 t1 x2 t2) --> (tcase t0' x1 t1 x2 t2)
  | ST_CaseInl : forall v0 x1 t1 x2 t2 T,
        value v0 ->
        (tcase (tinl T v0) x1 t1 x2 t2) --> [x1:=v0]t1
  | ST_CaseInr : forall v0 x1 t1 x2 t2 T,
        value v0 ->
        (tcase (tinr T v0) x1 t1 x2 t2) --> [x2:=v0]t2
  (*リスト*)
  | ST_Cons1 : forall t1 t1' t2,
       t1 --> t1' ->
       (tcons t1 t2) --> (tcons t1' t2)
  | ST_Cons2 : forall v1 t2 t2',
       value v1 ->
       t2 --> t2' ->
       (tcons v1 t2) --> (tcons v1 t2')
  | ST_Lcase1 : forall t1 t1' t2 x1 x2 t3,
       t1 --> t1' ->
       (tlcase t1 t2 x1 x2 t3) --> (tlcase t1' t2 x1 x2 t3)
  | ST_LcaseNil : forall T t2 x1 x2 t3,
       (tlcase (tnil T) t2 x1 x2 t3) --> t2
  | ST_LcaseCons : forall v1 vl t2 x1 x2 t3,
       value v1 ->
       value vl ->
       (tlcase (tcons v1 vl) t2 x1 x2 t3)
         --> (subst x2 vl (subst x1 v1 t3))
  (*UnitはStepない*)
  (*直積*)
  | ST_Pair1 : forall t1 t1' t2,
      t1 --> t1' ->
      pair t1 t2 --> pair t1' t2
  | ST_Pair2 : forall t1 t2 t2',
      value t1 ->
      t2 --> t2' ->
      pair t1 t2 --> pair t1 t2'
  | ST_Fst1 : forall t1 t1',
      t1 --> t1' ->
      fst t1 --> fst t1'
  | ST_FstPair : forall v1 v2,
      value (pair v1 v2) ->
      fst (pair v1 v2) --> v1
  | ST_Snd1 : forall t1 t1',
      t1 --> t1' ->
      snd t1 --> snd t1'
  | ST_SndPair : forall v1 v2,
      value (pair v1 v2) ->
      snd (pair v1 v2) --> v2
  (*let*)
  | ST_Let1 : forall x t1 t1' t2,
      t1 --> t1' ->
      tlet x t1 t2 --> tlet x t1' t2
  | ST_LetValue : forall x v1 t2,
      value v1 ->
      tlet x v1 t2 --> [x:= v1]t2
  (*fix*)
  | ST_Fix1 : forall t1 t1',
      t1 --> t1' ->
      tfix t1 --> tfix t1'
  | ST_FixAbs : forall x T t,
      tfix (abs x T t) --> [x:= tfix (abs x T t)]t
where "t1 '-->' t2" := (step t1 t2).

Notation multistep := (multi step).

Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Hint Constructors step.

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  (*pure*)
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- (var x) \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      (update Gamma x T11) |- t12 \in T12 ->
      Gamma |- (abs x T11 t12) \in (Arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (Arrow T1 T2) ->
      Gamma |- t2 \in T1 ->
      Gamma |- (app t1 t2) \in T2
  (*数値*)
  | T_Nat : forall Gamma n1,
      Gamma |- (const n1) \in Nat
  | T_Succ : forall Gamma t1,
      Gamma |- t1 \in Nat ->
      Gamma |- (scc t1) \in Nat
  | T_Pred : forall Gamma t1,
      Gamma |- t1 \in Nat ->
      Gamma |- (prd t1) \in Nat
  | T_Mult : forall Gamma t1 t2,
      Gamma |- t1 \in Nat ->
      Gamma |- t2 \in Nat ->
      Gamma |- (mlt t1 t2) \in Nat
  | T_Test0 : forall Gamma t1 t2 t3 T1,
      Gamma |- t1 \in Nat ->
      Gamma |- t2 \in T1 ->
      Gamma |- t3 \in T1 ->
      Gamma |- (test0 t1 t2 t3) \in T1
  (*直和*)
  | T_Inl : forall Gamma t1 T1 T2,
      Gamma |- t1 \in T1 ->
      Gamma |- (tinl T2 t1) \in (Sum T1 T2)
  | T_Inr : forall Gamma t2 T1 T2,
      Gamma |- t2 \in T2 ->
      Gamma |- (tinr T1 t2) \in (Sum T1 T2)
  | T_Case : forall Gamma t0 x1 T1 t1 x2 T2 t2 T,
      Gamma |- t0 \in (Sum T1 T2) ->
      (update Gamma x1 T1) |- t1 \in T ->
      (update Gamma x2 T2) |- t2 \in T ->
      Gamma |- (tcase t0 x1 t1 x2 t2) \in T
  (*リスト*)
  | T_Nil : forall Gamma T,
      Gamma |- (tnil T) \in (List T)
  | T_Cons : forall Gamma t1 t2 T1,
      Gamma |- t1 \in T1 ->
      Gamma |- t2 \in (List T1) ->
      Gamma |- (tcons t1 t2) \in (List T1)
  | T_Lcase : forall Gamma t1 T1 t2 x1 x2 t3 T2,
      Gamma |- t1 \in (List T1) ->
      Gamma |- t2 \in T2 ->
      (update (update Gamma x2 (List T1)) x1 T1) |- t3 \in T2 ->
      Gamma |- (tlcase t1 t2 x1 x2 t3) \in T2
  (*Unit*)
  | T_Unit : forall Gamma,
      Gamma |- unit \in Unit
  (*直積*)
  | T_Pair : forall Gemma t1 t2 T1 T2,
      Gemma |- t1 \in T1 ->
      Gemma |- t2 \in T2 ->
      Gemma |- (pair t1 t2) \in (Prod T1 T2)
  | T_Fst : forall Gemma t T1 T2,
      Gemma |- t \in (Prod T1 T2) ->
      Gemma |- fst t \in T1
  | T_Snd : forall Gemma t T1 T2,
      Gemma |- t \in (Prod T1 T2) ->
      Gemma |- snd t \in T2
  (*let*)
  | T_Let : forall Gemma x t1 t2 T1 T2,
      Gemma |- t1 \in T1 ->
      (update Gemma x T1) |- t2 \in T2 ->
      Gemma |- (tlet x t1 t2) \in T2
(*fix*)
  | T_Fix : forall Gemma t1 T1,
      Gemma |- t1 \in (Arrow T1 T1) ->
      Gemma |- (tfix t1) \in T1
where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

Definition manual_grade_for_extensions_definition : option (nat*string) := None.

Module Examples.

Open Scope string_scope.
Notation x := "x".
Notation y := "y".
Notation a := "a".
Notation f := "f".
Notation g := "g".
Notation l := "l".
Notation k := "k".
Notation i1 := "i1".
Notation i2 := "i2".
Notation processSum := "processSum".
Notation n := "n".
Notation eq := "eq".
Notation m := "m".
Notation evenodd := "evenodd".
Notation even := "even".
Notation odd := "odd".
Notation eo := "eo".

Module Numtest.

Definition test :=
  test0
    (prd
      (scc
        (prd
          (mlt
            (const 2)
            (const 0)))))
    (const 5)
    (const 6).

Example typechecks :
  empty |- test \in Nat.
Proof.
  unfold test.
  auto 10.
Qed.

Example numtest_reduces :
  test -->* const 5.
Proof.
  unfold test. eauto 20. Qed.
  (* econstructor. constructor. constructor. constructor. constructor. apply ST_Mulconsts. *)
  (* econstructor. constructor. constructor. constructor. apply ST_PredNat. *)
  (* econstructor. constructor. constructor. apply ST_SuccNat. *)
  (* econstructor. constructor. apply ST_PredNat. *)
  (* econstructor. apply ST_Test0Zero. *)
  (* constructor. *)
(* Qed. *)

End Numtest.

Module Prodtest.

Definition test :=
  snd
    (fst
      (pair
        (pair
          (const 5)
          (const 6))
        (const 7))).

Example typechecks :
  empty |- test \in Nat.
Proof. unfold test. eauto 15. Qed.

Example reduces :
  test -->* const 6.
Proof.
  unfold test.
  econstructor. constructor. apply ST_FstPair; constructor; constructor; constructor.
  econstructor. apply ST_SndPair; constructor; constructor.
  constructor.
Qed.

End Prodtest.

Module LetTest.

Definition test :=
  tlet
    x
    (prd (const 6))
    (scc (var x)).

Example typechecks :
  empty |- test \in Nat.
Proof. unfold test. eauto 15. Qed.

Example reduces :
  test -->* const 6.
Proof.
  unfold test.
  econstructor. constructor. apply ST_PredNat.
  econstructor. apply ST_LetValue. constructor.
  econstructor. unfold subst. rewrite <- eqb_string_refl. simpl. apply ST_SuccNat.
  constructor.
Qed.

End LetTest.

Module Sumtest1.

Definition test :=
  tcase (tinl Nat (const 5))
    x (var x)
    y (var y).

Example typechecks :
  empty |- test \in Nat.
Proof. unfold test. eauto 15. Qed.

Example reduces :
  test -->* (const 5).
Proof.
  unfold test.
  econstructor. apply ST_CaseInl. constructor.
  constructor.
Qed.

End Sumtest1.

Module Sumtest2.

Definition test :=
  tlet
    processSum
    (abs x (Sum Nat Nat)
      (tcase (var x)
         n (var n)
         n (test0 (var n) (const 1) (const 0))))
    (pair
      (app (var processSum) (tinl Nat (const 5)))
      (app (var processSum) (tinr Nat (const 5)))).

Example typechecks :
  empty |- test \in (Prod Nat Nat).
Proof.
  unfold test.
  econstructor. constructor. econstructor; constructor. constructor. constructor. constructor. constructor. constructor. constructor.
  econstructor. econstructor; constructor. constructor. constructor. econstructor. constructor. constructor.
  constructor. constructor.
Qed.

Example reduces :
  test -->* (pair (const 5) (const 0)).
Proof.
  unfold test.
  econstructor. apply ST_LetValue. constructor.
  econstructor. Abort.

End Sumtest2.

Module ListTest.

Definition test :=
  tlet l
    (tcons (const 5) (tcons (const 6) (tnil Nat)))
    (tlcase (var l)
       (const 0)
       x y (mlt (var x) (var x))).

Example typechecks :
  empty |- test \in Nat.
Proof.
  unfold test.
  econstructor. constructor. constructor. constructor. constructor. constructor.
  econstructor. constructor. constructor. constructor. constructor. constructor. constructor. constructor. constructor.
Qed.

Example reduces :
  test -->* (const 25).
Proof.
  unfold test.
  econstructor. apply ST_LetValue. constructor. constructor. constructor. constructor. constructor.
  econstructor. simpl. apply ST_LcaseCons. constructor. constructor. constructor. constructor.
  econstructor. simpl. apply ST_Mulconsts.
  constructor.
Qed.

End ListTest.

Module FixTest1.

Definition fact :=
  tfix
    (abs f (Arrow Nat Nat)
      (abs a Nat
        (test0
           (var a)
           (const 1)
           (mlt
              (var a)
              (app (var f) (prd (var a))))))).

Example typechecks :
  empty |- fact \in (Arrow Nat Nat).
Proof.
  unfold fact.
  econstructor. constructor. constructor. constructor.
  constructor. constructor.
  constructor.
  constructor.
  constructor. constructor.
  econstructor. constructor. constructor. constructor. constructor. constructor.
Qed.

Example reduces :
  (app fact (const 4)) -->* (const 24).
Proof.
  unfold fact. normalize.
  (* econstructor. constructor. apply ST_FixAbs. *)
  (* simpl. econstructor. constructor. constructor. *)
  (* econstructor. unfold subst. simpl. apply ST_Test0Nonzero. *)
  (* econstructor. apply ST_Mult2. constructor. constructor. apply ST_FixAbs. *)
  (* econstructor. apply ST_Mult2. constructor. simpl. apply ST_App2. constructor. apply ST_PredNat. *)
  (* econstructor. apply ST_Mult2. constructor. apply ST_AppAbs. constructor. *)
  (* econstructor. apply ST_Mult2. constructor. simpl. apply ST_Test0Nonzero. *)
  (* econstructor. apply ST_Mult2. constructor. apply ST_Mult2. constructor. apply ST_App1. apply ST_FixAbs. *)
  (* econstructor. apply ST_Mult2. constructor. apply ST_Mult2. constructor. apply ST_App2. constructor. apply ST_PredNat. *)
  (* econstructor. apply ST_Mult2. constructor. simpl. apply ST_Mult2. constructor. apply ST_AppAbs. constructor. *)
  (* econstructor. apply ST_Mult2. constructor. simpl. apply ST_Mult2. constructor. apply ST_Test0Nonzero. *)
  (* econstructor. apply ST_Mult2. constructor. simpl. apply ST_Mult2. constructor. apply ST_Mult2. constructor. apply ST_App1. apply ST_FixAbs. *)
  (* econstructor. apply ST_Mult2. constructor. simpl. apply ST_Mult2. constructor. apply ST_Mult2. constructor. apply ST_App2. constructor. apply ST_PredNat. *)
  (* econstructor. apply ST_Mult2. constructor. simpl. apply ST_Mult2. constructor. apply ST_Mult2. constructor. apply ST_AppAbs. constructor. *)
  (* econstructor. apply ST_Mult2. constructor. simpl. apply ST_Mult2. constructor. apply ST_Mult2. constructor. apply ST_Test0Nonzero. *)
  (*以下略*)
Qed.

End FixTest1.

Module FixTest2.

Definition map :=
  abs g (Arrow Nat Nat)
    (tfix
      (abs f (Arrow (List Nat) (List Nat))
        (abs l (List Nat)
          (tlcase (var l)
            (tnil Nat)
            a l (tcons (app (var g) (var a))
                         (app (var f) (var l))))))).

Example typechecks :
  empty |- map \in
    (Arrow (Arrow Nat Nat)
      (Arrow (List Nat)
        (List Nat))).
Proof.
  unfold map.
  econstructor. constructor. constructor. constructor.
  econstructor. constructor. constructor. constructor. constructor.
  econstructor. constructor. constructor. constructor. constructor.
  econstructor. constructor. constructor.
  constructor. constructor.
Qed.

Example reduces :
  app (app map (abs a Nat (scc (var a))))
         (tcons (const 1) (tcons (const 2) (tnil Nat)))
  -->* (tcons (const 2) (tcons (const 3) (tnil Nat))).
Proof.
  econstructor. constructor. constructor. constructor.
  econstructor. constructor. simpl. apply ST_FixAbs.
  econstructor. simpl. constructor. constructor. constructor. constructor. constructor. constructor.
  econstructor. simpl. apply ST_LcaseCons. constructor. constructor. constructor. constructor.
  econstructor. simpl. apply ST_Cons1. constructor. Abort.

End FixTest2.

End Examples.

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t --> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  generalize dependent HeqGamma.
  induction Ht; intros HeqGamma; subst.
  -

    inversion H.
  -

    left...
  -

    right.
    destruct IHHt1; subst...
    +
      destruct IHHt2; subst...
      *

        inversion H; subst; try solve_by_invert.
        exists (subst x t2 t12)...
      *

        inversion H0 as [t2' Hstp]. exists (app t1 t2')...
    +

      inversion H as [t1' Hstp]. exists (app t1' t2)...
  -
    left...
  -
    right.
    destruct IHHt...
    +
      inversion H; subst; try solve_by_invert.
      exists (const (S n1))...
    +
      inversion H as [t1' Hstp].
      exists (scc t1')...
  -
    right.
    destruct IHHt...
    +
      inversion H; subst; try solve_by_invert.
      exists (const (pred n1))...
    +
      inversion H as [t1' Hstp].
      exists (prd t1')...
  -
    right.
    destruct IHHt1...
    +
      destruct IHHt2...
      *
        inversion H; subst; try solve_by_invert.
        inversion H0; subst; try solve_by_invert.
        exists (const (mult n1 n0))...
      *
        inversion H0 as [t2' Hstp].
        exists (mlt t1 t2')...
    +
      inversion H as [t1' Hstp].
      exists (mlt t1' t2)...
  -
    right.
    destruct IHHt1...
    +
      inversion H; subst; try solve_by_invert.
      destruct n1 as [|n1'].
      *
        exists t2...
      *
        exists t3...
    +
      inversion H as [t1' H0].
      exists (test0 t1' t2 t3)...
  -
    destruct IHHt...
    +
      right. inversion H as [t1' Hstp]...
  -
    destruct IHHt...
    +
      right. inversion H as [t1' Hstp]...
  -
    right.
    destruct IHHt1...
    +
      inversion H; subst; try solve_by_invert.
      *
        exists ([x1:=v]t1)...
      *
        exists ([x2:=v]t2)...
    +
      inversion H as [t0' Hstp].
      exists (tcase t0' x1 t1 x2 t2)...
  -
    left...
  -
    destruct IHHt1...
    +
      destruct IHHt2...
      *
        right. inversion H0 as [t2' Hstp].
        exists (tcons t1 t2')...
    +
      right. inversion H as [t1' Hstp].
      exists (tcons t1' t2)...
  -
    right.
    destruct IHHt1...
    +
      inversion H; subst; try solve_by_invert.
      *
        exists t2...
      *
        exists ([x2:=vl]([x1:=v1]t3))...
    +
      inversion H as [t1' Hstp].
      exists (tlcase t1' t2 x1 x2 t3)...
  -
    left...
  -
    destruct IHHt1... destruct IHHt2...
    inversion H0. right. exists (pair t1 x). constructor; assumption.
    inversion H. right. exists (pair x t2). constructor; assumption.
  -
    right. destruct IHHt...
    inversion H; subst; inversion Ht; subst. exists v1. constructor; assumption.
    inversion H. exists (fst x). constructor; assumption.
  -
    right. destruct IHHt...
    inversion H; subst; inversion Ht; subst. exists v2. constructor; assumption.
    inversion H. exists (snd x). constructor; assumption.
  -
    destruct IHHt1... inversion H. right. exists (tlet x x0 t2). constructor; assumption.
  -
    right. destruct IHHt...
    inversion H; subst; inversion Ht; subst. exists ([x:= tfix (abs x T1 t12)]t12). apply ST_FixAbs.
    inversion H. exists (tfix x). constructor. assumption.
Qed.

Definition manual_grade_for_progress : option (nat*string) := None.

End STLCExtended.


(******************************************************************************)
(* Binary trees and their forests                                             *)
(*             bintree := a binary tree                                       *)
(*              forest := a sequence of trees                                 *)
(*        count_node t := the number of nodes on a tree t                     *)
(* count_node_forest f := the number of nodes on a forest f                   *)
(*          subtrees t := trees just below the root of a tree t               *)
(*         subforest f := subtrees of trees in a forest f                     *)
(*                                                                            *)
(* Specifications of leaves:                                                  *)
(*             leave_spec := a sequence specifying the number of leaves at    *)
(*                           each level in a forest                           *)
(* satisfy_leave_spec f s := check whether a forest f satisfies a spec s      *)
(*                           (for a tree t, use satisfy_leave_spec [:: t] s)  *)
(*                                                                            *)
(* Forest lifts:                                                              *)
(*    simple_lift f : adds one node on to the top of each tree in a forest f  *)
(* pairing_lift p f : divides trees in a forest f into p pairs and other      *)
(*                    individuals, and adds one node on to the top of each    *)
(*                    group                                                   *)
(*                                                                            *)
(* Bounds:                                                                    *)
(*     lower_bound_bottomup s, : a tight bound of the size of forests that    *)
(*     upper_bound_bottomup s    satisfy a spec s; see in_bottomup_boundP     *)
(* lower_bounds_backforth s n, : tight bounds of the number of nodes at all   *)
(* upper_bounds_backforth s n    levels of forests consisting n trees and     *)
(*                               satisfying a spec s                          *)
(*      lower_bound_total s n, : a tight bound of the total numbers of nodes  *)
(*      upper_bound_total s n    in forests consisting n trees and satisfying *)
(*                               a spec s; see in_total_boundP                *)
(*                                                                            *)
(* Efficiently computed bounds:                                               *)
(*    lower_bounds_topdown s n, : bounds of the number of nodes at all levels *)
(*    upper_bounds_topdown s n    of forests consisting n trees and           *)
(*                                satisfying a spec s; they may not be tight  *)
(* lower_bounds_backforth' s n, : the same as lower/upper_bound_backforth     *)
(* upper_bounds_backforth' s n                                                *)
(*      lower_bound_total' s n, : the same as lower/upper_bound_total; the    *)
(*      upper_bound_total' s n    time complexity is Θ(|s|) (|s| is the size  *)
(*                                of s)                                       *)
(******************************************************************************)

From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

From Coq Require Import Lia.
From mathcomp.zify Require Import zify.

Section SsrnatExt.
Lemma leq_div2 n : n./2 <= n.
Proof. by rewrite -divn2 leq_div. Qed.

Lemma leq_uphalf n : uphalf n <= n.
Proof.
  rewrite [in X in _ <= X](divn_eq n 2) addnC uphalf_half -modn2 -divn2.
  by apply: leq_add => //; apply: leq_pmulr.
Qed.

Lemma homo_maxl n :
  {homo maxn n : m l / m <= l}.
Proof.
  move=> m l leq_ml.
  by rewrite geq_max leq_maxl leq_max leq_ml orbT.
Qed.

Lemma homo_minl n :
  {homo minn n : m l / m <= l}.
Proof.
  move=> m l leq_ml.
  by rewrite leq_min geq_minl geq_min leq_ml orbT.
Qed.
End SsrnatExt.

Section SeqExt.
Lemma flatten_nseq_nil (T : Type) (n : nat) :
  @flatten T (nseq n [::]) = [::].
Proof. by elim: n. Qed.

Section Map.
  Variable A B C : Type.

  Definition map2 (f : A -> B -> C) :=
    fix map2 (s1 : seq A) (s2 : seq B) :=
      match s1, s2 with
        x :: s1', y :: s2' => f x y :: map2 s1' s2'
      | _, _ => [::]
      end.
End Map.

Section Scan.
Variable T S : Type.
Variable f : T -> S -> S.
Variable y0 : S.

Fixpoint scanr_aux (s : seq T) : {r : seq S | size r > 0} :=
  match s with
    [::] => exist _ [:: y0] erefl
  | x :: s' =>
      match scanr_aux s' with
        exist r Hr =>
          (match r return size r > 0 -> {r : seq S | size r > 0} with
             [::] => fun cont => match notF cont with end
           | y :: _ => fun Hr => exist _ (f x y :: r) erefl
           end) Hr
      end
  end.

Lemma scanr_auxE (x : T) (s' : seq T) :
  scanr_aux (x :: s') =
    match scanr_aux s' with
      exist r Hr =>
        (match r return size r > 0 -> {r : seq S | size r > 0} with
           [::] => fun cont => match notF cont with end
         | y :: _ => fun Hr => exist _ (f x y :: r) erefl
         end) Hr
    end.
Proof. by []. Qed.

Definition scanr (s : seq T) := proj1_sig (scanr_aux s).

Lemma scanrE (x : T) (s : seq T) :
  scanr (x :: s) = foldr f y0 (x :: s) :: scanr s.
Proof.
  rewrite /scanr.
  elim: s => // x' s' IH in x *.
  rewrite scanr_auxE.
  case: (scanr_aux (x' :: s')) (IH x') => /= r Hr Er.
  rewrite Er /= in Hr *.
  by congr (_ :: _).
Qed.
End Scan.
End SeqExt.

Section BinaryTree.
Inductive bintree := L | B1 of bintree | B2 of bintree & bintree.
Definition forest := seq bintree.

Fixpoint bintree_eq (t1 t2 : bintree) :=
  match t1, t2 with
  | L, L => true
  | B1 t1', B1 t2' => bintree_eq t1' t2'
  | B2 t11 t12, B2 t21 t22 => bintree_eq t11 t21 && bintree_eq t12 t22
  | _, _ => false
  end.

Lemma bintree_eqP : Equality.axiom bintree_eq.
Proof.
move=> t1 t2; apply/(iffP idP).
- elim: t1 t2 => [| t1' IH | t11 IH1 t12 IH2].
  + by case.
  + by case => //= t2' E; congr B1; apply: IH.
  + by case => //= t21 t22 /andP [E1 E2]; congr B2; [ apply: IH1 | apply: IH2 ].
- by move<-; elim: t1 => //= t11 IH1 t12 IH2; rewrite IH1 IH2.
Qed.

Canonical bintree_eqMixin := EqMixin bintree_eqP.
Canonical bintree_eqType := Eval hnf in EqType bintree bintree_eqMixin.

Fixpoint count_node (t : bintree) :=
  match t with
    L => 1
  | B1 t1 => (count_node t1).+1
  | B2 t1 t2 => (count_node t1 + count_node t2).+1
  end.

Definition count_node_forest (f : forest) :=
  sumn (map count_node f).

Lemma count_node_forest_cat (f1 f2 : forest) :
  count_node_forest (f1 ++ f2) = count_node_forest f1 + count_node_forest f2.
Proof. by rewrite /count_node_forest map_cat sumn_cat. Qed.

Lemma count_node_forest_nseq n t :
  count_node_forest (nseq n t) = (count_node t) * n.
Proof. by rewrite /count_node_forest map_nseq sumn_nseq. Qed.

Definition subtrees (t : bintree) : forest :=
  match t with
    L => [::]
  | B1 t => [:: t]
  | B2 t1 t2 => [:: t1; t2]
  end.

Definition subforest (f : forest) : forest :=
  flatten (map subtrees f).

Lemma subforest_cat f1 f2 :
  subforest (f1 ++ f2) = subforest f1 ++ subforest f2.
Proof. by rewrite /subforest map_cat flatten_cat. Qed.

Lemma subforest_nseq n t :
  subforest (nseq n t) = flatten (nseq n (subtrees t)).
Proof. by rewrite /subforest map_nseq. Qed.

Lemma eq_count_node t :
  count_node t = (count_node_forest (subtrees t)).+1.
Proof.
  rewrite /count_node_forest.
  by case: t => //= [t1 | t1 t2]; rewrite addn0.
Qed.

Lemma eq_count_node_forest f :
  count_node_forest f = size f + count_node_forest (subforest f).
Proof.
  rewrite /count_node_forest /subforest.
  elim: f => //= t0 f' IH.
  rewrite map_cat sumn_cat.
  rewrite -addn1 addn.[AC (2*2) ((3*2)*(1*4))] addn1.
  congr (_ + _) => //.
  by apply: eq_count_node.
Qed.
End BinaryTree.

Section LeaveSpec.
Definition leave_spec := seq nat.

Fixpoint satisfy_leave_spec (f : forest) (s : leave_spec) :=
  match s with
    [::] => f == [::]
  | l0 :: s' =>
      let f' := subforest f in
      (count_mem L f == l0) && satisfy_leave_spec f' s'
  end.
End LeaveSpec.

Definition lower_bound_bottomup (s : leave_spec) :=
  foldr (fun l0 lb => l0 + uphalf lb) 0 s.

Definition upper_bound_bottomup (s : leave_spec) :=
  foldr (fun l0 ub => l0 + ub) 0 s.

Lemma leq_bottomup_bound (s : leave_spec) :
  lower_bound_bottomup s <= upper_bound_bottomup s.
Proof.
  elim: s => //= l0 s' IH.
  by rewrite leq_add2l (leq_trans _ IH) ?leq_uphalf.
Qed.

Section ForestLift.
Definition simple_lift (f : forest) := map B1 f.

Fixpoint pairing_lift (p : nat) (f : forest) :=
  match p, f with
    p'.+1, t0 :: t1 :: f' => B2 t0 t1 :: pairing_lift p' f'
  | _, _ => simple_lift f
  end.

Lemma subforest_simple_lift f :
  subforest (simple_lift f) = f.
Proof.
  rewrite /subforest.
  elim: f => //= t0 f' IH.
  by congr (_ :: _).
Qed.

Lemma subforest_pairing_lift p f :
  subforest (pairing_lift p f) = f.
Proof.
  rewrite /subforest.
  elim: p f => [| p' IH]; first by apply: subforest_simple_lift.
  case => [| t0 [| t1 f']] //=.
  by congr (_ :: _ :: _).
Qed.

Lemma size_simple_lift f :
  size (simple_lift f) = size f.
Proof. by rewrite size_map. Qed.

Lemma size_pairing_lift p f :
  p <= half (size f) ->
  size (pairing_lift p f) = size f - p.
Proof.
  elim: p => [| p' IH] in f *.
  - by rewrite subn0 size_simple_lift.
  - case: f => [| t0 [| t1 f']] //= /[!ltnS] ltn_p'.
    rewrite subSS subSn; last first.
    + by apply/(leq_trans ltn_p')/leq_div2.
    + by congr _.+1; apply: IH.
Qed.

Lemma count_mem_L_simple_lift f :
  count_mem L (simple_lift f) = 0.
Proof. by rewrite count_map count_pred0. Qed.

Lemma count_mem_L_pairing_lift p f :
  count_mem L (pairing_lift p f) = 0.
Proof.
  elim: p => [| p' IH] in f *; first by rewrite count_mem_L_simple_lift.
  case: f => [| t0 [| t1 f']] //=.
  by rewrite add0n.
Qed.

Lemma count_node_forest_pairing_lift p f :
  p <= half (size f) ->
  count_node_forest (pairing_lift p f) = count_node_forest f + (size f - p).
Proof.
  move=> ltn_p.
  rewrite eq_count_node_forest.
  by rewrite size_pairing_lift // subforest_pairing_lift addnC.
Qed.
End ForestLift.

Lemma in_size_forest f :
  count_mem L f + uphalf (size (subforest f)) <= size f <= count_mem L f + size (subforest f).
Proof.
  rewrite /subforest.
  elim: f => // t0 f' IH.
  case: t0 => [| t0' | t01 t02] /=.
  - by rewrite add1n !addSn ltnS.
  - case/andP: IH => IHlb IHub.
    rewrite add0n !addnS !ltnS; apply/andP; split => //.
    by rewrite (leq_trans _ IHlb) ?leq_add2l ?uphalf_half ?leq_addl.
  - case/andP: IH => IHlb IHub.
    rewrite add0n !addnS !ltnS; apply/andP; split => //.
    by rewrite (leq_trans IHub).
Qed.

Proposition in_bottomup_boundP (n : nat) (s : leave_spec) :
  reflect (exists2 f, size f = n & satisfy_leave_spec f s) (lower_bound_bottomup s <= n <= upper_bound_bottomup s).
Proof.
  apply: (iffP idP).
  - elim: s => [| l0 s' IH] /= in n *.
    + by rewrite leqn0 => /eqP ->; exists [::].
    + move=> ineq_n.
      set lbb' := lower_bound_bottomup s'.
      set ubb' := upper_bound_bottomup s'.
      set i0 := n - l0.
      case: (leqP lbb' i0).
      * move=> le_lbb'_i0.
        have ineq_i0 : lbb' <= i0 <= ubb' by lia.
        case: (IH _ ineq_i0) => f' eq_size_f' sat_f'.
        exists (simple_lift f' ++ nseq l0 L).
        -- by rewrite size_cat size_simple_lift eq_size_f' size_nseq; lia.
        -- apply/andP; split.
           ++ by rewrite count_cat count_mem_L_simple_lift count_nseq mul1n.
           ++ rewrite subforest_cat subforest_simple_lift.
              by rewrite subforest_nseq flatten_nseq_nil cats0.
      * move=> lt_i0_lbb'.
        have ? := leq_bottomup_bound s'.
        have ineq_lbb' : lbb' <= lbb' <= ubb' by lia.
        case: (IH _ ineq_lbb') => f' eq_size_f' sat_f'.
        exists (pairing_lift (lbb' - i0) f' ++ nseq l0 L).
        -- by rewrite size_cat size_pairing_lift ?eq_size_f' ?size_nseq; lia.
        -- apply/andP; split.
           ++ by rewrite count_cat count_mem_L_pairing_lift count_nseq mul1n.
           ++ rewrite subforest_cat subforest_pairing_lift.
              by rewrite subforest_nseq flatten_nseq_nil cats0.
  - elim: s => [| l0 s' IH] in n *.
    + by case; case; case: n. (* :) *)
    + set lbb' := lower_bound_bottomup s'.
      set ubb' := upper_bound_bottomup s'.
      case => f Esize /= /andP [/eqP EcountL sat].
      have /[!Esize] /[!EcountL] := in_size_forest f.
      have : lbb' <= size (subforest f) <= ubb'.
      { by apply: IH; exists (subforest f). }
      by lia.
Qed.

Fixpoint lower_bounds_backforth (s : leave_spec) (n : nat) :=
  match s with
    [::] => [::]
  | l0 :: s' =>
      n :: lower_bounds_backforth s' (maxn (lower_bound_bottomup s') (n - l0))
  end.

Fixpoint upper_bounds_backforth (s : leave_spec) (n : nat) :=
  match s with
    [::] => [::]
  | l0 :: s' =>
      n :: upper_bounds_backforth s' (minn (upper_bound_bottomup s') (n - l0).*2)
  end.

Definition lower_bound_total s n :=
  sumn (lower_bounds_backforth s n).

Definition upper_bound_total s n :=
  sumn (upper_bounds_backforth s n).

Lemma homo_lower_bound_total s :
  {homo lower_bound_total s : n m / n <= m}.
Proof.
  rewrite /lower_bound_total.
  elim: s => //= l0 s' IH n m leq_nm.
  by apply/leq_add => //; apply/IH/homo_maxl/leq_sub2r.
Qed.

Lemma homo_upper_bound_total s :
  {homo (upper_bound_total s) : n m / n <= m}.
Proof.
  rewrite /upper_bound_total.
  elim: s => //= l0 s' IH n m leq_nm.
  apply/leq_add => //; apply/IH.
  by rewrite homo_minl ?leq_double ?leq_sub2r.
Qed.

Lemma leq_total_bound s n m :
  [&& lower_bound_bottomup s <= n, n <= m & m <= upper_bound_bottomup s] ->
  lower_bound_total s n <= upper_bound_total s m.
Proof.
  rewrite /lower_bound_total /upper_bound_total.
  elim: s => //= l0 s' IH in n m *.
  move=> ineq_nm.
  apply: leq_add; first by lia.
  by apply: IH; move: (leq_bottomup_bound s'); lia.
Qed.

Lemma consecutive_total_bounds_touch_each_other s n :
  lower_bound_bottomup s <= n ->
  n.+1 <= upper_bound_bottomup s ->
  lower_bound_total s n <= lower_bound_total s n.+1 <= (upper_bound_total s n).+1.
Proof.
  rewrite /lower_bound_total /upper_bound_total.
  case: s => //= l0 s' in n *.
  move=> geq_n leq_n1.
  apply/andP; split.
  - rewrite ltnW // addSn ltnS leq_add2l homo_lower_bound_total //.
    by lia.
  - rewrite addSn ltnS leq_add2l.
    apply: leq_total_bound.
    apply/and3P; split; [ apply: leq_maxl | | apply: geq_minl ].
    have := leq_bottomup_bound s'.
    suff : 1 <= n - l0 by lia.
    rewrite ltnNge.
    apply/negP => leq_nl0.
    have : upper_bound_bottomup s' > 0 by lia.
    apply/negP.
    rewrite -leqNgt leqn0.
    have : lower_bound_bottomup s' == 0 by lia.
    elim: s' {l0 n geq_n leq_n1 leq_nl0} => //= l1 s'' IH.
    by lia.
Qed.

Lemma interval_chain_forms_closed_interval (f g : nat -> nat) (a b n : nat) :
  a <= b ->
  (forall x, a <= x <= b -> f x <= g x) ->
  (forall x, a <= x -> x.+1 <= b -> f x <= f x.+1 <= (g x).+1) ->
  f a <= n <= g b ->
  exists2 m, a <= m <= b & f m <= n <= g m.
Proof.
  move/leP.
  elim: b / => [| b /leP leq_ab IH] leq_fg touching ineq_n.
  - by exists a; rewrite ?leqnn.
  - case: (leqP n (g b)) => [le_n_gb | lt_gb_n].
    + case: IH.
      * by move=> ??; apply: leq_fg; lia.
      * by move=> ???; apply: touching; lia.
      * by lia.
      * move=> m ineq_m ineq_fgm.
        exists m => //.
        by lia.
    + have ? := touching b leq_ab (leqnn _).
      by exists b.+1; lia.
Qed.

Lemma total_bound_chain_forms_closed_interval m s lb ub :
  [&& lower_bound_bottomup s <= lb, lb <= ub & ub <= upper_bound_bottomup s] ->
  lower_bound_total s lb <= m <= upper_bound_total s ub ->
  exists2 n, lb <= n <= ub & lower_bound_total s n <= m <= upper_bound_total s n.
Proof.
  move=> ineq_bound ineq_m.
  case: (@interval_chain_forms_closed_interval (lower_bound_total s) (upper_bound_total s) lb ub m) => //.
  - by lia.
  - by move=> ??; apply: leq_total_bound; lia.
  - by move=> ???; apply: consecutive_total_bounds_touch_each_other; lia.
  - by move=> n ??; exists n.
Qed.

Proposition in_total_boundP (n m : nat) (s : leave_spec) :
  lower_bound_bottomup s <= n <= upper_bound_bottomup s ->
  reflect (exists f, [/\ count_node_forest f = m, size f = n & satisfy_leave_spec f s]) (lower_bound_total s n <= m <= upper_bound_total s n).
Proof.
  rewrite /lower_bound_total /upper_bound_total.
  move=> ineq_n.
  apply: (iffP idP).
  - elim: s => [| l0 s' IH] /= in m n ineq_n *.
    + move: ineq_n; rewrite !leqn0; do 2!move/eqP->.
      by exists [::].
    + move=> ineq_m.
      set lb := maxn _ _ in ineq_m.
      set ub := minn _ _ in ineq_m.
      case: (@total_bound_chain_forms_closed_interval (m - n) s' lb ub).
      * by move: (leq_bottomup_bound s'); lia.
      * by rewrite /lower_bound_total /upper_bound_total; lia.
      * move=> n' ineq_n' ineq_m'.
        case: (IH (m - n) n').
        -- by lia.
        -- by rewrite /lower_bound_total /upper_bound_total in ineq_m'; lia.
        -- move=> f' [Ecount Esize sat].
           exists (pairing_lift (n' - (n - l0)) f' ++ nseq l0 L); split.
           ++ by rewrite count_node_forest_cat count_node_forest_pairing_lift ?Ecount ?Esize ?count_node_forest_nseq /=; lia.
           ++ by rewrite size_cat size_pairing_lift Esize ?size_nseq; lia.
           ++ apply/andP; split.
              ** by rewrite count_cat count_mem_L_pairing_lift count_nseq mul1n.
              ** rewrite subforest_cat subforest_pairing_lift.
                 by rewrite subforest_nseq flatten_nseq_nil cats0.
  - elim: s => [| l0 s' IH] /= in m n ineq_n *.
    + case => f [Ecount _ /eqP Ef].
      rewrite Ef in Ecount.
      by rewrite -Ecount.
    + case => f [Ecount Esize /andP [/eqP EcountL sat]].
      set f' := subforest f.
      have ineq_size_f' : lower_bound_bottomup s' <= size f' <= upper_bound_bottomup s'.
      { by apply/in_bottomup_boundP; exists f' => //. }
      have ex_f' : exists f, [/\ count_node_forest f = m - n, size f = size f' & satisfy_leave_spec f s'].
      {
        exists f'; split => //.
        by rewrite -Ecount (eq_count_node_forest f) Esize addKn.
      }
      have {ex_f'} := IH _ _ ineq_size_f' ex_f'.
      set lb := maxn _ _.
      set ub := minn _ _.
      have ineq_n' := in_size_forest f.
      rewrite EcountL Esize -/f' in ineq_n'.
      have : lower_bound_total s' lb <= lower_bound_total s' (size f').
      { by apply: homo_lower_bound_total; lia. }
      have : upper_bound_total s' (size f') <= upper_bound_total s' ub.
      { by apply: homo_upper_bound_total; lia. }
      have : n <= m.
      { by rewrite -Esize -Ecount eq_count_node_forest leq_addr. }
      rewrite /lower_bound_total /upper_bound_total.
      by lia.
Qed.

Definition lower_bounds_topdown (s : leave_spec) (n : nat) :=
  belast n (scanl subn n s).

Definition upper_bounds_topdown (s : leave_spec) (n : nat) :=
  belast n (scanl (fun ub l0 => (ub - l0).*2) n s).

Definition lower_bounds_bottomup s :=
  scanr (fun l0 lb : nat => l0 + uphalf lb) 0 s.

Definition upper_bounds_bottomup s :=
  scanr (fun l0 ub : nat => l0 + ub) 0 s.

Definition lower_bounds_backforth' s n :=
  map2 maxn (lower_bounds_bottomup s) (lower_bounds_topdown s n).

Definition upper_bounds_backforth' s n :=
  map2 minn (upper_bounds_bottomup s) (upper_bounds_topdown s n).

Lemma lower_bounds_backforth'E l0 s n :
  lower_bounds_backforth' (l0 :: s) n =
    maxn (lower_bound_bottomup (l0 :: s)) n :: lower_bounds_backforth' s (n - l0).
Proof. by rewrite /lower_bounds_backforth' /lower_bounds_bottomup scanrE. Qed.

Lemma upper_bounds_backforth'E l0 s n :
  upper_bounds_backforth' (l0 :: s) n =
    minn (upper_bound_bottomup (l0 :: s)) n :: upper_bounds_backforth' s (n - l0).*2.
Proof. by rewrite /upper_bounds_backforth' /upper_bounds_bottomup scanrE. Qed.

Definition lower_bound_total' s n :=
  sumn (lower_bounds_backforth' s n).

Definition upper_bound_total' s n :=
  sumn (upper_bounds_backforth' s n).

Lemma lower_bound_lower_bounds_backforth' s n :
  n <= lower_bound_bottomup s ->
  lower_bounds_backforth' s n = lower_bounds_backforth' s (lower_bound_bottomup s).
Proof.
  elim: s => //= l0 s' IH in n *.
  move=> leq_n.
  rewrite !lower_bounds_backforth'E /=.
  congr (_ :: _).
  - by rewrite maxnn; apply/maxn_idPl.
  - rewrite addKn !IH //.
    + by apply: leq_uphalf.
    + by lia.
Qed.

Lemma upper_bound_upper_bounds_backforth' s n :
  upper_bound_bottomup s <= n ->
  upper_bounds_backforth' s n = upper_bounds_backforth' s (upper_bound_bottomup s).
Proof.
  elim: s => //= l0 s' IH in n *.
  move=> leq_n.
  rewrite !upper_bounds_backforth'E /=.
  congr (_ :: _).
  - by rewrite minnn; apply/minn_idPl.
  - rewrite addKn !IH //.
    + by rewrite -mul2n leq_pmull.
    + by lia.
Qed.

Lemma lower_bounds_backforth_equiv s n :
  lower_bound_bottomup s <= n ->
  lower_bounds_backforth' s n = lower_bounds_backforth s n.
Proof.
  elim: s => //= l0 s' IH in n *.
  move=> geq_n.
  rewrite lower_bounds_backforth'E /=.
  congr (_ :: _).
  - by apply/maxn_idPr.
  - set lbb' := lower_bound_bottomup s'.
    case: (ltnP lbb' (n - l0)).
    + by move=> ?; apply/IH/ltnW.
    + by move=> le_nl0_lbb'; rewrite lower_bound_lower_bounds_backforth' // IH.
Qed.

Lemma upper_bounds_backforth_equiv s n :
  n <= upper_bound_bottomup s ->
  upper_bounds_backforth' s n = upper_bounds_backforth s n.
Proof.
  rewrite /upper_bound_total /upper_bound_total'.
  elim: s => //= l0 s' IH in n *.
  move=> leq_n.
  rewrite upper_bounds_backforth'E /=.
  congr (_ :: _).
  - by apply/minn_idPr.
  - set ubb' := upper_bound_bottomup s'.
    case: (ltnP (n - l0).*2 ubb').
    + by move=> ?; apply/IH/ltnW.
    + by move=> le_ubb'_nl02; rewrite upper_bound_upper_bounds_backforth' // IH.
Qed.

Lemma lower_bound_total_equiv s n :
  lower_bound_bottomup s <= n ->
  lower_bound_total' s n = lower_bound_total s n.
Proof. by move=> ?; rewrite /lower_bound_total' lower_bounds_backforth_equiv. Qed.

Lemma upper_bound_total_equiv s n :
  n <= upper_bound_bottomup s ->
  upper_bound_total' s n = upper_bound_total s n.
Proof. by move=> ?; rewrite /upper_bound_total' upper_bounds_backforth_equiv. Qed.

Require Extraction.
Extract Inductive list => "list" [ "[]" "( :: )" ].
Extract Inductive nat => "int" [ "0" "succ" ] "(fun fO fS n -> if n = 0 then fO () else fS (n - 1))".
Extract Inlined Constant addn => "( + )".
Extract Inlined Constant subn => "( - )".
Extract Inlined Constant maxn => "max".
Extract Inlined Constant minn => "min".
Extract Inlined Constant double => "(fun n -> n * 2)".
Extract Inlined Constant half => "(fun n -> n / 2)".
Extract Inlined Constant uphalf => "(fun n -> (n + 1) / 2)".
Extraction Inline scanr_aux.

Extraction "folia" lower_bound_bottomup upper_bound_total'.


(* begin hide *)
Require Import Coq.Lists.List.
Notation "[]" := nil : list_scope.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) .. ) : list_scope.
Open Scope bool_scope.
(* end hide *)
(** In this post, I will begin to formalize a small part of ##
combinatorial game theory## using Coq. Combinatorial game theory
attempts to model sequential, deterministic games between two players,
both of which take turns causing the game state to change. It
restricts itself to _perfect information_ games, where the current
configuration of the game is known to both players. Thus, it can be
used to study games such as chess, tic-tac-toe, and go, but not games
such as poker or blackjack.

The power of combinatorial game theory comes from abstracting away
details that are too specific to each game, such as whether it is
played moving pieces on a board, how the pieces can move, etc. It
defines a single mathematical object that can represent all games
uniformily, allowing us to study general situations that could occur
in many kinds of games. In this post, I will present this
representation and discuss why it makes sense. I will start with a
more intuitive formalization of combinatorial games, and then show how
combinatorial game theory applies to all of those.

** Defining combinatorial games

In combinatorial games, players are traditionally called _left_ and
_right_. *)

Inductive player : Type := Left | Right.

(** Each combinatorial game has a set of _positions_. In chess, for
instance, a position is a chess board with black and white pieces on
it. The rules of the game determine which _moves_ are available to
each player at a given position. They also describe how the game ends,
and which player wins in that case. To simplify our analysis, we will
assume that games end when some player must play but has no moves
left, in which case the other player wins. This frees us from having
to model how matches end separately for each game. We will also
consider only _finite_ games, i.e. ones that can't be played
indefinitely. Notice that these two assumptions taken together,
strictly speaking, rule out many interesting games: chess can end in a
draw, something that can't happen in our model.

Translating the above requirements into code results in the following
definition: *)

Inductive combinatorial_game := CombinatorialGame {
  position : Type;
  moves : player -> position -> list position;
  valid_move next current := exists s, In next (moves s current);
  finite_game : well_founded valid_move
}.

(** To formalize how games are played, we define a predicate [Match cg
first winner m] that represents a match of game [cg] where player
[first] starts and player [winner] wins. [m] is the sequence of
positions traversed during the match, from first to last. *)

Definition other (s : player) : player :=
  match s with
    | Left => Right
    | Right => Left
  end.

Inductive Match cg : forall (first winner : player), list (position cg) -> Prop :=
| Match_end : forall pl pos,
                moves cg pl pos = [] ->
                Match cg pl (other pl) [pos]
| Match_move : forall pl winner pos next m,
                 In next (moves cg pl pos) ->
                 Match cg (other pl) winner (next :: m) ->
                 Match cg pl winner (pos :: next :: m).

(** In the [Match_end] clause, we check that the current player has no
moves left. In [Match_move], we check that the current player can make
a move and that the match can then proceed with the other positions.

** A universal game

We will now define a combinatorial game that is, in a precise sense to
be explained later, the most general one. This is what combinatorial
game theory uses to study combinatorial games.

The crucial observation is that in the definition of [Match] we only
care about the moves that can be made from a given position, but not
about what the positions themselves _are_. This suggests a definition
where each position is just a pair of sets, one for each player's
moves. This forms the type [game] of games. *)

Inductive game := Game {
  left_moves : list game;
  right_moves : list game
}.

(** Each position in this game can be pictured as an
arbitrarily-branching tree with two sets of children. On each player's
turn, they choose one child in their set of moves to be the new
position, and lose if they can't choose anything.

The simplest [game] is [zero], where both players have no moves
available. It is a game where the first player always loses. *)

Definition zero : game := Game [] [].

(** Using [zero] we can define [star], where the first player _always_
wins by making a move to [zero]. *)

Definition star : game := Game [zero] [zero].

(** A small variation gives us [one] and [minus_one], where [Left] and
[Right] always win, respectively. *)

Definition one : game := Game [zero] [].
Definition minus_one : game := Game [] [zero].

(** It should be possible to encapsulate [game] in a
[combinatorial_game] record. Defining [moves] is simple, but proving
that [game]s are finite requires some additional work. The nested
inductive in the definition of [game] makes Coq generate an induction
principle that is too weak to be useful:

[[
game_ind
     : forall P : game -> Prop,
       (forall left_moves right_moves : list game,
        P {| left_moves := left_moves; right_moves := right_moves |}) ->
       forall g : game, P g
]]

The usual solution is to define a new one by hand that gives us
induction hypotheses to use: *)

Lemma lift_forall :
  forall T (P : T -> Prop),
    (forall t, P t) ->
    forall l, Forall P l.
Proof. induction l; auto. Defined.

Definition game_ind' (P : game -> Prop)
                     (H : forall l r, Forall P l -> Forall P r -> P (Game l r)) :
  forall g : game, P g :=
  fix F (g : game) : P g :=
  match g with
    | Game l r =>
      H l r (lift_forall _ P F l) (lift_forall _ P F r)
  end.

(** Using this principle, we can now prove that [game]s always
terminate and define a [combinatorial_game] for [game]. *)

Definition game_as_cg : combinatorial_game.
  refine ({| position := game;
             moves s := if s then left_moves else right_moves |}).
  intros p1.
  induction p1 as [l r IHl IHr] using game_ind'.
  (* ... *)
  (* begin hide *)
  constructor.
  intros p2 [s H].
  destruct s; simpl in H.
  - rewrite Forall_forall in IHl.
    apply IHl.
    assumption.
  - rewrite Forall_forall in IHr.
    apply IHr.
    assumption.
  (* end hide *)
Defined.

(** ** Game embeddings

I claimed that [game] is the most general combinatorial game. One way
of seeing this is that we lose no information by representing each
position in a combinatorial game as the tree of all possible moves,
and such a tree can always be encoded as a [game]. To make this
intuition formal, we can define a notion of _game embedding_ between
two combinatorial games. This will be a mapping between the positions
of each combinatorial game that preserves matches. Thus, if we have an
embedding of [cg1] into [cg2], then we can study [cg1] matches by
regarding them as [cg2] matches. *)

Definition game_embedding (cg1 cg2 : combinatorial_game)
           (embedding : position cg1 -> position cg2) : Prop :=
  forall first winner (m : list (position cg1)),
    Match cg1 first winner m ->
    Match cg2 first winner (map embedding m).

(** With this notion of game embedding, combinatorial games form a
category. I will now show that every combinatorial game can be
embedded in [game], making [game] a terminal object in this category
and the most general combinatorial game. In this formulation, it is
only a _weakly_ terminal object (i.e., embeddings are not unique), as
we are using Coq lists to represent sets.

To embed an arbitrary combinatorial game into [game], we can define a
function by well-founded recursion over the proof that games are
finite. In order to do this, we need a higher-order function
[map_game] that allows us to perform a well-founded recursive call on
a list of next moves. [map_game] acts like [map], but passes to its
argument function a proof that the element is a [valid_move]. *)

Fixpoint map_In {A B} (l : list A) : (forall x, In x l -> B) -> list B :=
  match l with
    | [] => fun _ => []
    | x :: l' => fun f =>
                   f x (or_introl _ eq_refl)
                     :: map_In l' (fun x P => f x (or_intror _ P))
  end.

Definition map_game {A} (cg : combinatorial_game)
                    (pos : position cg) (p : player)
                    (f : forall pos', valid_move cg pos' pos -> A) : list A :=
  map_In (moves cg p pos) (fun pos' P => f pos' (ex_intro _ p P)).

(** Using this function and the [Fix] combinator in the standard
library, we write a generic embedding function [embed_in_game]. Like a
regular fixpoint combinator, [Fix] takes a function that does a
recursive call by applying its argument (here, [F]). The difference is
that this argument must take a _proof_ that shows that the recursive
call is valid.

The behavior of [embed_in_game] is simple: it calls itself recursively
for each possible next position, and includes that position in the set
of moves of the appropriate player. *)

Definition embed_in_game cg (pos : position cg) : game :=
  Fix (finite_game cg)
      (fun _ => position game_as_cg)
      (fun pos F =>
         Game (map_game cg pos Left F)
              (map_game cg pos Right F))
      pos.
(* begin hide *)
Lemma map_In_map :
  forall A B
         (l : list A)
         (f : forall x, In x l -> B)
         (g : A -> B)
         (H : forall x P, f x P = g x),
    map_In l f = map g l.
Proof.
  intros.
  induction l as [|x l IH]; auto.
  simpl.
  rewrite H. f_equal.
  apply IH.
  intros x' P.
  apply H.
Qed.

Lemma map_game_map :
  forall A
         (cg : combinatorial_game)
         (pos : position cg) (p : player)
         (f : forall pos', valid_move cg pos' pos -> A)
         (g : position cg -> A)
         (H : forall pos' P, f pos' P = g pos'),
    map_game cg pos p f = map g (moves cg p pos).
Proof. eauto using map_In_map. Qed.

Lemma map_In_ext :
  forall A B
         (l : list A)
         (f g : forall x, In x l -> B)
         (EXT : forall x P, f x P = g x P),
    map_In l f = map_In l g.
Proof.
  intros.
  induction l as [|x l IH]; auto.
  simpl. rewrite EXT.
  f_equal.
  apply IH.
  intros x' P.
  apply EXT.
Qed.

Lemma map_game_ext :
  forall A
         (cg : combinatorial_game)
         (pos : position cg) (p : player)
         (f g : forall pos', valid_move cg pos' pos -> A)
         (EXT : forall pos' P, f pos' P = g pos' P),
    map_game cg pos p f = map_game cg pos p g.
Proof. eauto using map_In_ext. Qed.

(* end hide *)
(** Definitions that use [Fix] can be hard to manipulate directly, so
we need to prove some equations that describe the reduction behavior
of the function. I've hidden some of the auxiliary lemmas and proofs
for clarity; as usual, you can find them in the original [.v] file.

The proof that we can unfold [embed_in_game] once uses the [Fix_eq]
lemma in the standard library. *)

Lemma embed_in_game_eq cg (pos : position cg) :
  embed_in_game cg pos =
  Game (map (embed_in_game cg) (moves cg Left pos))
       (map (embed_in_game cg) (moves cg Right pos)).
Proof.
  unfold embed_in_game in *.
  rewrite Fix_eq.
  (* ... *)
  (* begin hide *)
  - intros.
    f_equal; apply map_game_map; reflexivity.
  - intros.
    f_equal; apply map_game_ext; intros; eauto.
  (* end hide *)
Qed.

(** With this lemma, we can show that [moves] and [embed_in_game] commute. *)

Lemma embed_in_game_moves cg (p : position cg) :
  forall s, moves game_as_cg s (embed_in_game cg p) =
            map (embed_in_game cg) (moves cg s p).
Proof.
  intros.
  rewrite embed_in_game_eq.
  destruct s; reflexivity.
Qed.

(** We are now ready to state and prove our theorem: every
combinatorial game can be embedded in [game]. *)

Theorem embed_in_game_correct cg :
  game_embedding cg game_as_cg (embed_in_game cg).
Proof.
  unfold game_embedding.
  intros first winner m MATCH.
  induction MATCH as [winner p H|s winner p p' m IN MATCH IH];
  simpl; constructor; eauto.
  - rewrite embed_in_game_moves, H. reflexivity.
  - rewrite embed_in_game_moves. auto using in_map.
Qed.

(** ** Summary

We've developed the foundations of combinatorial game theory, showing
how it can model combinatorial games in a simple yet general way. We
haven't explored yet how to use this representation in practice to
study games, something I plan to do on future posts.

_Update_: I'll leave the list of posts in this series here.

- ##Summing combinatorial games##

*)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf1 : natural) (z : natural) (x : natural)
  : natural := plus (mult x z) z.


Require Export GeoCoq.Elements.OriginalProofs.proposition_27.
Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearparallel.
Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelsymmetric.
Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelflip.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_27B :
   forall A D E F,
   CongA A E F E F D -> TS A E F D ->
   Par A E F D.
Proof.
intros.
assert (neq A E) by (forward_using lemma_angledistinct).
let Tf:=fresh in
assert (Tf:exists B, (BetS A E B /\ Cong E B A E)) by (conclude lemma_extension);destruct Tf as [B];spliter.
assert (neq F D) by (forward_using lemma_angledistinct).
assert (neq D F) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists C, (BetS D F C /\ Cong F C F D)) by (conclude lemma_extension);destruct Tf as [C];spliter.
assert (BetS C F D) by (conclude axiom_betweennesssymmetry).
assert (Par A B C D) by (conclude proposition_27).
assert (Col D F C) by (conclude_def Col ).
assert (Col C D F) by (forward_using lemma_collinearorder).
assert (Par A B F D) by (conclude lemma_collinearparallel).
assert (Par F D A B) by (conclude lemma_parallelsymmetric).
assert (Par F D B A) by (forward_using lemma_parallelflip).
assert (Col A E B) by (conclude_def Col ).
assert (Col B A E) by (forward_using lemma_collinearorder).
assert (neq A E) by (forward_using lemma_betweennotequal).
assert (neq E A) by (conclude lemma_inequalitysymmetric).
assert (Par F D E A) by (conclude lemma_collinearparallel).
assert (Par F D A E) by (forward_using lemma_parallelflip).
assert (Par A E F D) by (conclude lemma_parallelsymmetric).
close.
Qed.

End Euclid.


Require Import Arith.
Require Import List.

Require Import perm list_ind.
Require Import list_incl.

Section pigeon.

  Variable (X : Type).

  Inductive list_has_dup : list X -> Prop :=
    | in_lhd_1 : forall x l, In x l -> list_has_dup (x::l)
    | in_lhd_2 : forall x l, list_has_dup l -> list_has_dup (x::l).

  Notation lhd := list_has_dup.

  Fact lhd_app_left l m : lhd l -> lhd (l++m).
  Proof.
    intros H.
    induction H as [ x l H | x l H IH ]; simpl.
  Admitted.

  Fact lhd_app_right l m : lhd m -> lhd (l++m).
  Proof.
    induction l.
  Admitted.

  Fact lhd_app x l m : In x l -> In x m -> lhd (l++m).
  Proof.
    induction l as [ | y l IHl ]; simpl.
  Admitted.

  Fact lhd_cons_inv x l : lhd (x::l) -> In x l \/ lhd l.
  Proof.
    inversion_clear 1; auto.
  Qed.

  (* these are the equivalent characterizations *)

  Section alternate.

    Definition lhd_alt1 (m : list X) := exists x a b c, m = a++x::b++x::c.

    Fixpoint lhd_alt2 (m : list X) :=
      match m with
        | nil  => False
        | x::m => In x m \/ lhd_alt2 m
      end.

    Fact lhd_lhd_alt_1 m : lhd m -> lhd_alt1 m.
    Proof.
      induction 1 as [ x m Hm | x m Hm IHm ].
      apply in_split in Hm.
      destruct Hm as (l & r & Hm).
      subst m.
      exists x, nil, l, r.
      reflexivity.

      destruct IHm as (y & a & b & c & H).
      subst m.
      exists y, (x::a), b, c.
      reflexivity.
    Qed.

    Fact lhd_alt2_app_right l m : lhd_alt2 m -> lhd_alt2 (l++m).
    Proof.
      induction l; simpl; auto.
    Qed.

    Fact lhd_alt1_lhd_alt2 m : lhd_alt1 m -> lhd_alt2 m.
    Proof.
      intros (x & a & b & c & H).
      subst m.
      apply lhd_alt2_app_right.
      constructor 1.
      apply in_or_app; right; left; auto.
    Qed.

    Fact lhd_alt2_lhd m : lhd_alt2 m -> lhd m.
    Proof.
      induction m as [ | x m ].
      intros [].
      intros [ H | H ].
      constructor 1; auto.
      constructor 2; auto.
    Qed.

    Fact lhd_equiv m : lhd m <-> exists x a b c, m = a++x::b++x::c.
    Proof.
      split.
      apply lhd_lhd_alt_1.
      intros H; apply lhd_alt2_lhd, lhd_alt1_lhd_alt2, H.
    Qed.

  End alternate.

  Fact perm_lhd l m : l ~p m -> list_has_dup l -> list_has_dup m.
  Proof.
    intros H.
    induction H as [ | x l m H1 IH1 | x y l | ]; auto.
    intros H.
    apply lhd_cons_inv in H; destruct H as [ H | H ].

    admit.
    admit.

    intros H.
    apply lhd_cons_inv in H.
    destruct H as [ [ H | H ] | H ]; subst.

    admit.
    admit.

    apply lhd_cons_inv in H.
    destruct H as [ H | H ].

    admit.
    admit.

  Admitted.

  Fact In_perm_head (x : X) l : In x l -> exists m, l ~p x::m.
  Proof.
    intros H.
    apply in_split in H.
    destruct H as (u & v & ?).
    subst l.
    exists (u++v).
    apply perm_sym, perm_middle.
  Qed.

  Fact repeat_choice_two (x : X) m : (forall a, In a m -> a = x) -> (exists m', m = x::x::m') \/ m = nil \/ m = x::nil.
  Proof.
    intros H.
    destruct m as [ | a [ | b m ] ].
    right; left; auto.
    right; right; rewrite (H a); auto; left; auto.
    left; rewrite (H a), (H b).
    exists m; auto.
    right; left; auto.
    left; auto.
  Qed.

  Fact incl_right_cons_incl_or_lhd_or_perm m x l : incl m (x::l) -> incl m l \/ lhd m \/ exists m', m ~p x::m' /\ incl m' l.
  Proof.
    intros H.
    apply incl_right_cons_split in H.
    destruct H as (m1 & m2 & H1 & H2 & H3).
    destruct (repeat_choice_two _ _ H2) as [ (m3 & H4) | [ H4 | H4 ] ];
      subst m1; simpl in H1; clear H2.

    apply perm_sym in H1.
    right; left.
    apply perm_lhd with (1 := H1).
    constructor 1; left; auto.

    left.
    intros u Hu.
    apply H3.
    apply perm_incl with (1 := H1); auto.

    right; right.
    exists m2; auto.
  Qed.

  Fact length_le_and_incl_implies_dup_or_perm l :
               forall m, length l <= length m
                      -> incl m l
                      -> lhd m \/ m ~p l.
  Proof.

    (* the proof is by generalized induction over length l *)

    induction l as [ [ | x l ] IHl ] using list_gen_ind.

    (* case l -> nil *)

    admit.

    intros [ | y m ] H1 H2.

    (* case l -> x::l and m -> nil *)

    apply le_Sn_0 in H1; destruct H1.

    (* case l -> x::l and m -> y :: m *)

    simpl in H1; apply le_S_n in H1.
    apply incl_left_cons in H2.
    destruct H2 as [ H3 H4 ].

    simpl in H3.
    destruct H3 as [ H3 | H3 ].

    (* case x = y *)

    subst y.
    apply incl_right_cons_choose in H4.
    destruct H4 as [ H4 | H4 ].

    (* case x = y & In x m *)

    admit.

    (* case x = y & incl m l *)

    destruct IHl with (3 := H4).
    simpl; apply lt_n_Sn.
    assumption.
    admit.
    admit.

    (* case In y l *)

    apply incl_right_cons_incl_or_lhd_or_perm in H4.
    destruct H4 as [ H4 | [ H4 | (m' & H4 & H5) ] ].

    (* case In y l and incl m l *)

    destruct IHl with (3 := H4) as [ H5 | H5 ]; auto.
    admit.
    admit.

    (* case In y l and lhd m *)

    admit.

    (* case In y l and m ~p x::m' and incl m' l *)

    apply perm_sym in H4.
    apply In_perm_head in H3.
    destruct H3 as (l' & Hl').

    (* l ~p y::l' for some l' *)

    assert (incl m' (y::l')) as H6.
      intros ? ?; apply perm_incl with (1 := Hl'), H5; auto.
    clear H5.

    (* and incl m' (y::l') *)

    apply incl_right_cons_choose in H6.
    destruct H6 as [ H6 | H6 ].

    (* subcase In y m' *)

    admit.

    (* subcase incl m' l' *)

    (* apply the induction hypothesis *)

    apply IHl in H6.
    destruct H6 as [ H6 | H6 ].

    (* and either lhd m' *)

    admit.

    (* or m' ~p l', which leads to y::m ~p x::l *)

    admit.

    (* two checks that the induction hypothesis can be used *)

    apply perm_length in Hl'.
    simpl in Hl' |- *.
    rewrite Hl'.
    apply le_n_Sn.

    apply perm_length in Hl'.
    apply perm_length in H4.
    simpl in H4, Hl'.
    apply le_S_n.
    rewrite <- Hl', H4; auto.
  Admitted.

  (* if l is strictly shorter that m but m has all its elements in l
     then some element of m must be repeated *)

  Theorem finite_pigeon_hole l m : incl m l -> length l < length m -> lhd m.
  Proof.
    intros H2 H1.
    destruct length_le_and_incl_implies_dup_or_perm with (2 := H2) as [ H3 | H3 ]; auto.
    apply lt_le_weak; auto.
    apply perm_length in H3.
    exfalso; revert H1; rewrite H3; apply lt_irrefl.
  Qed.

End pigeon.