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).


(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)

Require Import Coq.Lists.List.
Require Import Coq.Strings.Ascii.
Require Import Turing.Lang.
Require Import Turing.Regular.
Require Import Turing.Regex.
Require Import Turing.Util.
Require Import Omega.
Import ListNotations.
Import RegexNotations.
Import Lang.LangNotations.
Open Scope char_scope.
Open Scope lang_scope.
Open Scope regex_scope.

(* ---------------------- END OF PREAMBLE ------------------ *)

(**

  The objective of this homework assignment is to prove that
  language L5 is not regular, where L5 is a^n b^m where n < m.

  WARNING: DO NOT CHANGE DEFINITION L5, otherwise you will get 0 points for
  this assignment.

*)
Definition L5 : language := fun w => exists n m, w = pow1 "a" n ++ (pow1 "b" ((S m) + n)).

Lemma pow1_app_cons_inv_eq_1:
forall {T} (a b:T),
a <> b ->
forall x y v w,
pow1 a x ++ b :: y = pow1 a v ++ b :: w ->
x = v.
Proof.
intros ? a b.
induction x; intros. {
    simpl in *.
    destruct v; auto.
    simpl in *.
    inversion H0.
    subst.
    contradiction.
}
simpl in *.
destruct v; simpl in *. {
    inversion H0.
    subst.
    contradiction.
}
inversion H0; subst; clear H0.
apply IHx in H2.
subst; reflexivity.
Qed.

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

(**

Easy. Show that the word that clogs is in L5.

 *)
Theorem l5_not_regular_1:
  forall p, In (pow1 "a" p ++ pow1 "b" (S p)) L5.
Proof.
intros.
Search (In _ (Clogs _ _)).
  unfold In.
  unfold  L5.
  exists p, 0.
  auto.
Qed.

(**

Easy. Show that the clogged word has at least p-characters.

 *)
Theorem l5_not_regular_2:
  forall p, length (pow1 "a" p ++ pow1 "b" (S p)) >= p.
Proof.
intros.
rewrite app_length.
rewrite pow1_length.
omega.
Qed.

(**

Difficult. The proof for Regular.Examples.l4_not_regular_alt is similar to what you should be doing. The only theorem you need to use is Regular.Examples.xyz_rw_ex.

 *)
Theorem l5_not_regular_4_1:
  forall p x y z n m, p >= 1 -> y <> [] -> pow1 "a" p ++ "b" :: pow1 "b" p = x ++ y ++ z -> length (x ++ y) <= p -> x ++ (y ++ y) ++ z = pow1 "a" n ++ pow1 "b" (S m + n) -> exists nx ny o,
    ny <> 0 /\
    pow1 "a" nx ++
    (pow1 "a" ny ++ pow1 "a" ny) ++
    pow1 "a" o ++
    "b" :: pow1 "b" (length (pow1 "a" nx ++ pow1 "a" ny) + o)
    =
    pow1 "a" n ++ pow1 "b" (S m + n).
Proof.
intros.
  apply Examples.xyz_rw_ex in H1.
  - destruct H1; destruct H1; destruct H4.
    destruct H5; destruct H6.
    subst.
    rewrite H5,H6 in H2, H3.
    exists (length x); exists (length y); exists x0.
    split.
    -- unfold not in *.
       rewrite length_zero_iff_nil.
       apply H0.
    -- apply H3.
  - apply H2.
Qed.

(**

Easy. Use rewriting rules (eg, app_assoc).

 *)
Theorem l5_not_regular_4_2:
  forall nx ny n m o, pow1 "a" nx ++ (pow1 "a" ny ++ pow1 "a" ny) ++ pow1 "a" o ++ "b" :: pow1 "b" (length (pow1 "a" nx ++ pow1 "a" ny) + o) = pow1 "a" n ++ pow1 "b" (S m + n) -> pow1 "a" (nx + ny + ny + o) ++ "b" :: pow1 "b" (nx + ny + o) = pow1 "a" n ++ "b" :: pow1 "b" (m + n).
