Require Import List.
Require Import Arith.
Import ListNotations.

Class Serializer (A : Type) : Type :=
  {
    serialize : A -> list bool;
    deserialize : list bool -> option (A * list bool);
    deser_ser_identity : forall a : A, forall bools: list bool, (deserialize ((serialize a) ++ bools)) = Some (a, bools);
  }.

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

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

Lemma bool_deser_ser_identity : forall a : bool, forall bools: list bool,
(bool_deserialize ((bool_serialize a) ++ bools)) = Some (a, bools).
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

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

Inductive Binary : Type :=
  | Z : Binary (* Zero *)
  | T : Binary -> Binary (* Twice *)
  | O : Binary -> Binary (* Twice plus one *)
.

Fixpoint inc (b : Binary) : Binary :=
  match b with
  | Z => O Z
  | T n => O n (* T (O n) *)
  | O n => T (inc n)
  end.

Fixpoint extract_last (b:Binary) :=
  match b with
  | Z => (Z , Z)
  | T Z => (T Z, Z)
  | O Z => (O Z, Z)
  | T b => (fst (extract_last b), T (snd (extract_last b)))
  | O b => (fst (extract_last b), O (snd (extract_last b)))
  end.

Fixpoint nat2bin (n : nat) : Binary :=
  match n with
  | Datatypes.O => Z
  | S n => inc (nat2bin n)
  end.

Fixpoint bin2nat (b: Binary) : nat :=
  match b with
  | Z => Datatypes.O
  | T b => (bin2nat b) + (bin2nat b)
  | O b => S ((bin2nat b) + (bin2nat b))
  end.

Lemma nat2bin_plus1 : forall n:nat,
  inc (nat2bin n) = nat2bin (S n).
Proof.
  induction n.
  - simpl. reflexivity.
  - simpl.
    reflexivity.
Qed.

Lemma bin2nat_plus1 : forall b:Binary,
  bin2nat (inc b) = S (bin2nat b).
Proof.
  induction b.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl.
    rewrite IHb.
    rewrite plus_n_Sm.
    rewrite <- plus_Sn_m.
    reflexivity.
Qed.

Lemma nat2bin_identity : forall n: nat,
  (bin2nat (nat2bin n)) = n.
Proof.
  intros.
  induction n.
  - simpl. reflexivity.
  - simpl.
    rewrite bin2nat_plus1.
    rewrite IHn.
    reflexivity.
Qed.

Lemma bin2nat_invertable : forall b: Binary,
  (nat2bin (bin2nat b)) = b.
Proof.
  intros.
  induction b.
  - simpl. reflexivity.
  - simpl.
    unfold nat2bin.
Abort.

Fixpoint binary_serialize (b : Binary) : list bool :=
  match b with
  | Z => [false]
  | T b => [true; true] ++ (binary_serialize b)
  | O b => [true; false] ++ (binary_serialize b)
  end.

Fixpoint binary_deserialize (bools : list bool) : option (Binary * list bool) :=
  match bools with
  | true :: false :: rest =>
    match (binary_deserialize rest) with
    | None => None
    | Some (b, rest) => Some (O b, rest)
    end
  | true :: true :: rest =>
    match (binary_deserialize rest) with
    | None => None
    | Some (b, rest) => Some (T b, rest)
    end
  | false :: rest => Some (Z, rest)
  | _ => None
  end.

Lemma binary_deser_ser_identity : forall a : Binary, forall bools: list bool,
  (binary_deserialize ((binary_serialize a) ++ bools)) = Some (a, bools).
Proof.
  intros.
  induction a.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHa.
    reflexivity.
  - simpl.
    rewrite IHa.
    reflexivity.
Qed.

Instance BinarySerializer : Serializer Binary.
Proof.
exact {| serialize := binary_serialize;
         deserialize := binary_deserialize;
         deser_ser_identity := binary_deser_ser_identity;
       |}.
Defined.

Definition nat_serialize (n : nat) : list bool := binary_serialize (nat2bin n).

Definition nat_deserialize (bools : list bool) : option (nat * list bool) :=
  match (binary_deserialize bools) with
  | None => None
  | Some (b, rest) => Some (bin2nat b, rest)
  end.

Lemma nat_deser_ser_identity: forall a : nat, forall bools: list bool,
  (nat_deserialize ((nat_serialize a) ++ bools)) = Some (a, bools).
Proof.
  intros.
  unfold nat_serialize, nat_deserialize.
  rewrite binary_deser_ser_identity.
  rewrite nat2bin_identity.
  reflexivity.
Qed.

Instance NatSerializer : Serializer nat.
Proof.
exact {| serialize := nat_serialize;
         deserialize := nat_deserialize;
         deser_ser_identity := nat_deser_ser_identity;
       |}.
Defined.

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

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

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

  Lemma pair_deser_ser_identity: forall (p : A * B) (bools: list bool),
    pair_deserialize ((pair_serialize p) ++ bools) = Some (p, bools).
  Proof.
    intros.
    unfold pair_serialize, pair_deserialize.
    rewrite <- app_assoc.
    rewrite deser_ser_identity.
    rewrite deser_ser_identity.
    rewrite <- surjective_pairing.
    reflexivity.
  Qed.

  Global Instance PairSerializer : Serializer (A * B).
  Proof.
  exact {| serialize := pair_serialize;
           deserialize := pair_deserialize;
           deser_ser_identity := pair_deser_ser_identity;
         |}.
  Defined.
End PairSerializer.

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

  Definition sum_serialize (s : A + B) : list bool :=
    match s with
    | inl a => [true] ++ serialize a
    | inr b => [false] ++ serialize b
    end.

  Definition sum_deserialize (bools : list bool) : option ((A + B) * list bool) :=
    match bools with
    | true :: bools =>
      match (deserialize bools) with
      | Some (a, bools) => Some(inl a, bools)
      | None => None
      end
    | false :: bools =>
      match (deserialize bools) with
      | Some (b, bools) => Some(inr b, bools)
      | None => None
      end
    | _ => None
    end.

  Lemma sum_deser_ser_identity: forall (s: A + B) (bools: list bool),
    sum_deserialize ((sum_serialize s) ++ bools) = Some (s, bools).
  Proof.
    intros.
    destruct s.
    - simpl.
      rewrite deser_ser_identity.
      reflexivity.
    - simpl.
      rewrite deser_ser_identity.
      reflexivity.
  Qed.

  Global Instance SumSerializer : Serializer (A + B).
  Proof.
  exact {| serialize := sum_serialize;
           deserialize := sum_deserialize;
           deser_ser_identity := sum_deser_ser_identity;
         |}.
  Defined.
End SumSerializer.

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

  Definition option_serialize (o : option A) : list bool :=
    match o with
    | Some a => [true] ++ serialize a
    | None => [false]
    end.

  Definition option_deserialize (bools : list bool) : option (option(A) * list bool) :=
    match bools with
    | false :: bools => Some(None, bools)
    | true :: bools =>
      match (deserialize bools) with
      | Some (a, bools) => Some(Some a, bools)
      | None => None
      end
    | _ => None
    end.

  Lemma option_deser_ser_identity: forall (o : option A) (bools: list bool),
    option_deserialize ((option_serialize o) ++ bools) = Some (o, bools).
  Proof.
    intros.
    destruct o.
    - simpl.
      rewrite deser_ser_identity.
      reflexivity.
    - simpl.
      reflexivity.
  Qed.

  Global Instance OptionSerializer : Serializer (option A).
  Proof.
  exact {| serialize := option_serialize;
           deserialize := option_deserialize;
           deser_ser_identity := option_deser_ser_identity;
         |}.
  Defined.
End OptionSerializer.

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

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

  Fixpoint list_deserialize (bools : list bool) : option (list A * list bool) :=
    match bools with
    | false :: bools => Some([], bools)
    | true :: bools =>
      match (list_deserialize bools) with
      | None => None
      | Some (list, bools) =>
        match (deserialize bools) with
        | None => None
        | Some (a, bools) => Some(a :: list, bools)
        end
      end
    | _ => None
    end.

  Lemma list_deser_ser_one: forall (a : A) (l : list A) (bools: list bool),
    list_deserialize ((list_serialize (a :: l)) ++ bools) =
      Some (a :: list_deserialize ((list_serialize l), bools)).
  Proof.
    intros.
    unfold list_deserialize, list_serialize.
    rewrite app_ass, app_ass.
    simpl.
  Qed.

  Lemma list_deser_ser_one: forall (a : A) (l : list A) (bools: list bool),
    list_deserialize ((list_serialize (a :: l)) ++ bools) = Some (a :: l, bools).
  Proof.
    intros.
    unfold list_deserialize, list_serialize.
    rewrite app_ass, app_ass.
    simpl.
  Qed.

  Lemma list_deser_ser_identity: forall (l : list A) (bools: list bool),
    list_deserialize ((list_serialize l) ++ bools) = Some (l, bools).
  Proof.
    intro l.
    induction l.
    - simpl. reflexivity.
    - simpl.
      intro bools.
      rewrite <- app_assoc.
      rewrite IHl.
      rewrite deser_ser_identity.
      reflexivity.
  Qed.

  Global Instance ListSerializer : Serializer (list A).
  Proof.
  exact {| serialize := list_serialize;
           deserialize := list_deserialize;
           deser_ser_identity := list_deser_ser_identity;
         |}.
  Defined.
End ListSerializer.

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

  Inductive tree: Type :=
  | leaf : tree
  | stem : A -> tree -> tree -> tree.

  Definition tree_prune (t: tree) :=
    match t with
    | leaf => leaf
    | stem a l r => stem a leaf leaf
    end.

  Fixpoint tree_insert (into node: tree) (path: list bool): tree :=
    match into with
    | leaf => node
    | stem a l r =>
        match path with
        | [] => node (* also not supported *)
        | true :: path => stem a (tree_insert l node path) r
        | false :: path => stem a l (tree_insert r node path)
        end
    end.

  Fixpoint leaf_insertable (into: tree) (path: list bool): Prop :=
    match into with
    | leaf =>
        match path with
        | [] => True (* Only if the location and tree run out at the same time should we insert *)
        | _ => False
        end
    | stem a l r =>
        match path with
        | [] => False
        | true :: path => (leaf_insertable l path)
        | false :: path => (leaf_insertable r path)
        end
    end.

  Fixpoint serialized_fold (fn : tree * list bool -> option(tree * list bool)) (bools : list bool) : option(tree * list bool) :=
    match bools with
    | true :: bools =>
      match (serialized_fold fn bools) with
      | Some (t, bools) => fn (t, bools)
      | None => None
      end
    | false :: bools => Some (leaf, bools)
    | _ => None
    end.

  Fixpoint tree_size (t:tree) : nat :=
    match t with
    | leaf => 0
    | stem a l r => 1 + tree_size l + tree_size r
    end.

  Definition tree_serialize_node (t: tree) (location: list bool): list bool :=
    match t with
      | leaf => []
      | stem a l r => (serialize location) ++ (serialize a)
    end.

  Fixpoint tree_serialize_subtree (t: tree) (location: list bool): list bool :=
    match t with
      | leaf => tree_serialize_node t location
      | stem a l r =>  tree_serialize_node t location  ++ (tree_serialize_subtree l (true :: location)) ++
        (tree_serialize_subtree r (false :: location))
    end.

  Fixpoint tree_serialize_header (t : tree) :=
    match t with
    | leaf => []
    | stem a l r => [true] ++ tree_serialize_header l ++ tree_serialize_header r
    end.

  Definition tree_serialize (t: tree) : list bool :=
    (nat_serialize (tree_size t)) ++ (tree_serialize_subtree t []).

  Definition tree_deserialize_node (root :tree) (bools: list bool) : option (tree * list bool) :=
    match (list_deserialize bool BoolSerializer bools) with
    | None => None
    | Some (location, bools) =>
      match (deserialize bools) with
      | None => None
      | Some (a, bools) => Some (tree_insert root (stem a leaf leaf) (rev location), bools)
      end
    end.

  Fixpoint tree_deserialize_impl (remaining : nat) (root : tree) (bools : list bool) : option (tree * list bool) :=
    match remaining with
    | S n =>
      match tree_deserialize_node root bools with
      | None => None
      | Some (root, bools) => tree_deserialize_impl n root bools
      end
    | _ => Some (root, bools)
    end.

  Fixpoint is_subpath (parent path: list bool) : bool :=
    match parent, path with
    | [], _ => true
    | _, [] => false
    | h_parent :: t_parent, h_path :: t_path => (Bool.eqb h_parent h_path) && (is_subpath t_parent t_path)
    end.