Proof.
intros.
repeat rewrite app_assoc in H.
repeat rewrite pow1_plus in H.
repeat rewrite pow1_length in H.
simpl in *.
apply H.
Qed.

(**

Hard. This is the final step of the proof. You want to start by showing that the powers of "a" are equal (for which you'll need pow1_app_cons_inv_eq_1). After that you want to remove the left-hand side of the equality with app_inv_head. Your final step should be to conclude that both powers must be equal. Once you have an equality over naturals, then use `omega` to conclude.

 *)
Theorem l5_not_regular_4_3:
  forall nx ny o n m, ny <> 0 -> pow1 "a" (nx + ny + ny + o) ++ "b" :: pow1 "b" (nx + ny + o) <>
    pow1 "a" n ++ "b" :: pow1 "b" (m + n).
Proof.
  intros; intros N.
  inversion N.
  apply pow1_app_cons_inv_eq_1 in N.
  - rewrite N in H1.
    apply app_inv_head in H1.
    inversion H1.
    apply pow1_inv_eq in H2.
    inversion H2.
    omega.
  - intros M.
    inversion M.
Qed.

(**

Easy. Use the lemmas that start with l5_not_regular_4_

 *)
Theorem l5_not_regular_4:
  forall p m n x y z, p >= 1 -> y <> [] -> pow1 "a" p ++ "b" :: pow1 "b" p = x ++ y ++ z -> length (x ++ y) <= p -> x ++ (y ++ y) ++ z <> pow1 "a" n ++ pow1 "b" (S m + n).
Proof.
intros; intros N.
apply l5_not_regular_4_1 with (p:= p) in N.
- destruct  N as (x0, (x1, (x2, (H3, H4)))).
apply l5_not_regular_4_2 in H4.
apply l5_not_regular_4_3 in H4.
{ apply H4. }
{ apply H3. }
- omega.
- apply H0.
- apply H1.
- apply H2.
Qed.

(**

Easy. Show that a^p b^(p+1) clogs L5. Conclude the proof using Lemma l5_not_regular_4 to conclude.

 *)
Theorem l5_not_regular_3:
  forall p, p >= 1 -> In (pow1 "a" p ++ pow1 "b" (S p)) (Clogs L5 p).
Proof.
  intros.
  simpl.
  Search (In _ (Clogs _ _)).
  unfold In, Clogs.
  intros.
  exists 2.
  intros N.
  unfold  L5 in N.
  unfold In in N.
  destruct N as (w1, (w2, Ha)).
  simpl in *.
  rewrite app_nil_r in Ha.
  apply l5_not_regular_4 with (p:=p) in Ha.
  - assumption.
  - auto.
  -auto.
  -auto.
  -auto.
Qed.

(**

Easy. Show that L5 is not regular.

 *)
Theorem l5_not_regular:
  ~ Regular L5.
Proof.
  unfold L5.
  apply not_regular.
  intros.
  apply clogged_def with (w:=(pow1 "a" p ++ pow1 "b" (1 + p)) % list).
  - apply l5_not_regular_1.
  - apply l5_not_regular_2.
  - apply l5_not_regular_3.
    + apply H.
Qed.


(*|
###############################################################################################
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.


(* in Idris könnte es so aussehen *)

Variables A B: Prop.

Inductive finite : nat -> Type :=
  new : forall n, finite (S n)
| inj : forall n, finite n -> finite (S n).

(* Isomorphismus *)
Inductive Iso : Type -> Type -> Type :=
  Mk_Iso : A B :Type -> (f: A -> B) -> (g: B -> A)
  -> (prod a:A, g(f a) = a)
  -> (prod b:B, f(g b) = b)
  -> Iso A.

Inductive Is_Finite : Type -> Type :=
  Mk_Finite : A : Type -> card : nat
  -> Iso (A, finite card) -> Is_Finite A.

(* endliche Teilmenge *)
Inductive Finite_Sub: Type -> Type :=
  Mk_Finite_Sub : A : Type -> (card : nat)
  -> (f: A -> finite n) -> (g: (finite n) -> A)
  -> (prod x: finite n (f(g x)=x))
  -> Finite_Sub.