(*
  Fixpoint tree_deserialize_subtree (remaining : nat) (root: tree) (path: list bool) (bools: list bool) : option (tree * list bool) :=
    match remaining with
    | S n =>
      match (tree_deserialize_subtree n root path bools) with
      | None => None
      | Some (root, []) => Some (root, bools)
      | Some (root, bools) =>
        match (list_deserialize bool BoolSerializer bools) with
        | None => None
        | Some (location, bools) =>
          match (is_subpath path (rev location)) with
          | false => Some (root, bools)
          | true =>
            match (deserialize bools) with
            | None => None
            | Some (a, bools) => Some (tree_insert root (stem a leaf leaf) (rev location), bools)
            end
          end
        end
      end
    | _ => Some (root, bools)
    end.
*)

  Fixpoint tree_deserialize_size (bools : list bool) : option (nat * list bool):=
    match bools with
    | true :: bools =>
      match tree_deserialize_size bools with
      | Some (n, bools) => Some (S n, bools)
      | None => None
      end
    | false :: bools => Some (0, bools)
    | _ => None
    end.

  Definition tree_deserialize (bools: list bool) : option (tree * list bool) :=
    match nat_deserialize bools with
    | Some (size, bools) => tree_deserialize_impl size leaf bools
    | None => None
    end.

  Lemma sublocation_child_sublocation: forall location parent sublocation: list bool,
    is_subpath (rev parent) (rev location) = true -> is_subpath (rev parent) (rev (location ++ sublocation)) = true.
  Proof.
    intros location parent sublocation.
    induction sublocation.
    - Abort.

  Lemma subpath_child_subpath: forall path parent subpath: list bool,
    is_subpath parent path = true -> is_subpath parent (path ++ subpath) = true.
  Proof.
    intros path parent subpath.
    induction parent.
    - simpl. reflexivity.
    - intros. Abort.

  Fixpoint skipped_branches (root : tree) (path : list bool) : list tree :=
    match root, path with
    | leaf, _ => [] (* The tree ran out before the path... probably shouldn't happen *)
    | stem a l r, true :: path => r :: (skipped_branches l path) (* The ordering here may have to be flipped *)
    | stem a l r, false :: path => l :: (skipped_branches r path)
    | stem a l r, [] => [] (* Everything underneath will be seen *)
    end.

  Fixpoint unseen_branches_impl (current : tree) (path : list bool) (location: list bool) : list (tree * list bool) :=
    match current, path with
    | leaf, _ => [] (* The tree ran out before the path... probably shouldn't happen *)
    | stem a l r, true :: path => (unseen_branches_impl l path (true::location)) ++ [(r, rev location)] (* The ordering here may have to be flipped *)
    | stem a l r, false :: path => (unseen_branches_impl r path (false::location)) ++ [(l, rev location)]
    | stem a l r, [] => [(stem a l r, location)] (* Everything underneath will be seen *)
    end.

  Definition unseen_branches (root : tree) (path : list bool) : list (tree * list bool) :=
    unseen_branches_impl root path [].

  Fixpoint skipped_branches_clean (current : tree) (path : list bool) : list (tree) :=
    match current, path with
    | leaf, _ => [] (* The tree ran out before the path... probably shouldn't happen *)
    | stem a l r, true :: path => [r] ++ (skipped_branches_clean l path) (* Skpped the right *)
    | stem a l r, false :: path => (skipped_branches_clean r path) (* Already been to the left *)
    | stem a l r, [] => [stem a l r] (* Everything underneath will be seen *)
    end.

  Fixpoint reassemble_tree (root: tree) (path : list bool) (branches: list tree) : tree :=
    match root, path, branches with
    | stem a l r, [], _ => stem a l r
    | stem a l r, true :: path, [] => stem a l r
    | stem a l r, true :: path, branch :: branches => stem a (reassemble_tree l path branches) branch
    | stem a l r, false :: path, _  => stem a l (reassemble_tree r path branches)
    | leaf, _, _ => leaf
    end.

  Fixpoint seen_tree (root : tree) (path : list bool) (*{struct path}*) : tree :=
    match root, path with
    | leaf, _ => leaf (* The tree ran out before the path... probably shouldn't happen *)
    | stem a l r, true :: path => stem a (seen_tree l path) leaf
    | stem a l r, false :: path => stem a l (seen_tree r path)
    | stem a l r, [] => stem a l r (* Everything underneath will be observed *)
    end.

  Lemma skip_reassemble_whole : forall t : tree, forall path : list bool,
    leaf_insertable t path ->
      reassemble_tree (seen_tree t path) path (skipped_branches_clean t path) = t.
  Proof.
    induction t as [|a l IHL r IHR ]; intros path InTree.
    - simpl. reflexivity.
    - simpl.
      destruct path.
      + trivial.
      + destruct b.
        * simpl.
          rewrite IHL.
          reflexivity.
          simpl in InTree.
          apply InTree.
  Abort.

  Lemma tree_insert_at_leaf : forall root : tree, forall path : list bool,
    leaf_insertable root path ->
      tree_insert root leaf path = root.
  Proof.
    induction root as [| a l IHL r IHR]; intros.
    - destruct path.
      + trivial.
      + simpl in H. inversion H.
    - unfold tree_insert; fold tree_insert.
      destruct path.
      + simpl in H. inversion H.
      + simpl in H.
        destruct b;
          f_equal.
        * apply IHL.
          apply H.
        * apply IHR.
          apply H.
  Qed.

  Lemma tree_insert_into_leaf_l : forall root l r: tree, forall path: list bool, forall a: A,
    leaf_insertable root path ->
      tree_insert (tree_insert root (stem a leaf r) path) l (path ++ [true]) =
      tree_insert root (stem a l r) path.
  Proof.
    induction root as [| a l IHL r IHR]; intros.
    - destruct path.
      + trivial.
      + simpl in H. inversion H.
    - destruct path; simpl in H.
      + inversion H.
      + destruct b;
        simpl;
        f_equal.
        * apply IHL, H.
        * apply IHR, H.
  Qed.

  Lemma tree_insert_into_leaf_r : forall root r l: tree, forall path: list bool, forall a: A,
    leaf_insertable root path ->
      tree_insert (tree_insert root (stem a l leaf) path) r (path ++ [false]) =
      tree_insert root (stem a l r) path.
  Proof. (* Is there a way to reuse proof reasoning, like from above? *)
    induction root as [| a l IHL r IHR]; intros.
    - destruct path.
      + trivial.
      + simpl in H. inversion H.
    - destruct path; simpl in H.
      + inversion H.
      + destruct b;
        simpl;
        f_equal.
        * apply IHL, H.
        * apply IHR, H.
  Qed.

  Lemma tree_insert_into_empty : forall root l r : tree, forall path: list bool, forall a: A,
    leaf_insertable root path ->
      tree_insert (
        tree_insert (tree_insert root (stem a leaf leaf) path) l
          (path ++ [true])) r (path ++ [false]) =
      tree_insert root (stem a l r) path.
  Proof.
    intros.
    rewrite tree_insert_into_leaf_l.
    rewrite tree_insert_into_leaf_r.
    reflexivity.
    apply H.
    apply H.
  Qed.

  Lemma tree_insertable_after_r : forall (root l : tree) (a : A) (path : list bool),
  leaf_insertable root path ->
    leaf_insertable (tree_insert root (stem a l leaf) path) (path ++ [false]).
  Proof.
    induction root as [| a l IHL r IHR]; intros.
    - simpl.
      destruct path.
      + trivial.
      + simpl in H. inversion H.
    - destruct path.
      + simpl in H. inversion H.
      + simpl.
        simpl in H.
        destruct b.
        * apply IHL.
          apply H.
        * apply IHR.
          apply H.
  Qed.

  Lemma tree_insertable_after_l : forall (root r : tree) (a : A) (path : list bool),
  leaf_insertable root path ->
    leaf_insertable (tree_insert root (stem a leaf r) path) (path ++ [true]).
  Proof.
    induction root as [| a l IHL r IHR]; intros.
    - simpl.
      destruct path.
      + trivial.
      + simpl in H. inversion H.
    - destruct path.
      + simpl in H. inversion H.
      + simpl.
        simpl in H.
        destruct b.
        * apply IHL.
          apply H.
        * apply IHR.
          apply H.
  Qed.

  Lemma tree_deser_ser_impl : forall a root : tree, forall location : list bool, forall bs : list bool, forall n : nat,
      leaf_insertable root (rev location) ->
      tree_deserialize_impl (tree_size a + n) root (tree_serialize_subtree a location ++ bs) =
        tree_deserialize_impl n (tree_insert root a (rev location)) bs.
  induction a as [| a l IHL r IHR]; intros root location bs n InTree.
  - simpl.
    rewrite tree_insert_at_leaf.
    reflexivity.
    apply InTree.
  - cbn - [tree_insert].
    rewrite !app_ass.
    unfold tree_deserialize_node.
    rewrite list_deser_ser_identity.
    rewrite deser_ser_identity.
    rewrite <- plus_assoc.
    rewrite IHL.
    rewrite IHR.
    f_equal.
    rewrite tree_insert_into_empty.
      reflexivity.
    apply InTree.
      rewrite tree_insert_into_leaf_l.
      simpl.
      apply tree_insertable_after_r.
      apply InTree.
      apply InTree.
    apply tree_insertable_after_l.
      apply InTree.
  Qed.

(* For reassemble
  Lemma tree_deser_ser_partTree : forall seen : tree, forall location bools : list bool,
    leaf_insertable root location ->
      tree_deserialize ((nat_serialize (tree_size root)) ++ ) = Some (root, bools).

  Lemma tree_deser_ser_subtree : forall a r : tree, forall i : list bool, forall bs : list bool, forall n : nat,
      leaf_insertable r (rev i) ->
      tree_deserialize_subtree n r (tree_serialize_subtree a  i ++ bs) = tree_deserialize_subtree n (tree_insert a r (rev i)) bs.
  Proof.
    intros a r i bs n insertable.
    induction a as [|a L IHL R IHR].
    - simpl. reflexivity.
    - unfold tree_serialize_subtree.
      rewrite app_ass, app_ass.
      simpl. *)

  Theorem tree_deser_ser_identity: forall t : tree, forall bools: list bool,
    (tree_deserialize ((tree_serialize t) ++ bools)) = Some (t, bools).
  Proof.
    intros.
    unfold tree_deserialize, tree_serialize.
    rewrite app_ass.
    rewrite nat_deser_ser_identity.
    rewrite (plus_n_O (tree_size t)).
    rewrite tree_deser_ser_impl.
    simpl.
    reflexivity.
    simpl.
    reflexivity.
  Qed.

  Global Instance TreeSerializer : Serializer (tree).
  Proof.
  exact {| serialize := tree_serialize;
           deserialize := tree_deserialize;
           deser_ser_identity := tree_deser_ser_identity;
         |}.
  Defined.
End TreeSerializer.

(*Definition test_tree (t : tree nat) : Prop :=
  Some (t, []) = tree_deserialize (tree_serialize t).*)
Check tree nat.
Eval compute in deserialize (serialize
  (stem nat 1
    (stem nat 2 (stem nat 3 (leaf nat) (stem nat 4 (leaf nat) (leaf nat))) (leaf nat)) (leaf nat))) : option (tree nat * list bool).

Eval compute in deserialize (serialize (stem nat 2 (stem nat 3 (leaf nat) (stem nat 4 (leaf nat) (leaf nat))) (leaf nat))) : option (tree nat * list bool).

Eval compute in deserialize (serialize (stem nat 0 (leaf nat) (leaf nat))) : option (tree nat * list bool).

Eval compute in deserialize (serialize (leaf nat)) : option (tree nat * list bool).

Eval compute in deserialize (serialize (true, Z)): option ((bool* Binary) * list bool).


(*|
###############################################################################################
Pattern-match on type in order to implement equality for existentially typed constructor in Coq
###############################################################################################

:Link: https://stackoverflow.com/q/42140009
|*)

(*|
Question
********

Let's say I have again a small problem with my datatype with an
existential quantified component. This time I want to define when two
values of type ``ext`` are equal.
|*)

Inductive ext (A : Set) :=
| ext_ : forall (X : Set), option X -> ext A.

Fail Definition ext_eq (A : Set) (x y : ext A) : Prop :=
  match x with
  | ext_ _ ox => match y with
                 | ext_ _ oy => (* only when they have the same types *)
                     ox = oy
                 end
  end.

(*|
What I'd like to do is somehow distinguish between the cases where the
existential type is actually same and where it's not. Is this a case
for ``JMeq`` or is there some other way to accomplish such a case
distinction?

I googled a lot, but unfortunately I mostly stumbled upon posts about
dependent pattern matching.

I also tried to generate a (boolean) scheme with ``Scheme Equality for
ext``, but this wasn't successful because of the type argument.
|*)

(*|
Answer
******

    What I'd like to do is somehow distinguish between the cases where
    the existential type is actually same and where it's not.

This is not possible as Coq's logic is compatible with the univalence
axiom which says that isomorphic types are equal. So even though
``(unit * unit)`` and ``unit`` are syntactically distinct, they cannot
be distinguished by Coq's logic.

A possible work-around is to have a datatype of codes for the types
you are interested in and store that as an existential. Something like
this:
|*)

Reset Initial. (* .none *)
Inductive Code : Type :=
| Nat : Code
| List : Code -> Code.

Fixpoint meaning (c : Code) :=
  match c with
  | Nat     => nat
  | List c' => list (meaning c')
  end.

Inductive ext (A : Set) :=
| ext_ : forall (c : Code), option (meaning c) -> ext A.

Lemma Code_eq_dec : forall (c d : Code), {c = d} + {c <> d}.
Proof.
  intros c. induction c; intros d; destruct d.
  - left. reflexivity.
  - right. inversion 1.
  - right. inversion 1.
  - destruct (IHc d).
    + left. congruence.
    + right. inversion 1. contradiction.
Defined.

Definition ext_eq (A : Set) (x y : ext A) : Prop.
  refine (match x with
          | @ext_ _ c ox =>
              match y with
              | @ext_ _ d oy =>
                  match Code_eq_dec c d with
                  | left eq   => _
                  | right neq => False
                  end end end).
  subst. exact (ox = oy).
Defined.

(*|
However this obviously limits quite a lot the sort of types you can
pack in an ``ext``. Other, more powerful, languages (e.g. equipped
with `Induction-recursion
<https://en.wikipedia.org/wiki/Induction-recursion>`__) would give you
more expressive power.

----

**A:** Nice workaround! Let me add a couple comments: (1)
``Code_eq_dec`` can be *literally* defined using the ``decide
equality`` tactic, which will really shine when we start adding more
data constructors into ``Code``; (2) ``ext_`` can be destructed using
the ``let`` expression (since it has only one constructor), which
makes the code a bit more concise: ``let (c,ox) := x in ...``
|*)


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Supplementary Coq material: unification and logic programming
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/
  * Much of the material comes from CPDT <http://adam.chlipala.net/cpdt/> by the same author. *)

Require Import Frap.

Set Implicit Arguments.

(** * Introducing Logic Programming *)

(* Recall the definition of addition from the standard library. *)

Definition real_plus := Eval compute in plus.
Print real_plus.

(* Alternatively, we can define it as a relation. *)

Inductive plusR : nat -> nat -> nat -> Prop :=
| PlusO : forall m, plusR O m m
| PlusS : forall n m r, plusR n m r
  -> plusR (S n) m (S r).

(* Let's prove the correspondence. *)

Theorem plusR_plus : forall n m r,
  plusR n m r
  -> r = n + m.
Proof.
Admitted.

Theorem plus_plusR : forall n m,
  plusR n m (n + m).
Proof.
Admitted.

Example four_plus_three : 4 + 3 = 7.
Proof.
  reflexivity.
Qed.

Print four_plus_three.

Example four_plus_three' : plusR 4 3 7.
Proof.
Admitted.

Print four_plus_three'.

Example five_plus_three : plusR 5 3 8.
Proof.
Admitted.

(* Demonstrating _backtracking_ *)
Example seven_minus_three : exists x, x + 3 = 7.
Proof.
  apply ex_intro with 0.
Abort.

Example seven_minus_three' : exists x, plusR x 3 7.
Proof.
Admitted.

(* Backwards! *)
Example seven_minus_four' : exists x, plusR 4 x 7.
Proof.
Admitted.

Example seven_minus_three'' : exists x, x + 3 = 7.
Proof.
Admitted.

Example seven_minus_four : exists x, 4 + x = 7.
Proof.
Admitted.

Example seven_minus_four_zero : exists x, 4 + x + 0 = 7.
Proof.
Admitted.

Check eq_trans.

Section slow.
  Hint Resolve eq_trans.

  Example zero_minus_one : exists x, 1 + x = 0.
    Time eauto 1.
    Time eauto 2.
    Time eauto 3.
    Time eauto 4.
    Time eauto 5.

    debug eauto 3.
  Abort.
End slow.

Example from_one_to_zero : exists x, 1 + x = 0.
Proof.
Admitted.

Example seven_minus_three_again : exists x, x + 3 = 7.
Proof.
Admitted.

Example needs_trans : forall x y, 1 + x = y
  -> y = 2
  -> exists z, z + x = 3.
Proof.
Admitted.

(** * Searching for Underconstrained Values *)

Print Datatypes.length.

Example length_1_2 : length (1 :: 2 :: nil) = 2.
Proof.
Admitted.

Print length_1_2.

Example length_is_2 : exists ls : list nat, length ls = 2.
Proof.
Abort.

Print Forall.

Example length_is_2 : exists ls : list nat, length ls = 2
  /\ Forall (fun n => n >= 1) ls.
Proof.
Admitted.

Print length_is_2.

Definition sum := fold_right plus O.

Example length_and_sum : exists ls : list nat, length ls = 2
  /\ sum ls = O.
Proof.
Admitted.

Print length_and_sum.

Example length_and_sum' : exists ls : list nat, length ls = 5
  /\ sum ls = 42.
Proof.
Admitted.

Print length_and_sum'.

Example length_and_sum'' : exists ls : list nat, length ls = 2
  /\ sum ls = 3
  /\ Forall (fun n => n <> 0) ls.
Proof.
Admitted.

Print length_and_sum''.

(** * Synthesizing Programs *)

Inductive exp : Set :=
| Const (n : nat)
| Var
| Plus (e1 e2 : exp).

Inductive eval (var : nat) : exp -> nat -> Prop :=
| EvalConst : forall n, eval var (Const n) n
| EvalVar : eval var Var var
| EvalPlus : forall e1 e2 n1 n2, eval var e1 n1
  -> eval var e2 n2
  -> eval var (Plus e1 e2) (n1 + n2).

Hint Constructors eval.

Example eval1 : forall var, eval var (Plus Var (Plus (Const 8) Var)) (var + (8 + var)).
Proof.
  auto.
Qed.

Example eval1' : forall var, eval var (Plus Var (Plus (Const 8) Var)) (2 * var + 8).
Proof.
  eauto.
Abort.

Example eval1' : forall var, eval var (Plus Var (Plus (Const 8) Var)) (2 * var + 8).
Proof.
Admitted.

Example synthesize1 : exists e, forall var, eval var e (var + 7).
Proof.
Admitted.

Print synthesize1.

(* Here are two more examples showing off our program-synthesis abilities. *)

Example synthesize2 : exists e, forall var, eval var e (2 * var + 8).
Proof.
Admitted.

Print synthesize2.

Example synthesize3 : exists e, forall var, eval var e (3 * var + 42).
Proof.
Admitted.

Print synthesize3.

Theorem linear : forall e, exists k n,
  forall var, eval var e (k * var + n).
Proof.
Admitted.

Section side_effect_sideshow.
  Variable A : Set.
  Variables P Q : A -> Prop.
  Variable x : A.

  Hypothesis Px : P x.
  Hypothesis Qx : Q x.

  Theorem double_threat : exists y, P y /\ Q y.
  Proof.
    eexists; propositional.
    eauto.
    eauto.
  Qed.
End side_effect_sideshow.

(** * More on [auto] Hints *)

Theorem bool_neq : true <> false.
Proof.
Admitted.

Section forall_and.
  Variable A : Set.
  Variables P Q : A -> Prop.

  Hypothesis both : forall x, P x /\ Q x.

  Theorem forall_and : forall z, P z.
  Proof.
  Admitted.
End forall_and.

(** * Rewrite Hints *)

Section autorewrite.
  Variable A : Set.
  Variable f : A -> A.

  Hypothesis f_f : forall x, f (f x) = f x.

  Hint Rewrite f_f.

  Lemma f_f_f : forall x, f (f (f x)) = f x.
  Proof.
    intros; autorewrite with core; reflexivity.
  Qed.

  Section garden_path.
    Variable g : A -> A.
    Hypothesis f_g : forall x, f x = g x.
    Hint Rewrite f_g.

    Lemma f_f_f' : forall x, f (f (f x)) = f x.
    Proof.
    Admitted.
  End garden_path.

  Lemma in_star : forall x y, f (f (f (f x))) = f (f y)
    -> f x = f (f (f y)).
  Proof.
  Admitted.

End autorewrite.


Require Import Coq.Lists.ListSet.

Require Import Listkit.Sets.

Definition monomorphism A B (f:A->B) : Prop := (forall x y, f x = f y -> x = y).

Lemma map_monomorphism:
  forall A B eq_dec X (f:A-> B) (x:A),
    (monomorphism _ _ f) ->
    (set_In x X <-> set_In (f x) (set_map eq_dec f X)).
Proof.
 unfold monomorphism.
 induction X; simpl; intros.
  split; auto.
 split; intros.
  destruct H0.
   subst a.
   apply set_add_intro.
   auto.
  apply set_add_intro.
  right.
  apply set_map_intro; auto.
 apply set_add_elim in H0.
 intuition.
 right.
 apply <- IHX; eauto.
Qed.


From Undecidability.Shared Require Import FinitenessFacts.
Require Import List.

Definition total {X Y} (R : X -> Y -> Prop) :=
  forall x, exists y, R x y.

Lemma Forall2_total {X} {Y} (R : X -> Y -> Prop) L :
  (forall x, In x L -> exists y, R x y) -> exists L', Forall2 R L L'.
Proof.
  intros HP. induction L.
  - exists nil. econstructor.
  - destruct (HP a) as [b H]. 1:firstorder.
    destruct IHL as [L2' IH].
    + eauto.
    + exists (b :: L2'). econstructor; eauto.
Qed.

Lemma finite_choice_list {X Y} (R : X -> Y -> Prop) L (y0 : Y) :
  (forall x1 x2 : X, {x1 = x2} + {x1 <> x2}) ->
  (forall x, In x L -> exists y, R x y) ->
  exists f, forall x, In x L -> R x (f x).
Proof.
  intros D Htot.
  induction L as [ | x L].
  - exists (fun _ => y0). firstorder.
  - destruct IHL as [f Hf].
    + eauto.
    + destruct (Htot x) as [y Hy]; [ auto | ].
      exists (fun x' => if D x x' then y else f x').
      intros x0 [-> | H].
      * destruct (D x0 x0); tauto.
      * destruct (D x x0) as [-> | Hx]; auto.
Qed.

Lemma finite_choice_precond {X Y} (R : X -> Y -> Prop) (p : X -> Prop) (y0 : Y) :
  listable p ->
  (forall x1 x2 : X, {x1 = x2} + {x1 <> x2}) ->
  (forall x, p x -> exists y, R x y) ->
  exists f, forall x, p x -> R x (f x).
Proof.
  intros [L HL]. red in HL. setoid_rewrite HL.
  eapply finite_choice_list. exact y0.
Qed.

Lemma finite_choice {X Y} (R : X -> Y -> Prop) :
  finiteᵗ X ->
  (forall x1 x2 : X, {x1 = x2} + {x1 <> x2}) ->
  (forall x, exists y, R x y) ->
  exists f, forall x, R x (f x).
Proof.
  intros [L HL] D Htot.
  destruct L as [ | x0].
  - unshelve eexists; intros; exfalso; firstorder.
  - destruct (Htot x0) as [y0 _]. revert HL. generalize (x0 :: L). clear L x0. intros L HL.
    destruct (@finite_choice_list _ _ R L y0) as [f Hf].
    + exact D.
    + firstorder.
    + exists f. intros. now apply Hf.
Qed.


(*COLLINET Noah Groupe C*)

Require Export Classical.
(* exercice 1 *)
Parameter T : Set.
Parameters P Q : T -> Prop.

Goal (exists x: T, P(x)) /\ (forall x: T, P(x)-> Q(x)) -> (exists x: T, Q(x)).
intros.
elim H.
intros.
elim H0.
intros.
exists x.
apply H1.
assumption.
Qed.

Goal (exists x: T, P(x) /\ Q(x)) -> (exists x: T, P(x) -> Q(x)).
intros.
elim H.
intros.
exists x.
intros.
apply H0.
Qed.

(* exercice 2 *)
Parameter R : Set .
Parameters zero one : R.
Parameter opp : R -> R.
Parameters plus mult : R -> R -> R.

Section Commutative_ring .

Variables a b c : R.

Axiom ass_plus : plus ( plus a b ) c = plus a ( plus b c ).
Axiom com_plus : plus a b = plus b a.
Axiom com_mult : mult a b = mult b a.
Axiom ass_mult : mult ( mult a b ) c = mult a ( mult b c ).
Axiom dis_left : mult a ( plus b c ) = plus ( mult a b ) ( mult a c ).
Axiom dis_right : mult ( plus b c ) a = plus ( mult b a ) ( mult c a ).
Axiom neu_plus_r : plus a zero = a.
Axiom neu_plus_l : plus zero a = a.
Axiom neu_mult_r : mult a one = a.
Axiom neu_mult_l : mult one a = a.
Axiom opp_right : plus a ( opp a ) = zero.
Axiom opp_left : plus ( opp a ) a = zero.

End Commutative_ring .

Lemma num1: forall a b : R, (mult (plus a b)( plus one one) ) = (plus b (plus a (plus b a))).
intros.
rewrite dis_left.
rewrite dis_right.
rewrite neu_mult_r.
rewrite neu_mult_r.
rewrite (com_plus b a).
rewrite <-(ass_plus b a (plus a b)).
rewrite (com_plus b a).
reflexivity.
Qed.

(* exercice 3 *)
Require Export List.
Open Scope list_scope.
Import List Notations.

Inductive is_length: list nat -> nat -> Prop :=
| is_length_nil : is_length nil 0
| is_length_cons : forall( n e : nat ) ( l : list nat ),
is_length l n -> is_length ( e::l ) ( S n ).

Fixpoint length ( l : list nat ) {struct l} : nat :=
match l with
| nil => 0
| e :: q => S ( length q )
end .

Theorem first : forall l : list nat, forall n : nat, (length l) = n -> (is_length l n).
induction l.
intros.
rewrite <- H.
simpl.
apply is_length_nil.

intros.
rewrite <- H.
simpl.
apply is_length_cons.
apply IHl.
reflexivity.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega Wellfounded.

Set Implicit Arguments.

Theorem measure_rect X (m : X -> nat) (P : X -> Type) :
      (forall x, (forall y, m y < m x -> P y) -> P x) -> forall x, P x.
Proof.
  apply well_founded_induction_type, wf_inverse_image, lt_wf.
Qed.

Section list_snoc_ind.

  Variable (X : Type) (P : list X -> Type)
           (HP0 : P nil) (HP1 : forall x l, P l -> P (l++x::nil)).

  Theorem list_snoc_ind : forall l, P l.
  Proof.
    intros l.
    rewrite <- (rev_involutive l).
    generalize (rev l); clear l; intros l.
    induction l as [ | x l IHl ].
    apply HP0.
    simpl; apply HP1; auto.
  Qed.

End list_snoc_ind.

Fact list_snoc_inv X l m (x y : X) : l++x::nil = m++y::nil -> l = m /\ x = y.
Proof.
  intros H.
  apply f_equal with (f := @rev _) in H.
  do 2 rewrite rev_app_distr in H; simpl in H.
  inversion H; subst.
  rewrite <- (rev_involutive l), H2, rev_involutive; auto.
Qed.

Fact list_snoc_destruct X l : { x : X & { m | l = m++x::nil } } + { l = nil }.
Proof.
  induction l  as [ | x l _ ] using list_snoc_ind.
  * right; auto.
  * left; exists x, l; auto.
Qed.

Definition app_split X (l1 : list X) : forall l2 r1 r2, l1++r1 = l2++r2
                                      -> { m | l2 = l1++m /\ r1 = m++r2 }
                                       + { m | l1 = l2++m /\ r2 = m++r1 }.
Proof.
  induction l1 as [ | x l1 Hl1 ].
  left; exists l2; auto.
  intros [ | y l2 ] r1 r2 H.
  right; exists (x::l1); auto.
  simpl in H; injection H; clear H; intros H ?; subst.
  apply Hl1 in H.
  destruct H as [ (m & H1 & H2) | (m & H1 & H2) ].
  left; exists m; subst; auto.
  right; exists m; subst; auto.
Qed.

Fact list_split_first_half U (ll : list U) x : x <= length ll -> { l : _ & { r | ll = l++r /\ length l = x } }.
Proof.
  revert ll; induction x as [ | x IHx ]; intros [ | u ll ] Hx.
  exists nil, nil; simpl; auto.
  exists nil, (u::ll); auto.
  simpl in Hx; omega.
  destruct (IHx ll) as (l & r & H1 & H2).
  simpl in Hx; omega.
  exists (u::l), r; simpl; split; f_equal; auto.
Qed.

Fact list_split_second_half U (ll : list U) x : x <= length ll -> { l : _ & { r | ll = l++r /\ length r = x } }.
Proof.
  intros Hx.
  destruct list_split_first_half with (ll := ll) (x := length ll - x)
    as (l & r & H1 & H2).
  omega.
  exists l, r; split; auto.
  apply f_equal with (f := @length _) in H1.
  rewrite app_length in H1.
  omega.
Qed.

Section Forall.

  Variables (X : Type) (P : X -> Prop).

  Fact Forall_app ll mm : Forall P (ll++mm) <-> Forall P ll /\ Forall P mm.
  Proof.
    split.
    induction ll as [ | x ll ]; split; auto.
    constructor;
    inversion H; auto.
    apply IHll; auto.
    inversion H; apply IHll; auto.
    intros (H1 & H2).
    induction H1; simpl; auto; constructor; auto.
  Qed.

  Fact Forall_cons_inv x ll : Forall P (x::ll) <-> P x /\ Forall P ll.
  Proof.
    split.
    inversion_clear 1; auto.
    constructor; tauto.
  Qed.

  Hypothesis P_dec : forall x, P x \/ ~ P x.

  Fact Forall_l_dec l : Forall P l \/ ~ Forall P l.
  Proof.
    induction l as [ | x l [ IHl | IHl ] ].
    + left; auto.
    + destruct (P_dec x) as [ H | H ].
      * left; constructor; auto.
      * right; contradict H; rewrite Forall_cons_inv in H; tauto.
    + right; contradict IHl; rewrite Forall_cons_inv in IHl; tauto.
  Qed.

  Fact Exists_l_dec l : (exists x, In x l /\ P x) \/ forall x, In x l -> ~ P x.
  Proof.
    induction l as [ | x l [ (y & H1 & H2) | IHl ] ].
    + right; simpl; tauto.
    + left; exists y; simpl; auto.
    + destruct (P_dec x) as [ H | H ].
      * left; exists x; simpl; auto.
      * right; intros ? [|]; subst; auto.
  Qed.

End Forall.


Require Import Nat.
Require Import List.
Import ListNotations.
Require Import Relations.
(** MTrees are the trees we pickle into
 *)
Inductive Ntree : Type := NLeaf: nat -> Ntree | NBranch:  nat -> list Ntree -> Ntree.

Section correct_ntree_ind.

Variables
  (A : Set)(P : Ntree -> Prop).
Hypotheses
  (H : forall (a:nat)(l:list (Ntree)), (forall x, In x l -> P x) -> P (NBranch a l))

 (H1 : forall t:Ntree, P t -> forall l:list (Ntree), (forall x, In x l -> P x) -> (forall x, In x (cons t l) -> P x))
 (H2: forall (n: nat), P(NLeaf n)).
Lemma  H0: forall x, In x [] -> P x.
  intros x H4.  destruct H4.
  Qed.
Fixpoint ntree_ind2 (t:Ntree) : P t :=
  match t as x return P x with
  | NBranch a l =>
      H a l
        (((fix l_ind (l':list (Ntree)) : (forall x, In x l' -> P x) :=
             match l' as x return forall y, In y x -> P y with
             | nil => H0
             | cons t1 tl => H1 t1 (ntree_ind2 t1) tl (l_ind tl)
             end)) l)
  | NLeaf x => H2 x
  end.

End correct_ntree_ind.
Require Import PeanoNat.
Definition list_eq (A: Type) (f: A -> A -> bool) (l1 l2: list A) :=
  let fll := fix gh (l1 l2:list A) :=
                 match (l1, l2) with
                   (nil ,nil) => true
                 | (a::xr1, b::xr2) => if f a b then gh xr1 xr2 else false
                 | _ => false end
             in fll l1 l2.
Fixpoint ntree_eq_dec (n1 n2: Ntree) : bool :=
  match (n1, n2) with
    (NLeaf a ,NLeaf b) => if Nat.eq_dec a b then true else false
  | (NBranch a xr1, NBranch b xr2) => if Nat.eq_dec a b then list_eq Ntree ntree_eq_dec xr1 xr2 else false
  | _ => false end.

(**
   Note: I know that this proof is quite ugly, sorry :-(
 **)
Definition ntree_equal_dec_lemma: forall (x1 x2: Ntree), x1 = x2 <-> (ntree_eq_dec x1 x2) = true .
Proof.
  intro.
  induction x1 using ntree_ind2.
  - intro x2. destruct x2.
    split.
    + intro. congruence.
    + intro.   simpl ntree_eq_dec in H1.  congruence.
    + split.
      intro.
      inversion H1.
      simpl ntree_eq_dec.
      destruct (Nat.eq_dec n n). subst l0. induction l. simpl.  reflexivity.
      simpl list_eq. enough (ntree_eq_dec a0 a0 = true).
      rewrite H2. apply IHl. intros x H4. apply H. right. assumption.
      rewrite H3.
      reflexivity.
      apply H.
      left. auto.
      reflexivity.
      congruence.
      intro H1.
      simpl ntree_eq_dec in H1.
      destruct (Nat.eq_dec a n).
      enough (l = l0).
      subst a.  subst l. reflexivity.
      assert (forall (l' l'': list Ntree), (forall x, In x l' -> In x l) -> list_eq Ntree ntree_eq_dec l' l'' = true <-> l' = l'').
      intro l'.
      induction l'.
      *  intro l''. intro Hx. destruct l''. firstorder eauto.
         split. intro. simpl list_eq in H2.  congruence.  intro. inversion H2.
      *  intros l'' H2. split.
         destruct l''.
         intro. simpl in  H3.  congruence.
         intro. assert (l' = l'').
         apply IHl'. intros. apply H2. right. auto.
         simpl in  H3. destruct (ntree_eq_dec a0 n0). auto.  congruence.
         assert (a0 = n0).  apply H.  apply H2.  left. auto.
         simpl in H3. destruct ( ntree_eq_dec a0 n0). reflexivity. congruence.  rewrite H4.  rewrite H5.
         reflexivity.
         destruct l''.
         intro. congruence.
         intro.
         simpl list_eq.
         inversion H3.
         enough((ntree_eq_dec n0 n0) = true).
         rewrite H4.
         inversion H3.  rewrite<- H6.
         apply IHl'. intros x H10. apply H2. right. auto.
         reflexivity.
         apply H. rewrite<- H5.
         apply H2. left. auto.
         reflexivity.
      *   apply H2.   intro. auto.
          auto.
      *      congruence.
  -    intro.       destruct H1.
       subst x1_2.
       apply IHx1_1.
       apply H.  auto.
  -  intro.
     destruct x2.
     + split.
       intro.
       inversion H.
       simpl ntree_eq_dec.  destruct (Nat.eq_dec n0 n0).  reflexivity.
       congruence.
       simpl ntree_eq_dec. destruct (Nat.eq_dec n n0). subst n. firstorder eauto.
       intro. congruence.
     +  split. intro. congruence.
        intro. simpl ntree_eq_dec in H. congruence.
Defined.

(**
  * We can embed Ltrees / Gentrees (Ltrees are just gentrees with nat as a type)
  * into lists of (nat * nat) + nat.
  * The proofs of this equivalence are based on proofs from the stdpp library.
  *)
Definition flatten {A: Type} (l: list (list A)) : list A :=
  List.fold_right (@app A) [] l.

Fixpoint ntree_to_list (t : Ntree ) : list ((nat *  nat) + nat) :=
  match t with
  | NLeaf x => [inr x]
  | NBranch n ts =>  (flatten (List.map ntree_to_list ts )) ++ [ @inl (nat*nat) nat (length ts, n) ]
  end.

Fixpoint ntree_of_list
    (k : list (Ntree)) (l : list (nat * nat + nat)) : option (Ntree) :=
  match l with
  | [] => head k
  | inr x :: l => ntree_of_list (NLeaf x :: k) l
  | inl (len,n) :: l =>
     ntree_of_list (NBranch n (rev' (firstn len k)) :: skipn len k) l
  end.

Tactic Notation "trans" constr(A) := transitivity A.

About "::".

Lemma take_app_alt {A: Type} (l: list A) k :  firstn (length l) (l ++ k) = l.
Proof.
  induction l.
  - reflexivity.
  - simpl firstn.  rewrite IHl. reflexivity.
Qed.

Lemma drop_app_alt {A: Type} (l: list A) k :  skipn (length l) (l ++ k) = k.
Proof.
  induction l.
  - reflexivity.
  - simpl skipn.  rewrite IHl. reflexivity.
Qed.
Print rev.

Lemma ntree_of_to_list k l (t : Ntree) :
  ntree_of_list k (ntree_to_list t ++ l) = ntree_of_list (t :: k) l.
Proof.
  revert t k l. fix FIX 1. intros [|n ts] k l; simpl; auto.
    trans (ntree_of_list (rev' ts ++ k) ([inl (length ts, n)] ++ l)).
  -   rewrite<- app_assoc. revert k. generalize ([inl (length ts, n)] ++ l).
      induction ts as [|t ts'' IH]; intros k ts'''; simpl; auto.
      unfold rev. simpl rev_append.   rewrite<- app_assoc.  rewrite FIX. rewrite IH.
      unfold rev' at 2. simpl rev_append. rewrite rev_append_rev. rewrite<- app_assoc. simpl app at 3.  repeat rewrite<- app_assoc.  unfold rev'.
     rewrite rev_append_rev. rewrite app_nil_r . reflexivity.
  -  simpl.
     enough ((length ts) = length (rev' ts)).
     rewrite H.
     rewrite take_app_alt.
     rewrite drop_app_alt.
     unfold rev'.
     rewrite rev_append_rev.
     rewrite<- rev_alt.
     rewrite rev_involutive.
     enough (ts++[] = ts).
     rewrite H1.
     reflexivity.
     induction ts. simpl. reflexivity. simpl. rewrite IHts.  reflexivity.
     unfold rev'.
     rewrite rev_append_rev.
     enough ((rev ts)++[] = rev ts).
     rewrite H1.
     symmetry. apply rev_length.
     induction (rev ts). simpl. reflexivity. simpl. rewrite IHl0.  reflexivity.
     symmetry. unfold rev'.
     rewrite rev_append_rev. rewrite app_nil_r .  apply rev_length.
Qed.

Require Import List.
Import ListNotations.

Definition cumulative {X} (L: nat -> list X) :=
  forall n, exists A, L (S n) = L n ++ A.
Hint Extern 0 (cumulative _) => intros ?; cbn; eauto : core.

Lemma cum_ge {X} {L: nat -> list X} {n m} :
  cumulative L -> m >= n -> exists A, L m = L n ++ A.
Proof.
  induction 2 as [|m _ IH].
  - exists nil. now rewrite app_nil_r.
  - destruct (H m) as (A&->), IH as [B ->].
    exists (B ++ A). now rewrite app_assoc.
Qed.

Lemma cum_ge' {X} {L: nat -> list X} {x n m} :
  cumulative L -> In x (L n) -> m >= n -> In x (L m).
Proof.
  intros ? H [A ->] % (cum_ge (L := L)). apply in_app_iff. eauto. eauto.
Qed.

Definition list_enumerator {X} (L: nat -> list X) (p : X -> Prop) :=
  forall x, p x <-> exists m, In x (L m).
Definition list_enumerable {X} (p : X -> Prop) :=
  exists L, list_enumerator L p.

Definition list_enumerator__T' X f := forall x : X, exists n : nat, In x (f n).
Notation list_enumerator__T f X := (list_enumerator__T' X f).
Definition list_enumerable__T X := exists f : nat -> list X, list_enumerator__T f X.
Definition inf_list_enumerable__T X := { f : nat -> list X | list_enumerator__T f X }.

Section enumerator_list_enumerator.
  Variable X : Type.
  Variable p : X -> Prop.
  Variables (e : nat -> option X).

  Let T (n : nat) : list X :=  match e n with Some x => [x] | None => [] end.

  Lemma enumerator_to_list_enumerator : forall x, (exists n, e n = Some x) <-> (exists n, In x (T n)).
  Proof.
    split; intros [n H].
    - exists n. unfold T. rewrite H. firstorder.
    - unfold T in *. destruct (e n) eqn:E. inversion H; subst. eauto. destruct H1.  destruct H.
  Qed.

End enumerator_list_enumerator.

Definition enumerable {X} (p : X -> Prop) := exists f, forall x, p x <-> exists n : nat, f n = Some x.
Definition enumerable__T X := exists f : nat -> option X, forall x, exists n, f n = Some x.

Lemma enumerable_list_enumerable {X} {p : X -> Prop} :
  enumerable p -> list_enumerable p.
Proof.
  intros [f Hf]. eexists.
  unfold list_enumerator.
  intros x. rewrite <- enumerator_to_list_enumerator.
  eapply Hf.
Qed.

Lemma enumerable__T_list_enumerable {X} :
  enumerable__T X -> list_enumerable__T X.
Proof.
  intros [f Hf]. eexists.
  unfold list_enumerator.
  intros x. rewrite <- enumerator_to_list_enumerator.
  eapply Hf.
Qed.
(* bijection from nat * nat to nat *)
Definition embed '(x, y) : nat :=
  y + (nat_rec _ 0 (fun i m => (S i) + m) (y + x)).

(* bijection from nat to nat * nat *)
Definition unembed (n : nat) : nat * nat :=
  nat_rec _ (0, 0) (fun _ '(x, y) => match x with S x => (x, S y) | _ => (S y, 0) end) n.

Lemma embedP {xy: nat * nat} : unembed (embed xy) = xy.
Proof.
  assert (forall n, embed xy = n -> unembed n = xy).
    intro n. revert xy. induction n as [|n IH].
      intros [[|?] [|?]]; intro H; inversion H; reflexivity.
    intros [x [|y]]; simpl.
      case x as [|x]; simpl; intro H.
        inversion H.
      rewrite (IH (0, x)); [reflexivity|].
      inversion H; simpl. rewrite Nat.add_0_r. reflexivity.
    intro H. rewrite (IH (S x, y)); [reflexivity|].
    inversion H. simpl. rewrite Nat.add_succ_r. reflexivity.
  apply H. reflexivity.
Qed.

Lemma unembedP {n: nat} : embed (unembed n) = n.
Proof.
  induction n as [|n IH]; [reflexivity|].
  simpl. revert IH. case (unembed n). intros x y.
  case x as [|x]; intro Hx; rewrite <- Hx; simpl.
    rewrite Nat.add_0_r. reflexivity.
  rewrite ?Nat.add_succ_r. simpl. rewrite ?Nat.add_succ_r. reflexivity.
Qed.
Arguments embed : simpl never.

Module EmbedNatNotations.
  Notation "⟨ a , b ⟩" := (embed (a, b)) (at level 0).
End EmbedNatNotations.
Section enumerator_list_enumerator.

  Variable X : Type.
  Variables (T : nat -> list X).

  Let e (n : nat) : option X :=
    let (n, m) := unembed n in
    nth_error (T n) m.

  Lemma list_enumerator_to_enumerator : forall x, (exists n, e n = Some x) <-> (exists n, In x (T n)).
  Proof.
    split; intros [k H].
    - unfold e in *.
      destruct (unembed k) as (n, m).
      exists n. eapply (nth_error_In _ _ H).
    - unfold e in *.
      eapply In_nth_error in H as [m].
      exists (embed (k, m)). now rewrite embedP, H.
  Qed.

End enumerator_list_enumerator.

Definition enumerator {X} (f : nat -> option X) (P : X -> Prop) : Prop :=
	  forall x, P x <-> exists n, f n = Some x.

Lemma list_enumerator_enumerator {X} {p : X -> Prop} {T} :
  list_enumerator T p -> enumerator (fun n => let (n, m) := unembed n in
    nth_error (T n) m) p.
Proof.
  unfold list_enumerator.
  intros H x. rewrite list_enumerator_to_enumerator. eauto.
Qed.

Lemma list_enumerable_enumerable {X} {p : X -> Prop} :
  list_enumerable p -> enumerable p.
Proof.
  intros [T HT]. eexists.
  unfold list_enumerator.
  intros x. rewrite list_enumerator_to_enumerator.
  eapply HT.
Qed.

Lemma list_enumerable__T_enumerable {X} :
  list_enumerable__T X -> enumerable__T X.
Proof.
  intros [T HT]. eexists.
  unfold list_enumerator.
  intros x. rewrite list_enumerator_to_enumerator.
  eapply HT.
Qed.

Lemma enum_enumT {X} :
  enumerable__T X <-> list_enumerable__T X.
Proof.
  split.
  eapply enumerable__T_list_enumerable.
  eapply list_enumerable__T_enumerable.
Qed.

Definition to_cumul {X} (L : nat -> list X) := fix f n :=
  match n with 0 => [] | S n => f n ++ L n end.

Lemma to_cumul_cumulative {X} (L : nat -> list X) :
  cumulative (to_cumul L).
Proof.
  eauto.
Qed.

Lemma to_cumul_spec {X} (L : nat -> list X) x :
  (exists n, In x (L n)) <-> exists n, In x (to_cumul L n).
Proof.
  split.
  - intros [n H].
    exists (S n). cbn. eapply in_app_iff. eauto.
  - intros [n H].
    induction n; cbn in *.
    + inversion H.
    + eapply in_app_iff in H as [H | H]; eauto.
Qed.

Lemma cumul_In {X} (L : nat -> list X) x n :
  In x (L n) -> In x (to_cumul L (S n)).
Proof.
  intros H. cbn. eapply in_app_iff. eauto.
Qed.

Lemma In_cumul {X} (L : nat -> list X) x n :
  In x (to_cumul L n) -> exists n, In x (L n).
Proof.
  intros H. eapply to_cumul_spec. eauto.
Qed.

Lemma Cumul_Step {X} (L : nat -> list X) x n :
  forall m, n < m -> In x (L n) -> In x (to_cumul L m).
Proof.
  intros m. intros E. induction E. firstorder eauto.  apply cumul_In. assumption.
  intro. simpl to_cumul. apply in_app_iff. left. apply IHE. assumption.
Qed.

Hint Resolve cumul_In In_cumul : core.

Lemma list_enumerator_to_cumul {X} {p : X -> Prop} {L} :
  list_enumerator L p -> list_enumerator (to_cumul L) p.
Proof.
  unfold list_enumerator.
  intros. rewrite H.
  eapply to_cumul_spec.
Qed.

Lemma cumul_spec__T {X} {L} :
  list_enumerator__T L X -> list_enumerator__T (to_cumul L) X.
Proof.
  unfold list_enumerator__T.
  intros. now rewrite <- to_cumul_spec.
Qed.

Lemma cumul_spec {X} {L} {p : X -> Prop} :
  list_enumerator L p -> list_enumerator (to_cumul L) p.
Proof.
  unfold list_enumerator.
  intros. now rewrite <- to_cumul_spec.
Qed.

Module ListAutomationNotations.

  Notation "x 'el' L" := (In x L) (at level 70).
  Notation "A '<<=' B" := (incl A B) (at level 70).

  Notation "( A × B × .. × C )" := (list_prod .. (list_prod A B) .. C) (at level 0, left associativity).

End ListAutomationNotations.
Import ListAutomationNotations.

Ltac in_app n :=
  (match goal with
  | [ |- In _ (_ ++ _) ] =>
    match n with
    | 0 => idtac
    | 1 => eapply in_app_iff; left
    | S ?n => eapply in_app_iff; right; in_app n
    end
  | [ |- In _ (_ :: _) ] => match n with 0 => idtac | 1 => left | S ?n => right; in_app n end
  end) || (repeat (try right; eapply in_app_iff; right)).

Require Import Lia Arith.
Local Set Implicit Arguments.
Local Unset Strict Implicit.

Hint Extern 4 =>
match goal with
|[ H: ?x el nil |- _ ] => destruct H
end : core.

Hint Extern 4 =>
match goal with
|[ H: False |- _ ] => destruct H
|[ H: true=false |- _ ] => discriminate H
|[ H: false=true |- _ ] => discriminate H
end : core.
Lemma incl_nil X (A : list X) :
  nil <<= A.
Proof. intros x []. Qed.

Hint Rewrite <- app_assoc : list.
Hint Rewrite rev_app_distr map_app prod_length : list.
Hint Resolve in_eq in_nil in_cons in_or_app : core.
Hint Resolve incl_refl incl_tl incl_cons incl_appl incl_appr incl_app incl_nil : core.

Lemma app_incl_l X (A B C : list X) :
A ++ B <<= C -> A <<= C.
Proof.
firstorder eauto.
Qed.

Lemma app_incl_R X (A B C : list X) :
A ++ B <<= C -> B <<= C.
Proof.
firstorder eauto.
Qed.

Lemma cons_incl X (a : X) (A B : list X) : a :: A <<= B -> A <<= B.
Proof.
intros ? ? ?. eapply H. firstorder.
Qed.

Lemma incl_sing X (a : X) A : a el A -> [a] <<= A.
Proof.
now intros ? ? [-> | [] ].
Qed.

Hint Resolve app_incl_l app_incl_R cons_incl incl_sing : core.

Hint Extern 4 (_ el map _ _) => eapply in_map_iff : core.
Hint Extern 4 (_ el filter _ _) => eapply filter_In : core.

Section Inclusion.
  Variable X : Type.
  Implicit Types A B : list X.

  Lemma incl_nil_eq A :
    A <<= nil -> A=nil.

  Proof.
    intros D. destruct A as [|x A].
    - reflexivity.
    - exfalso. apply (D x). auto.
  Qed.

  Lemma incl_shift x A B :
    A <<= B -> x::A <<= x::B.

  Proof. auto. Qed.

  Lemma incl_lcons x A B :
    x::A <<= B <-> x el B /\ A <<= B.
  Proof.
    split.
    - intros D. split; hnf; auto.
    - intros [D E] z [F|F]; subst; auto.
  Qed.

  Lemma incl_rcons x A B :
    A <<= x::B -> ~ x el A -> A <<= B.

  Proof. intros C D y E. destruct (C y E) as [F|F]; congruence. Qed.

  Lemma incl_lrcons x A B :
    x::A <<= x::B -> ~ x el A -> A <<= B.

  Proof.
    intros C D y E.
    assert (F: y el x::B) by auto.
    destruct F as [F|F]; congruence.
  Qed.

  Lemma incl_app_left A B C :
    A ++ B <<= C -> A <<= C /\ B <<= C.
  Proof.
    firstorder.
  Qed.

End Inclusion.

Require Import Setoid Morphisms.

Instance incl_preorder X :
  PreOrder (@incl X).
Proof.
  constructor; hnf; unfold incl; auto.
Qed.

Definition equi X (A B : list X) : Prop := incl A B /\ incl B A.
Local Notation "A === B" := (equi A B) (at level 70).
Hint Unfold equi : core.

Instance equi_Equivalence X :
  Equivalence (@equi X).
Proof.
  constructor; hnf; firstorder.
Qed.

Instance incl_equi_proper X :
  Proper (@equi X ==> @equi X ==> iff) (@incl X).
Proof.
  hnf. intros A B D. hnf. firstorder.
Qed.

Instance cons_incl_proper X x :
  Proper (@incl X ==> @incl X) (@cons X x).
Proof.
  hnf. apply incl_shift.
Qed.

Instance cons_equi_proper X x :
  Proper (@equi X ==> @equi X) (@cons X x).
Proof.
  hnf. firstorder.
Qed.

Instance in_incl_proper X x :
  Proper (@incl X ==> Basics.impl) (@In X x).
Proof.
  intros A B D. hnf. auto.
Qed.

Instance in_equi_proper X x :
  Proper (@equi X ==> iff) (@In X x).
Proof.
  intros A B D. firstorder.
Qed.

Instance app_incl_proper X :
  Proper (@incl X ==> @incl X ==> @incl X) (@app X).
Proof.
  intros A B D A' B' E. auto.
Qed.

Instance app_equi_proper X :
  Proper (@equi X ==> @equi X ==> @equi X) (@app X).
Proof.
  hnf. intros A B D. hnf. intros A' B' E.
  destruct D, E; auto.
Qed.
Notation cumul := (to_cumul).

Ltac inv H := inversion H; subst; clear H.

Definition dec (X: Prop) : Type := {X} + {~ X}.

Coercion dec2bool P (d: dec P) := if d then true else false.
Definition is_true (b : bool) := b = true.

Existing Class dec.

Definition Dec (X: Prop) (d: dec X) : dec X := d.
Arguments Dec X {d}.

Lemma Dec_reflect (X: Prop) (d: dec X) :
  is_true (Dec X) <-> X.
Proof.
  destruct d as [A|A]; cbv in *; intuition congruence.
Qed.

Lemma Dec_auto (X: Prop) (d: dec X) :
  X -> is_true (Dec X).
Proof.
  destruct d as [A|A]; cbn; intuition congruence.
Qed.

(* Lemma Dec_auto_not (X: Prop) (d: dec X) : *)
(*   ~ X -> ~ Dec X. *)
(* Proof. *)
(*   destruct d as [A|A]; cbn; tauto. *)
(* Qed. *)

(* Hint Resolve Dec_auto Dec_auto_not : core. *)
Hint Extern 4 =>  (* Improves type class inference *)
match goal with
  | [  |- dec ((fun _ => _) _) ] => cbn
end : typeclass_instances.

Tactic Notation "decide" constr(p) :=
  destruct (Dec p).
Tactic Notation "decide" constr(p) "as" simple_intropattern(i) :=
  destruct (Dec p) as i.
Tactic Notation "decide" "_" :=
  destruct (Dec _).

Lemma Dec_true P {H : dec P} : dec2bool (Dec P) = true -> P.
Proof.
  decide P; cbv in *; firstorder.
Qed.

Lemma Dec_false P {H : dec P} : dec2bool (Dec P) = false -> ~P.
Proof.
  decide P; cbv in *; firstorder.
Qed.

Hint Extern 4 =>
match goal with
  [ H : dec2bool (Dec ?P) = true  |- _ ] => apply Dec_true in  H
| [ H : dec2bool (Dec ?P) = true |- _ ] => apply Dec_false in H
end : core.

(* Decided propositions behave classically *)

Lemma dec_DN X :
  dec X -> ~~ X -> X.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_and X Y :
  dec X -> dec Y -> ~ (X /\ Y) -> ~ X \/ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

Lemma dec_DM_impl X Y :
  dec X -> dec Y -> ~ (X -> Y) -> X /\ ~ Y.
Proof.
  unfold dec; tauto.
Qed.

(* Propagation rules for decisions *)

Fact dec_transfer P Q :
  P <-> Q -> dec P -> dec Q.
Proof.
  unfold dec. tauto.
Qed.

Instance True_dec :
  dec True.
Proof.
  unfold dec; tauto.
Qed.

Instance False_dec :
  dec False.
Proof.
  unfold dec; tauto.
Qed.

Instance impl_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X -> Y).
Proof.
  unfold dec; tauto.
Qed.

Instance and_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X /\ Y).
Proof.
  unfold dec; tauto.
Qed.

Instance or_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X \/ Y).
Proof.
  unfold dec; tauto.
Qed.

(* Coq standard modules make "not" and "iff" opaque for type class inference,
   can be seen with Print HintDb typeclass_instances. *)

Instance not_dec (X : Prop) :
  dec X -> dec (~ X).
Proof.
  unfold not. firstorder eauto.
Qed.

Instance iff_dec (X Y : Prop) :
  dec X -> dec Y -> dec (X <-> Y).
Proof.
  unfold iff. firstorder eauto.
Qed.

(* Discrete types *)

Notation "'eq_dec' X" := (forall x y : X, dec (x=y)) (at level 70).

Structure eqType := EqType {
  eqType_X :> Type;
  eqType_dec : eq_dec eqType_X }.

Arguments EqType X {_} : rename.

Canonical Structure eqType_CS X (A: eq_dec X) := EqType X.

Existing Instance eqType_dec.

Instance unit_eq_dec :
  eq_dec unit.
Proof.
  unfold dec. decide equality.
Qed.

Instance bool_eq_dec :
  eq_dec bool.
Proof.
  unfold dec. decide equality.
Defined.

Instance nat_eq_dec :
  eq_dec nat.
Proof.
  unfold dec. decide equality.
Defined.

Instance prod_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X * Y).
Proof.
  unfold dec. decide equality.
Defined.

Instance list_eq_dec X :
  eq_dec X -> eq_dec (list X).
Proof.
  unfold dec. decide equality.
Defined.

Instance sum_eq_dec X Y :
  eq_dec X -> eq_dec Y -> eq_dec (X + Y).
Proof.
  unfold dec. decide equality.
Defined.

Instance option_eq_dec X :
  eq_dec X -> eq_dec (option X).
Proof.
  unfold dec. decide equality.
Defined.

Instance Empty_set_eq_dec:
  eq_dec Empty_set.
Proof.
  unfold dec. decide equality.
Qed.

Instance True_eq_dec:
  eq_dec True.
Proof.
  intros x y. destruct x,y. now left.
Qed.

Instance False_eq_dec:
  eq_dec False.
Proof.
  intros [].
Qed.

  Notation "[ s | p ∈ A ',' P ]" :=
    (map (fun p => s) (filter (fun p => Dec P) A)) (p pattern).

Section L_list_def.
  Context {X : Type}.
  Variable (L : nat -> list X).
  Print cumul.
  Import ListAutomationNotations.
  Notation "( A × B × .. × C )" := (list_prod .. (list_prod A B) .. C) (at level 0, left associativity).
  Notation "[ s | p ∈ A ]" :=
    (map (fun p => s) A) (p pattern).

  Fixpoint L_list (n : nat) : list (list X) :=
	  match n
	  with
	  | 0 => [ [] ]
	  | S n => L_list n ++ [x :: L | (x,L) ∈ (cumul L n × L_list n)]
	  end.

End L_list_def.

Lemma L_list_cumulative {X} L : cumulative (@L_list X L).
Proof.
  intros ?; cbn; eauto.
Qed.

Ltac in_collect a :=
  eapply in_map_iff; exists a; split; [ eauto | match goal with
                                              _ => try (rewrite !in_prod_iff; repeat split) end ].

Lemma enumerator__T_list {X} L :
  list_enumerator__T L X -> list_enumerator__T (L_list L) (list X).
Proof.
  intros H l.
  induction l.
  - exists 0. cbn. eauto.
  - destruct IHl as [n IH].
    destruct (cumul_spec__T H a) as [m ?].
    exists (1 + n + m). cbn. intros. in_app 2.
    in_collect (a,l).
    all: eapply cum_ge'; eauto using L_list_cumulative; lia.
Qed.

Section L_sum_def.
  Context {X1 X2 : Type}.
  Variables (L1 : nat -> list X1) (L2: nat -> list X2).
  Print cumul.
  Import ListAutomationNotations.
  Notation "( A × B × .. × C )" := (list_prod .. (list_prod A B) .. C) (at level 0, left associativity).
  Notation "[ s | p ∈ A ]" :=
    (map (fun p => s) A) (p pattern).

  Definition L_sum_list (n : nat) : list (X1+X2) :=
	  (List.map inl (L1 n)) ++ (List.map inr (L2 n))
	 .

End L_sum_def.

Lemma enumerator_sum_list {X1 X2} L1 L2 :
  list_enumerator__T L1 X1 -> list_enumerator__T L2 X2 -> list_enumerator__T (L_sum_list L1 L2) (X1+X2).
Proof.
  intros H1 H2.
  intro.
  destruct x.
  - destruct (H1 x) as [n1 Hn1].
   exists n1.  unfold L_sum_list. rewrite in_app_iff.
    left. apply in_map_iff. exists x. firstorder eauto.
  - destruct (H2 x).    unfold L_sum_list. exists x0. rewrite in_app_iff.
    right. apply in_map_iff.  exists x. split; firstorder eauto.
Qed.

(* Pickles X1 * X2 *)
Section L_prod_def.
  Context {X1 X2 : Type}.
  Variables (L1 : nat -> list X1) (L2: nat -> list X2).
  Print cumul.
  Import ListAutomationNotations.
  Notation "( A × B × .. × C )" := (list_prod .. (list_prod A B) .. C) (at level 0, left associativity).
  Notation "[ s | p ∈ A ]" :=
    (map (fun p => s) A) (p pattern).

  Definition L_prod_list (n : nat) : list (X1*X2) :=
	   ((L1 n) × (L2 n)).

End L_prod_def.

  Fact list_prod_spec X Y l m c : In c (@list_prod X Y l m) <-> In (fst c) l /\ In (snd c) m.
  Proof.
    revert c; induction l as [ | x l IHl ]; intros c; simpl; try tauto.
    rewrite in_app_iff, IHl, in_map_iff; simpl.
    split.
    + intros [ (y & <- & ?) | (? & ?) ]; simpl; auto.
    + intros ([ -> | ] & ? ); destruct c; simpl; firstorder.
  Qed.

Search "L_prod".
Lemma enumerator_prod_list {X1 X2} L1 L2 :
  list_enumerator__T L1 X1 -> list_enumerator__T L2 X2 -> list_enumerator__T (L_prod_list (to_cumul L1) (to_cumul L2)) (X1*X2).
Proof.
  intros H1 H2.
  intro.
  destruct x as [x1 x2].
  specialize (H1 x1). specialize (H2 x2).
  destruct H1 as [n1 Hn1]. destruct H2 as [n2 Hn2].
  exists (S(Nat.max n1 n2)).

  apply list_prod_spec.
  split.
  simpl fst.
  apply Cumul_Step with n1.
  lia.
  auto.

  apply Cumul_Step with n2.
  lia.
  exact Hn2.
Qed.

Lemma  enumerable_list {X} : list_enumerable__T X -> list_enumerable__T (list X).
Proof.
  intros [L H].
  eexists. now eapply enumerator__T_list.
Qed.

Lemma  enumerable_sum {X1 X2} : list_enumerable__T X1 -> list_enumerable__T X2 -> list_enumerable__T (X1+X2).
Proof.
  intros [L1 H1]. intros  [L2 H2].

  eexists. now eapply enumerator_sum_list.
Qed.

Lemma  enumerable_prod {X1 X2} : list_enumerable__T X1 -> list_enumerable__T X2 -> list_enumerable__T (X1*X2).
Proof.
  intros [L1 H1]. intros  [L2 H2].

  eexists. now eapply enumerator_prod_list.
Qed.
Lemma enumNatNat: enumerable__T ((nat*nat)+nat).
Proof.
  enough (H: enumerable__T nat).
  apply enum_enumT.
  apply enumerable_sum.
  apply enum_enumT.
  apply enum_enumT.

  apply enumerable_prod. apply enum_enumT. apply H.
  apply enum_enumT. apply H. apply enum_enumT. apply H.
  unfold enumerable__T.
  exists (fun x => Some x).  intro. eauto.
Defined.
Lemma enumerableDecodeEncode (A B: Type)
      (code: A -> B)
      (decode: B -> option A)
      (H1: forall a, (decode (code a)) = Some a)
      (enumB: enumerable__T B)
  : enumerable__T A.
Proof.
  unfold enumerable__T.
  destruct enumB as [fb Hb].
  exists (fun n => match (fb n) with None => None | Some x => (decode x) end).
  intro a. specialize (H1 a).
  specialize (Hb (code a)).
  destruct Hb. exists x. rewrite H. apply H1.
Defined.

Print enumerableDecodeEncode.
Lemma enumLtree: enumerable__T Ntree.
Proof.
  apply (@enumerableDecodeEncode Ntree (list ((nat*nat)+nat)) ntree_to_list (ntree_of_list [])  ).
  intro.
  pose (ntree_of_to_list [] [] a).
  rewrite app_nil_r in e.
  rewrite e.
  simpl ntree_of_list.
  reflexivity.
  apply  enum_enumT.
  apply enumerable_list.
  apply enum_enumT.
  apply enumNatNat.
Defined.

(** Ntrees are decidable **)
Instance Ntree_eq_dec :
  eq_dec Ntree.
Proof.
  intros x y.
  destruct ((ntree_eq_dec x y)) eqn:H.
  left.
  apply ntree_equal_dec_lemma.
  auto.
  right. intro.  apply ntree_equal_dec_lemma in H1. congruence.
Defined.


Require Import Arith.
Require Import Omega.
Require Import List.
Import ListNotations.
Require Import Sorting.Permutation.
Require Import StructTact.StructTactics.
Require Import StructTact.ListTactics.

Set Implicit Arguments.

Notation member := (in_dec eq_nat_dec).

Lemma seq_range :
  forall n a x,
    In x (seq a n) ->
    a <= x < a + n.
Proof.
  induction n; intros; simpl in *.
  - intuition.
  - break_or_hyp; try find_apply_hyp_hyp; intuition.
Qed.

Lemma plus_gt_0 :
  forall a b,
    a + b > 0 ->
    a > 0 \/ b > 0.
Proof.
  intros.
  destruct (eq_nat_dec a 0); intuition.
Qed.

Section list_util.
  Variables A B C : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Lemma list_neq_cons :
    forall (l : list A) x,
      x :: l <> l.
  Proof using.
    intuition.
    symmetry in H.
    induction l;
      now inversion H.
  Qed.

  Lemma remove_preserve :
    forall (x y : A) xs,
      x <> y ->
      In y xs ->
      In y (remove A_eq_dec x xs).
  Proof using.
    induction xs; intros.
    - intuition.
    - simpl in *.
      concludes.
      intuition; break_if; subst; try congruence; intuition.
  Qed.

  Lemma in_remove :
    forall (x y : A) xs,
      In y (remove A_eq_dec x xs) ->
      In y xs.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl in *. break_if; simpl in *; intuition.
  Qed.

  Lemma remove_partition :
    forall xs (p : A) ys,
      remove A_eq_dec p (xs ++ p :: ys) = remove A_eq_dec p (xs ++ ys).
  Proof using.
    induction xs; intros; simpl; break_if; congruence.
  Qed.

  Lemma remove_not_in :
    forall (x : A) xs,
      ~ In x xs ->
      remove A_eq_dec x xs = xs.
  Proof using.
    intros. induction xs; simpl in *; try break_if; intuition congruence.
  Qed.

  Lemma remove_app_comm :
    forall a xs ys,
      remove A_eq_dec a (xs ++ ys) = remove A_eq_dec a xs ++ remove A_eq_dec a ys.
  Proof.
    intros.
    generalize dependent ys.
    induction xs; intros.
    - tauto.
    - destruct (A_eq_dec a0 a);
      simpl;
      break_if;
      try rewrite <- app_comm_cons;
      rewrite IHxs;
      congruence.
  Qed.

  Lemma filter_app : forall (f : A -> bool) xs ys,
      filter f (xs ++ ys) = filter f xs ++ filter f ys.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl. rewrite IHxs. break_if; auto.
  Qed.

  Lemma filter_fun_ext_eq : forall f g xs,
      (forall a : A, In a xs -> f a = g a) ->
      filter f xs = filter g xs.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl. rewrite H by intuition. rewrite IHxs by intuition. auto.
  Qed.

  Lemma not_in_filter_false :
    forall (f : A -> bool) l x,
      In x l ->
      ~ In x (filter f l) ->
      f x = false.
  Proof.
    intros.
    destruct (f x) eqn:?H; [|tauto].
    unfold not in *; find_false.
    now eapply filter_In.
  Qed.

  Lemma filter_length_bound :
    forall f (l : list A),
      length (filter f l) <= length l.
  Proof.
    induction l.
    - easy.
    - simpl.
      break_if; simpl; omega.
  Qed.

  Lemma NoDup_map_injective : forall (f : A -> B) xs,
      (forall x y, In x xs -> In y xs ->
              f x = f y -> x = y) ->
      NoDup xs -> NoDup (map f xs).
  Proof using.
    induction xs; intros.
    - constructor.
    - simpl. invc_NoDup. constructor.
      + intro. do_in_map.
        assert (x = a) by intuition.
        congruence.
      + intuition.
  Qed.

  Lemma NoDup_disjoint_append :
    forall (l : list A) l',
      NoDup l ->
      NoDup l' ->
      (forall a, In a l -> ~ In a l') ->
      NoDup (l ++ l').
  Proof using.
    induction l; intros.
    - auto.
    - simpl. invc_NoDup. constructor.
      + intro. do_in_app. intuition eauto with *.
      + intuition eauto with *.
  Qed.

  Lemma NoDup_map_partition :
    forall (f : A -> B) xs l y zs xs' y' zs',
      NoDup (map f l) ->
      l = xs ++ y :: zs ->
      l = xs' ++ y' :: zs' ->
      f y = f y' ->
      xs = xs'.
  Proof using.
    induction xs; simpl; intros; destruct xs'.
    - auto.
    - subst. simpl in *. find_inversion.
      invc H. exfalso. rewrite map_app in *. simpl in *.
      repeat find_rewrite. intuition.
    - subst. simpl in *. find_inversion.
      invc H. exfalso. rewrite map_app in *. simpl in *.
      repeat find_rewrite. intuition.
    - subst. simpl in *. find_injection. intros. subst.
      f_equal. eapply IHxs; eauto. solve_by_inversion.
  Qed.

  Lemma filter_NoDup :
    forall p (l : list A),
      NoDup l ->
      NoDup (filter p l).
  Proof using.
    induction l; intros.
    - auto.
    - invc_NoDup. simpl. break_if; auto.
      constructor; auto.
      intro. apply filter_In in H. intuition.
  Qed.

  Lemma NoDup_map_filter :
    forall (f : A -> B) g l,
      NoDup (map f l) ->
      NoDup (map f (filter g l)).
  Proof using.
    intros. induction l; simpl in *.
    - constructor.
    - invc_NoDup. concludes.
      break_if; simpl in *; auto.
      constructor; auto.
      intro. do_in_map.
      find_apply_lem_hyp filter_In. intuition.
      match goal with | H : _ -> False |- False => apply H end.
      apply in_map_iff. eauto.
  Qed.

  Lemma filter_true_id : forall (f : A -> bool) xs,
      (forall x, In x xs -> f x = true) ->
      filter f xs = xs.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl. now rewrite H, IHxs by intuition.
  Qed.

  Lemma map_of_map : forall (f : A -> B) (g : B -> C) xs,
      map g (map f xs) = map (fun x => g (f x)) xs.
  Proof using.
    induction xs; simpl; auto using f_equal2.
  Qed.

  Lemma filter_except_one : forall (f g : A -> bool) x xs,
      (forall y, In y xs ->
            x <> y ->
            f y = g y) ->
      g x = false ->
      filter f (remove A_eq_dec x xs) = filter g xs.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl.
      break_if.
      + subst. repeat find_rewrite. eauto with *.
      + simpl. rewrite H by auto with *.
        break_if; eauto using f_equal2 with *.
  Qed.

  Lemma flat_map_nil : forall (f : A -> list B) l,
      flat_map f l = [] ->
      l = [] \/ (forall x, In x l -> f x = []).
  Proof using.
    induction l; intros.
    - intuition.
    - right. simpl in *.
      apply app_eq_nil in H.
      intuition; subst; simpl in *; intuition.
  Qed.

  Theorem NoDup_Permutation_NoDup :
    forall (l l' : list A),
      NoDup l ->
      Permutation l l' ->
      NoDup l'.
  Proof using.
    intros l l' Hnd Hp.
    induction Hp; auto; invc_NoDup; constructor;
      eauto using Permutation_in, Permutation_sym;
      simpl in *; intuition.
  Qed.

  Theorem NoDup_append :
    forall l (a : A),
      NoDup (l ++ [a]) <-> NoDup (a :: l).
  Proof using.
    intuition eauto using NoDup_Permutation_NoDup, Permutation_sym, Permutation_cons_append.
  Qed.

  Lemma NoDup_map_elim :
    forall (f : A -> B) xs x y,
      f x = f y ->
      NoDup (map f xs) ->
      In x xs ->
      In y xs ->
      x = y.
  Proof using.
    induction xs; intros; simpl in *.
    - intuition.
    - invc_NoDup. intuition; subst; auto; exfalso.
      + repeat find_rewrite. auto using in_map.
      + repeat find_reverse_rewrite. auto using in_map.
  Qed.

  Lemma remove_length_not_in : forall (x : A) xs,
      ~ In x xs ->
      length (remove A_eq_dec x xs) = length xs.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl in *. intuition.
      break_if; subst; simpl; intuition.
  Qed.

  Lemma remove_length_in : forall (x : A) xs,
      In x xs ->
      NoDup xs ->
      S (length (remove A_eq_dec x xs)) = length xs.
  Proof using.
    induction xs; intros; simpl in *; intuition; invc_NoDup;
      break_if; subst; intuition (simpl; try congruence).
    now rewrite remove_length_not_in.
  Qed.

  Lemma subset_size_eq :
    forall xs,
      NoDup xs ->
      forall ys,
        NoDup ys ->
        (forall x : A, In x xs -> In x ys) ->
        length xs = length ys ->
        (forall x, In x ys -> In x xs).
  Proof using.
    induction xs; intros.
    - destruct ys; simpl in *; congruence.
    - invc_NoDup. concludes.
      assert (In a ys) by eauto with *.

      find_apply_lem_hyp in_split.
      break_exists_name l1.
      break_exists_name l2.
      subst.

      specialize (IHxs (l1 ++ l2)).

      conclude_using ltac:(eauto using NoDup_remove_1).

      forward IHxs.
      intros x' Hx'.
      assert (In x' (l1 ++ a :: l2)) by eauto with *.
      do_in_app. simpl in *. intuition. subst. congruence.
      concludes.

      forward IHxs.
      rewrite app_length in *. simpl in *. omega.
      concludes.

      do_in_app. simpl in *. intuition.
  Qed.

  Lemma remove_NoDup :
    forall (x : A) xs,
      NoDup xs ->
      NoDup (remove A_eq_dec x xs).
  Proof using.
    induction xs; intros.
    - auto with struct_util.
    - invc_NoDup. simpl. break_if; eauto 6 using in_remove with struct_util.
  Qed.

  Lemma remove_length_ge : forall (x : A) xs,
      NoDup xs ->
      length (remove A_eq_dec x xs) >= length xs - 1.
  Proof using.
    induction xs; intros.
    - auto.
    - invc_NoDup. simpl. break_if.
      + rewrite <- minus_n_O.
        subst.
        rewrite remove_length_not_in; auto.
      + simpl. concludes. omega.
  Qed.

  Lemma remove_length_le :
    forall (x : A) xs eq_dec,
      length xs >= length (remove eq_dec x xs).
  Proof using.
    induction xs; intros.
    - auto.
    - simpl in *.
      specialize (IHxs eq_dec).
      break_if; subst; simpl; omega.
  Qed.

  Lemma remove_length_lt :
    forall (x : A) xs eq_dec,
      In x xs ->
      length xs > length (remove eq_dec x xs).
  Proof using.
    induction xs; intros; simpl in *; intuition.
    - subst.
      break_if; try congruence.
      pose proof remove_length_le x xs eq_dec.
      omega.
    - specialize (IHxs ltac:(eauto) ltac:(eauto)).
      break_if; subst; simpl; omega.
  Qed.

  Lemma subset_length :
    forall xs ys,
      NoDup xs ->
      (forall x : A, In x xs -> In x ys) ->
      length ys >= length xs.
  Proof using A_eq_dec.
    induction xs; intros.
    - simpl. omega.
    - specialize (IHxs (remove A_eq_dec a ys)).
      invc_NoDup.
      concludes.

      forward IHxs.
      intros.
      apply remove_preserve; [congruence|intuition].
      concludes.

      pose proof remove_length_lt a ys A_eq_dec.
      conclude_using intuition.

      simpl. omega.
  Qed.

  Lemma app_cons_singleton_inv :
    forall xs (y : A) zs w,
      xs ++ y :: zs = [w] ->
      xs = [] /\ y = w /\ zs = [].
  Proof using.
    intros.
    destruct xs.
    - solve_by_inversion.
    - destruct xs; solve_by_inversion.
  Qed.

  Lemma app_cons_in :
    forall (l : list A) xs a ys,
      l = xs ++ a :: ys ->
      In a l.
  Proof using.
    intros. subst. auto with *.
  Qed.
  Hint Resolve app_cons_in : struct_util.

  Lemma app_cons_in_rest:
    forall (l : list A) xs a b ys,
      l = xs ++ a :: ys ->
      In b (xs ++ ys) ->
      In b l.
  Proof using.
    intros. subst. in_crush.
  Qed.
  Hint Resolve app_cons_in_rest : struct_util.

  Lemma in_rest_app_cons:
    forall (l xs ys : list A) a b,
      l = xs ++ a :: ys ->
      In b l ->
      a <> b ->
      In b (xs ++ ys).
  Proof using.
    intros.
    subst_max.
    do_in_app.
    break_or_hyp.
    - auto with datatypes.
    - find_apply_lem_hyp in_inv.
      break_or_hyp; auto using in_or_app || congruence.
  Qed.
  Hint Resolve in_rest_app_cons : struct_util.

  Lemma remove_filter_commute :
    forall (l : list A) A_eq_dec f x,
      remove A_eq_dec x (filter f l) = filter f (remove A_eq_dec x l).
  Proof using.
    induction l; intros; simpl in *; auto.
    repeat (break_if; subst; simpl in *; try congruence).
  Qed.

  Lemma In_filter_In :
    forall (f : A -> bool) x l l',
      filter f l = l' ->
      In x l' -> In x l.
  Proof using.
    intros. subst.
    eapply filter_In; eauto.
  Qed.

  Lemma filter_partition :
    forall (l1 : list A) f l2 x l1' l2',
      NoDup (l1 ++ x :: l2) ->
      filter f (l1 ++ x :: l2) = (l1' ++ x :: l2') ->
      filter f l1 = l1' /\ filter f l2 = l2'.
  Proof using.
    induction l1; intros; simpl in *; break_if; simpl in *; invc_NoDup.
    - destruct l1'; simpl in *.
      + solve_by_inversion.
      + find_inversion. exfalso. eauto using In_filter_In with *.
    - exfalso. eauto using In_filter_In with *.
    - destruct l1'; simpl in *; break_and; find_inversion.
      + exfalso. eauto with *.
      + find_apply_hyp_hyp. intuition auto using f_equal2.
    - eauto.
  Qed.

  Lemma map_inverses :
    forall (la : list A) (lb : list B)  (f : A -> B) g,
      (forall a, g (f a) = a) ->
      (forall b, f (g b) = b) ->
      lb = map f la ->
      la = map g lb.
  Proof using.
    destruct la; intros; simpl in *.
    - subst. reflexivity.
    - destruct lb; try congruence.
      simpl in *. find_inversion.
      find_higher_order_rewrite.
      f_equal.
      rewrite map_map.
      erewrite map_ext; [symmetry; apply map_id|].
      simpl in *. auto.
  Qed.

  Lemma In_notIn_implies_neq :
    forall x y l,
      In(A:=A) x l ->
      ~ In(A:=A) y l ->
      x <> y.
  Proof using.
    intuition congruence.
  Qed.

  Lemma In_cons_neq :
    forall a x xs,
      In(A:=A) a (x :: xs) ->
      a <> x ->
      In a xs.
  Proof using.
    simpl.
    intuition congruence.
  Qed.

  Lemma NoDup_app3_not_in_1 :
    forall (xs ys zs : list A) b,
      NoDup (xs ++ ys ++ b :: zs) ->
      In b xs ->
      False.
  Proof using.
    intros.
    rewrite <- app_ass in *.
    find_apply_lem_hyp NoDup_remove.
    rewrite app_ass in *.
    intuition.
  Qed.

  Lemma NoDup_app3_not_in_2 :
    forall (xs ys zs : list A) b,
      NoDup (xs ++ ys ++ b :: zs) ->
      In b ys ->
      False.
  Proof using.
    intros.
    rewrite <- app_ass in *.
    find_apply_lem_hyp NoDup_remove_2.
    rewrite app_ass in *.
    auto 10 with *.
  Qed.

  Lemma NoDup_app3_not_in_3 :
    forall (xs ys zs : list A) b,
      NoDup (xs ++ ys ++ b :: zs) ->
      In b zs ->
      False.
  Proof using.
    intros.
    rewrite <- app_ass in *.
    find_apply_lem_hyp NoDup_remove_2.
    rewrite app_ass in *.
    auto 10 with *.
  Qed.

  Lemma In_cons_2_3 :
    forall xs ys zs x y a,
      In (A:=A) a (xs ++ ys ++ zs) ->
      In a (xs ++ x :: ys ++ y :: zs).
  Proof using.
    intros.
    repeat (do_in_app; intuition auto 10 with *).
  Qed.

  Lemma In_cons_2_3_neq :
    forall a x y xs ys zs,
      In (A:=A) a (xs ++ x :: ys ++ y :: zs) ->
      a <> x ->
      a <> y ->
      In a (xs ++ ys ++ zs).
  Proof using.
    intros.
    repeat (do_in_app; simpl in *; intuition (auto with *; try congruence)).
  Qed.

  Lemma in_middle_reduce :
    forall a xs y zs,
      In (A:=A) a (xs ++ y :: zs) ->
      a <> y ->
      In a (xs ++ zs).
  Proof using.
    intros.
    do_in_app; simpl in *; intuition. congruence.
  Qed.

  Lemma in_middle_insert :
    forall a xs y zs,
      In (A:=A) a (xs ++ zs) ->
      In a (xs ++ y :: zs).
  Proof using.
    intros.
    do_in_app; simpl in *; intuition.
  Qed.

  Lemma NoDup_rev :
    forall l,
      NoDup (A:=A) l ->
      NoDup (rev l).
  Proof using.
    induction l; intros; simpl.
    - auto.
    - apply NoDup_append.
      invc_NoDup.
      constructor; auto.
      intuition.
      find_apply_lem_hyp in_rev.
      auto.
  Qed.

  Lemma NoDup_map_map :
    forall (f : A -> B) (g : A -> C) xs,
      (forall x y, In x xs -> In y xs -> f x = f y -> g x = g y) ->
      NoDup (map g xs) ->
      NoDup (map f xs).
  Proof using.
    induction xs; intros; simpl in *.
    - constructor.
    - invc_NoDup.
      constructor; auto.
      intro.
      do_in_map.
      find_apply_hyp_hyp.
      find_reverse_rewrite.
      auto using in_map.
  Qed.

  Lemma pigeon :
    forall (l : list A) sub1 sub2,
      (forall a, In a sub1 -> In a l) ->
      (forall a, In a sub2 -> In a l) ->
      NoDup l ->
      NoDup sub1 ->
      NoDup sub2 ->
      length sub1 + length sub2 > length l ->
      exists a, In a sub1 /\ In a sub2.
  Proof using A_eq_dec.
    induction l.
    intros.
    + simpl in *. find_apply_lem_hyp plus_gt_0. intuition.
      * destruct sub1; simpl in *; [omega|].
        specialize (H a). intuition.
      * destruct sub2; simpl in *; [omega|].
        specialize (H0 a). intuition.
    + intros. simpl in *.
      destruct (in_dec A_eq_dec a sub1);
        destruct (in_dec A_eq_dec a sub2); eauto;
          specialize (IHl (remove A_eq_dec a sub1) (remove A_eq_dec a sub2));
          cut (exists a0, In a0 (remove A_eq_dec a sub1) /\ In a0 (remove A_eq_dec a sub2));
          try solve [intros; break_exists;
                     intuition eauto using in_remove];
          apply IHl; try solve [
                           intros; find_copy_apply_lem_hyp in_remove;
                           find_apply_hyp_hyp; intuition; subst; exfalso; eapply remove_In; eauto];
          eauto using remove_NoDup; try solve_by_inversion;
            repeat match goal with
                   | H : ~ In a ?sub |- _ =>
                     assert (length (remove A_eq_dec a sub) = length sub)
                       by eauto using remove_length_not_in; clear H
                   | H : In a ?sub |- _ =>
                     assert (length (remove A_eq_dec a sub) >= length sub - 1)
                       by eauto using remove_length_ge; clear H
                   end; omega.
  Qed.

  Lemma snoc_assoc :
    forall (l : list A) x y,
      l ++ [x; y] = (l ++ [x]) ++ [y].
  Proof using.
    induction l; intros; simpl; intuition.
    auto using f_equal.
  Qed.

  Lemma cons_cons_app :
    forall (x y : A),
      [x; y] = [x] ++ [y].
  Proof using.
    auto.
  Qed.

  Lemma map_eq_inv :
    forall (f : A -> B) l xs ys,
      map f l = xs ++ ys ->
      exists l1 l2,
        l = l1 ++ l2 /\
        map f l1 = xs /\
        map f l2 = ys.
  Proof using.
    induction l; simpl; intros xs ys H.
    - symmetry in H. apply app_eq_nil in H. break_and. subst.
      exists [], []. auto.
    - destruct xs; simpl in *.
      + exists [], (a :: l). intuition.
      + invc H. find_apply_hyp_hyp.
        break_exists_name l1.
        break_exists_name l2.
        break_and.
        exists (a :: l1), l2. subst.
        intuition.
  Qed.

  Lemma map_partition :
    forall p l (x : B) p' (f : A -> B),
      map f l = (p ++ x :: p') ->
      exists ap a ap',
        l = ap ++ a :: ap' /\
        map f ap = p /\
        f a = x /\
        map f ap' = p'.
  Proof using.
    intros p l x p' f H_m.
    pose proof map_eq_inv f _ _ _ H_m.
    break_exists_name l1.
    break_exists_name l2.
    break_and.
    find_rewrite.
    destruct l2; simpl in *.
    - match goal with H : [] = _ :: _ |- _ => contradict H end.
      auto with datatypes.
    - repeat find_rewrite.
      find_inversion.
      exists l1, a, l2. auto.
  Qed.

  Lemma map_eq_inv_eq :
    forall (f : A -> B),
      (forall a a', f a = f a' -> a = a') ->
      forall l l', map f l = map f l' -> l = l'.
  Proof using.
    induction l; simpl; intros l' Heq; destruct l'; simpl in *; try congruence.
    find_inversion. auto using f_equal2.
  Qed.

  Lemma map_fst_snd_id :
    forall l, map (fun t : A * B => (fst t, snd t)) l = l.
  Proof using.
    intros.
    rewrite <- map_id.
    apply map_ext.
    destruct a; auto.
  Qed.

  Lemma in_firstn : forall n (x : A) xs,
      In x (firstn n xs) -> In x xs.
  Proof using.
    induction n; simpl; intuition; break_match; simpl in *; intuition.
  Qed.

  Lemma firstn_NoDup : forall n (xs : list A),
    NoDup xs ->
    NoDup (firstn n xs).
  Proof using.
    induction n; intros; simpl; destruct xs; auto with struct_util.
    invc_NoDup.
    eauto 6 using in_firstn with struct_util.
  Qed.

  Lemma NoDup_mid_not_in :
    forall (a : A) (l l' : list A),
    NoDup (l ++ a :: l') ->
    ~ In a (l ++ l').
  Proof using.
    induction l; intros; simpl in *.
    - invc_NoDup; auto.
    - invc_NoDup.
      intro.
      break_or_hyp.
      * match goal with H: ~ In _ _ |- _ => contradict H end.
        apply in_or_app.
        right; left. auto.
      * match goal with H: In _ _ |- _ => contradict H end.
        eauto.
    Qed.

  Lemma Permutation_split :
    forall (ns ns' : list A) (n : A),
      Permutation (n :: ns) ns' ->
      exists ns0, exists ns1, ns' = ns0 ++ n :: ns1.
  Proof using.
    intros l l' a H_pm.
    assert (In a (a :: l)); auto with datatypes.
    assert (In a l'); eauto using Permutation_in.
    find_apply_lem_hyp In_split; auto.
  Qed.

  Lemma NoDup_app_left :
    forall (l l' : list A),
      NoDup (l ++ l') -> NoDup l.
  Proof using.
    induction l; intros; simpl in *.
    - apply NoDup_nil.
    - invc_NoDup.
      find_apply_hyp_hyp.
      apply NoDup_cons; auto.
      intro.
      match goal with H: ~ In _ _ |- _ => contradict H end.
      apply in_or_app.
      left; auto.
  Qed.

  Lemma NoDup_app_right :
    forall (l l' : list A),
      NoDup (l ++ l') -> NoDup l'.
  Proof using.
    induction l; intros; simpl in *; auto.
    invc_NoDup.
    find_apply_hyp_hyp; auto.
  Qed.

  Lemma NoDup_in_not_in_right :
    forall (l l' : list A) (a : A),
      NoDup (l ++ l') -> In a l -> ~ In a l'.
  Proof using.
    induction l; intros; simpl in *; auto.
    invc_NoDup.
    break_or_hyp; eauto with datatypes.
  Qed.

  Lemma NoDup_in_not_in_left :
    forall (l l' : list A) (a : A),
    NoDup (l ++ l') -> In a l' -> ~ In a l.
  Proof using.
    intros.
    induction l; simpl in *; auto.
    invc_NoDup.
    concludes.
    intro.
    break_or_hyp; auto with datatypes.
  Qed.

  Lemma count_occ_app :
    forall l l' (a : A),
      count_occ A_eq_dec (l ++ l') a = count_occ A_eq_dec l a + count_occ A_eq_dec l' a.
  Proof using.
    intros.
    induction l; simpl in *; auto.
    break_if; auto.
    find_rewrite.
    auto.
  Qed.

  Lemma Permutation_map_fst :
    forall l l' : list (A * B),
      Permutation l l' ->
      Permutation (map fst l) (map fst l').
  Proof using.
    induction l; intros; simpl in *.
    - find_apply_lem_hyp Permutation_nil.
      find_rewrite.
      auto.
    - assert (In a l').
        apply Permutation_in with (l := a :: l); auto with datatypes.
      find_apply_lem_hyp in_split.
      break_exists.
      find_rewrite.
      find_apply_lem_hyp Permutation_cons_app_inv.
      find_apply_hyp_hyp.
      find_rewrite.
      rewrite map_app.
      simpl.
      apply Permutation_cons_app.
      rewrite <- map_app.
      auto.
     Qed.

  Lemma snd_eq_not_in_map :
    forall (l : list (A * B)) n m,
      (forall nm, In nm l -> snd nm = m) ->
      ~ In (n, m) l ->
      ~ In n (map fst l).
  Proof using.
    intros.
    induction l; simpl in *; auto.
    intro.
    break_or_hyp.
    - match goal with H: ~ _ |- _ => contradict H end.
      left.
      destruct a.
      match goal with H: forall _ : A * B, _ |- _ => specialize (H (a, b)) end.
      simpl in *.
      intuition eauto; repeat find_rewrite; auto.
    - match goal with H: In _ _ |- _ => contradict H end.
      apply IHl; eauto.
  Qed.

  Lemma NoDup_map_snd_fst :
    forall nms : list (A * B),
      NoDup nms ->
      (forall nm nm', In nm nms -> In nm' nms -> snd nm = snd nm') ->
      NoDup (map fst nms).
  Proof using.
    intros.
    induction nms; simpl in *.
    - apply NoDup_nil.
    - invc_NoDup.
      apply NoDup_cons.
      * assert (forall nm, In nm nms -> snd nm = snd a).
          intuition eauto.
        destruct a.
        apply snd_eq_not_in_map with (m := b); auto.
      * apply IHnms; auto.
  Qed.

  Lemma in_fold_left_by_cons_in :
    forall (l : list B) (g : B -> A) x acc,
      In x (fold_left (fun a b => g b :: a) l acc) ->
      In x acc \/ exists y, In y l /\ x = g y.
  Proof using A_eq_dec.
    intros until l.
    induction l.
    - auto.
    - simpl; intros.
      destruct (A_eq_dec x (g a)); subst.
      + right; exists a; tauto.
      + find_apply_lem_hyp IHl.
        break_or_hyp; [left|right].
        * find_apply_lem_hyp In_cons_neq; tauto.
        * break_exists_exists; tauto.
  Qed.

  Lemma fold_left_for_each_not_in :
    forall (f : A -> B -> A) (g : A -> B -> C),
      (forall a b b',
          b <> b' ->
          g (f a b') b = g a b) ->
      forall l a b,
        ~ In b l ->
        g (fold_left f l a) b = g a b.
  Proof using A B C.
    induction l as [| b' l']; simpl in *; auto.
    - intros. intuition.
      rewrite IHl'; auto.
  Qed.

  Lemma fold_left_for_each_in :
    forall (f : A -> B -> A) (g : A -> B -> C) (B_eq_dec : forall x y : B, {x = y} + {x <> y}),
      (forall a b b',
          b <> b' ->
          g (f a b') b = g a b) ->
      forall l a b,
        In b l ->
        exists a',
          g (fold_left f l a) b = g (f a' b) b.
  Proof using A B C.
    induction l as [|b' l']; simpl in *; intuition; subst.
    destruct (in_dec B_eq_dec b l'); intuition.
    find_eapply_lem_hyp fold_left_for_each_not_in; eauto.
  Qed.

  Lemma hd_error_tl_exists :
    forall (l : list A) x,
      hd_error l = Some x ->
      exists tl,
        l = x :: tl.
  Proof.
    intros.
    destruct l; simpl in *.
    - congruence.
    - eexists; solve_by_inversion.
  Qed.

  Lemma hd_error_None :
    forall (l : list A),
      hd_error l = None ->
      l = [].
  Proof.
    now destruct l.
  Qed.

End list_util.

(* We have to repeat these Hint Resolve commands because hints don't survive
   past the ends of sections *)
Hint Resolve app_cons_in : struct_util.
Hint Resolve app_cons_in_rest : struct_util.
Hint Resolve in_rest_app_cons : struct_util.


Inductive SC(T:Type): Type :=
| Value : T -> SC T
| Unknown : SC T.

Inductive Stack(T:Type): Type :=
| Empty : Stack T
| Push:  T -> Stack T -> Stack T.
(* For better readability I renamed Add constructor in Ex1.v to Push *)

(*Stack is parameterized over the stack element.*)

Definition pop(T:Type) (s:Stack T):(Stack T):=
match s with
| Empty => Empty T
| Push _ xs => xs
end.

Definition top (T:Type)(s:Stack T) : SC T :=
match s with
| Empty => Unknown T
| Push s' _ => Value T s'
end.

Definition isEmpty (T:Type) (s:Stack T) : bool :=
match s with
|Empty => true
|Push _ _ => false
end.

Theorem push_post_condition : forall t x xs, (top t (Push t x xs))= Value t x.
Proof.
intros.
simpl.
reflexivity.
Qed.

Theorem push_invariant : forall t x xs, pop t (Push t x xs) = xs.
Proof.
intros.
simpl.
reflexivity.
Qed.

Theorem pop_post_condition : forall t x xs, pop t (Push t x xs) = xs.
Proof.
intros.
simpl.
reflexivity.
Qed.

Theorem top_post_condition : forall t x xs, (top t (Push t x xs)) = Value t x.
Proof.
 intros.
 simpl.
 reflexivity.
Qed.

Theorem isEmpty_post_condition: forall t, isEmpty t (Empty t)=true.
Proof.
intros.
reflexivity.
Qed.

(* For arbitrary x and y, on an empty stack, we are pushing twice and popping
   twice on the same stack. So, it is safe and doesnot crash. The final state
   of the stack is empty.
*)
Theorem proof1: forall t x y, (pop t (pop t ( Push t y (Push t x (Empty t)))))= (Empty t).
Proof.
intros.
simpl.
reflexivity.
Qed.

(* For arbitrary x and y, on an empty stack, we are pushing once and popping twice.
   Since we wrote the contuctor for "empty" in pop definition, the below theorem doesnot crash.
   Otherwise (pop (pop (push x empty)) is unsafe.
*)

Theorem proof2: forall t x, (pop t (pop t (Push t x (Empty t))))= (Empty t).
Proof.
intros.
simpl.
reflexivity.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Category.Composable_Chain.
Require Import Functor.Functor.

(*

(** The image of a functor is not simply the image of its object and arrow maps as
those may not form a category. Consider the following example.

  category C:
#

             f
       x1 ——————–> y1

       x2 ——————–> y2
             g

#
   category D:
#

             h1        h2
       x ——————–> y ————————> z

       u ——————–> v
            m

#
    functor F where:
#

       F _o x1 = x
       F _o y1 = y
       F _o x2 = y
       F _o y2 = z

       F _a f = h1
       F _a g = h2

#

Here we have not drawn identity arrows and compositions of arrows in categories and
their mappings by the functor as these are trivial details.

In this case, the simple image of arrow map of F has only h1 and h2 but not their
composition and is hence not a category.

We define the image of a functor to be a sum category of the codomain category with
objects the image of object map of the functor and as morphisms image of the arrow
map of the functor closed under composition. That is, each morphism in the image
category is a morphism that corresponds to a composable chain of morohisms in the
image of the arrow map of the functor.

*)
Section Functor_Image.
  Context {C D : Category}
          (F : (C –≻ D)%functor).

  Local Open Scope morphism_scope.

  Program Definition Functor_Image :=
    SubCategory D
                (fun a => ∃ x, (F _o x)%object = a)
                (
                  fun a b f =>
                    ∃ (ch : Composable_Chain D a b),
                      (Compose_of ch) = f
                      ∧
                      Forall_Links ch (
                                     fun x y g =>
                                     ∃ (c d : Obj) (h : c –≻ d)
                                       (Fca : (F _o c)%object = x) (Fdb : (F _o d)%object = y),
                                       match Fca in (_ = Z) return Z –≻ _ with
                                         idpath =>
                                         match Fdb in (_ = Y) return _ –≻ Y with
                                           idpath => (F _a h)%morphism
                                         end
                                       end = g)
                )
                _ _.

  Ltac destr_exists :=
    progress
    (repeat
       match goal with
         [H : ∃ x, _ |- _] =>
         let x := fresh "x" in
         let Hx := fresh "H" x in
         destruct H as [x Hx]
       end).

  Next Obligation. (* Hom_Cri_id *)
  Proof.
    destr_exists.
    ElimEq.
    exists (Single (F _a id)); simpl; split; auto.
    do 3 eexists; do 2 exists eq_refl; reflexivity.
  Qed.

  Next Obligation. (* Hom_Cri_compose *)
  Proof.
    destr_exists.
    intuition.
    ElimEq.
    match goal with
        [ch1 : Composable_Chain _ ?a ?b, ch2 : Composable_Chain _ ?b ?c|- _] =>
        exists (Chain_Compose ch1 ch2); split
    end.
    rewrite <- Compose_of_Chain_Compose; trivial.
    apply Forall_Links_Chain_Compose; auto.
  Qed.

End Functor_Image.
*)