Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.NaturalNumbers.

Definition graph: UU := total2 (fun S: (dirprod hSet hSet) => dirprod ((pr2 S) -> (pr1 S)) ((pr2 S) -> (pr1 S))).

Definition make_graph (V E : hSet) (s t : E -> V) : graph := tpair (fun S : (dirprod hSet hSet) => dirprod ((pr2 S) -> (pr1 S)) ((pr2 S) -> (pr1 S))) (make_dirprod V E) (make_dirprod s t).

Definition vertices_of (g : graph) := dirprod_pr1 (pr1 g).
Definition edges_of (g : graph) := dirprod_pr2 (pr1 g).
Definition source_of (g : graph) := dirprod_pr1 (pr2 g).
Definition target_of (g : graph) := dirprod_pr2 (pr2 g).

Definition path_of_length (g : graph) : nat -> (vertices_of g) -> (vertices_of g) -> UU := nat_rect _ (fun (v1 v2 : (vertices_of g)) => paths v1 v2) (fun (m : nat) (pths_of_m : _) => (fun (v1 v2 : (vertices_of g)) => (total2 (fun u : (vertices_of g) => dirprod (pths_of_m v1 u) (total2 (fun (e : (edges_of g)) => dirprod (paths u ((source_of g) e)) (paths v2 ((target_of g) e)))))))).

Definition cycle (g : graph) : UU := (total2 (fun (v : vertices_of g) => total2 (fun (n : nat) => dirprod (n != 0) (path_of_length g n v v)))).

Definition acyclic (g : graph) : hProp := make_hProp (neg (ishinh (cycle g))) (isapropneg _).

Definition empty_isaset: (isaset empty) := empty_rect (fun (x: empty) => (∏ x': empty, isaprop (paths x x'))).
Definition emptyset: hSet := make_hSet empty empty_isaset.

Definition underlined : nat -> hSet := nat_rect _ emptyset (fun (_ : _) (prev : _) => setcoprod prev unitset).

Definition I_or_O (V : hSet) (f : V -> nat) := total2_hSet (fun v : V => underlined (f v)).

Definition tuple (m n : nat) : UU := total2 (fun V : hSet => total2 (fun in_out : dirprod (V -> nat) (V -> nat) => weq (setcoprod (underlined m) (I_or_O V (dirprod_pr2 in_out))) (setcoprod (underlined n) (I_or_O V (dirprod_pr1 in_out))))).

Definition vertices {m n : nat} (t : tuple m n) := pr1 t.
Definition in_func {m n : nat} (t : tuple m n) := dirprod_pr1 (pr1 (pr2 t)).
Definition out_func {m n : nat} (t : tuple m n) := dirprod_pr2 (pr1 (pr2 t)).
Definition i_func {m n : nat} (t : tuple m n) := pr1 (pr2 (pr2 t)).
Definition i_property {m n : nat} (t : tuple m n) := pr2 (pr2 (pr2 t)).

Definition internal_flow_graph_of {m n : nat} (t : tuple m n) : graph := make_graph (vertices t) (total2_hSet (fun uivj : dirprod_hSet (I_or_O (vertices t) (out_func t)) (I_or_O (vertices t) (in_func t)) => hProp_to_hSet (eqset ((i_func t) (inr (dirprod_pr1 uivj))) (inr (dirprod_pr2 uivj))))) (fun uivj : _ => pr1 (dirprod_pr2 (pr1 uivj))) (fun uivj : _ => pr1 (dirprod_pr1 (pr1 uivj))).

Definition port_graph (m n : nat) : UU := total2 (fun t : tuple m n => acyclic (internal_flow_graph_of t)).

Definition topological_order (g : graph) : UU := total2 (fun enumeration : (vertices_of g) -> nat => forall e : edges_of g, natlth (enumeration ((source_of g) e)) (enumeration ((target_of g) e))).

Lemma trivial_case (g : graph) (top_order : topological_order g) (v1 : vertices_of g) : forall u : vertices_of g, ((paths 0 0) -> empty) -> (path_of_length g 0 v1 u) -> natlth ((pr1 top_order) v1) ((pr1 top_order) u).
Proof.
  intros u prop.
  apply (fromempty (prop (idpath 0))).
Qed.

Lemma trivial_case_for_next_step (g : graph) (top_order : topological_order g) (v1 v : vertices_of g) (n : nat) (path : path_of_length g (S (S n)) v1 v) : natlth ((pr1 top_order) (pr1 path)) ((pr1 top_order) v).
Proof.
  rewrite (dirprod_pr2 (pr2 (dirprod_pr2 (pr2 path)))).
  apply (paths_rect _ (source_of g (pr1 (dirprod_pr2 (pr2 path)))) (fun (ver : vertices_of g) (_ : _) => natlth ((pr1 top_order) ver) ((pr1 top_order) (target_of g (pr1 (dirprod_pr2 (pr2 path)))))) ((pr2 top_order) (pr1 (dirprod_pr2 (pr2 path)))) (pr1 path) (pathsinv0 (dirprod_pr1 (pr2 (dirprod_pr2 (pr2 path)))))).
Qed.

Lemma next_step (g : graph) (top_order : topological_order g) (v1 : vertices_of g) (n : nat) (prev_step : forall u : vertices_of g, ((paths n 0) -> empty) -> (path_of_length g n v1 u) -> natlth ((pr1 top_order) v1) ((pr1 top_order) u)) : forall v : vertices_of g, ((paths (S n) 0) -> empty) -> (path_of_length g (S n) v1 v) -> natlth ((pr1 top_order) v1) ((pr1 top_order) v).
Proof.
  intros v prop path.
  unfold path_of_length in path.
  induction n.
  unfold nat_rect in path.
  rewrite (dirprod_pr1 (pr2 path)).
  unfold topological_order in top_order.
  rewrite (dirprod_pr2 (pr2 (dirprod_pr2 (pr2 path)))).
  apply (paths_rect _ (source_of g (pr1 (dirprod_pr2 (pr2 path)))) (fun (ver : vertices_of g) (_ : _) => natlth ((pr1 top_order) ver) ((pr1 top_order) (target_of g (pr1 (dirprod_pr2 (pr2 path)))))) ((pr2 top_order) (pr1 (dirprod_pr2 (pr2 path)))) (pr1 path) (pathsinv0 (dirprod_pr1 (pr2 (dirprod_pr2 (pr2 path)))))).
  apply (natlehlthtrans _ _ _ (natlthtoleh _ _ (prev_step (pr1 path) (negpathssx0 n) (dirprod_pr1 (pr2 path)))) (trivial_case_for_next_step g top_order v1 v n path)).
Qed.

Lemma extended_topological_order (g : graph) : (topological_order g) -> total2 (fun enumeration : (vertices_of g) -> nat => forall (v1 v2 : vertices_of g) (n : total2 (fun m : nat => (paths m 0) -> empty)), (path_of_length g (pr1 n) v1 v2) -> natlth (enumeration v1) (enumeration v2)).
Proof.
  intros top_order.
  unfold topological_order in top_order.
  exists (pr1 top_order).
  intros v1 v2 n.
  intros path.
  unfold path_of_length in path.
  induction n as [n prop].
  apply (nat_rect (fun (n : nat)  => forall u : vertices_of g, ((paths n 0) -> empty) -> (path_of_length g n v1 u) -> natlth ((pr1 top_order) v1) ((pr1 top_order) u)) (trivial_case g top_order v1) (next_step g top_order v1) n v2 prop path).
Qed.

Theorem topological_order_acyclic (g : graph) : (topological_order g) -> (acyclic g).
Proof.
  unfold acyclic.
  intros top_order cycle.
  unfold topological_order in top_order.
  (**unfold cycle in cycle.**)
  Print ishinh_UU.
  apply (cycle hfalse (fun cycle' => (isirreflnatlth _ ((pr2 (extended_topological_order g top_order)) (pr1 cycle') (pr1 cycle') (tpair (fun n : nat => n != 0) (pr1 (pr2 cycle')) (dirprod_pr1 (pr2 (pr2 cycle')))) (dirprod_pr2 (pr2 (pr2 cycle'))))))).
Qed.

Definition in_example : boolset -> nat := fun (b : boolset) => 1.
Definition out_example : boolset -> nat := fun (b : boolset) => 1.
Definition in_out_example := make_dirprod in_example out_example.

Definition i_func_example : (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr2 in_out_example))) -> (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr1 in_out_example))).
  intros out.
  induction out.
  unfold underlined in a.
  unfold nat_rect in a.
  induction a.
  induction a.
  apply (fromempty (a)).
  unfold I_or_O.
  unfold underlined.
  unfold dirprod_pr1.
  unfold in_out_example.
  unfold make_dirprod.
  unfold pr1.
  unfold in_example.
  unfold nat_rect.
  apply (inr (tpair _ true (inr tt))).
  apply (inr (tpair _ false (inr tt))).
  unfold in_out_example in b.
  unfold make_dirprod in b.
  unfold dirprod_pr2 in b.
  unfold pr2 in b.
  unfold I_or_O in b.
  induction b as [v i].
  induction v.
  unfold out_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty (a)).
  apply (inl (inl (inr tt))).
  unfold out_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty (a)).
  apply (inl (inr tt)).
Defined.

Definition i_func_example_reverse : (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr1 in_out_example))) -> (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr2 in_out_example))).
  intros in_.
  induction in_.
  unfold underlined in a.
  unfold nat_rect in a.
  induction a.
  induction a.
  apply (fromempty (a)).
  unfold I_or_O.
  unfold underlined.
  unfold dirprod_pr2.
  unfold in_out_example.
  unfold make_dirprod.
  unfold pr2.
  unfold out_example.
  unfold nat_rect.
  apply (inr (tpair _ true (inr tt))).
  apply (inr (tpair _ false (inr tt))).
  unfold in_out_example in b.
  unfold make_dirprod in b.
  unfold dirprod_pr1 in b.
  unfold pr1 in b.
  unfold I_or_O in b.
  induction b as [v i].
  induction v.
  unfold in_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty (a)).
  apply (inl (inl (inr tt))).
  unfold in_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty (a)).
  apply (inl (inr tt)).
Defined.

Theorem is_iso_i_example_1 : ∏ out_ : (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr2 in_out_example))), i_func_example_reverse (i_func_example out_) = out_.
  intros out_.
  induction out_.
  unfold underlined in a.
  unfold nat_rect in a.
  induction a.
  induction a.
  apply (fromempty a).
  unfold i_func_example.
  unfold coprod_rect.
  unfold i_func_example_reverse.
  unfold coprod_rect.
  unfold bool_rect.
  apply (maponpaths).
  apply (maponpaths).
  apply (maponpaths).
  apply isProofIrrelevantUnit.
  unfold i_func_example.
  unfold coprod_rect.
  unfold i_func_example_reverse.
  unfold coprod_rect.
  unfold bool_rect.
  apply maponpaths.
  apply maponpaths.
  apply isProofIrrelevantUnit.
  unfold in_out_example in b.
  unfold make_dirprod in b.
  unfold dirprod_pr2 in b.
  unfold pr2 in b.
  unfold I_or_O in b.
  induction b as [v i].
  induction v.
  unfold out_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty a).
  unfold i_func_example.
  unfold coprod_rect.
  unfold bool_rect.
  unfold i_func_example_reverse.
  unfold coprod_rect.
  apply maponpaths.
  apply maponpaths.
  apply maponpaths.
  apply isProofIrrelevantUnit.
  unfold out_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty a).
  unfold i_func_example.
  unfold coprod_rect.
  unfold bool_rect.
  unfold i_func_example_reverse.
  unfold coprod_rect.
  apply maponpaths.
  apply maponpaths.
  apply maponpaths.
  apply isProofIrrelevantUnit.
Qed.

Theorem is_iso_i_example_2 : ∏ in_ : (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr1 in_out_example))), i_func_example (i_func_example_reverse in_) = in_.
  intros in_.
  induction in_.
  unfold underlined in a.
  unfold nat_rect in a.
  induction a.
  induction a.
  apply (fromempty a).
  unfold i_func_example.
  unfold coprod_rect.
  unfold i_func_example_reverse.
  unfold coprod_rect.
  unfold bool_rect.
  apply (maponpaths).
  apply (maponpaths).
  apply (maponpaths).
  apply isProofIrrelevantUnit.
  unfold i_func_example.
  unfold coprod_rect.
  unfold i_func_example_reverse.
  unfold coprod_rect.
  unfold bool_rect.
  apply maponpaths.
  apply maponpaths.
  apply isProofIrrelevantUnit.
  unfold in_out_example in b.
  unfold make_dirprod in b.
  unfold dirprod_pr2 in b.
  unfold pr2 in b.
  unfold I_or_O in b.
  induction b as [v i].
  induction v.
  unfold out_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty a).
  unfold i_func_example.
  unfold coprod_rect.
  unfold bool_rect.
  unfold i_func_example_reverse.
  unfold coprod_rect.
  apply maponpaths.
  apply maponpaths.
  apply maponpaths.
  apply isProofIrrelevantUnit.
  unfold out_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty a).
  unfold i_func_example.
  unfold coprod_rect.
  unfold bool_rect.
  unfold i_func_example_reverse.
  unfold coprod_rect.
  apply maponpaths.
  apply maponpaths.
  apply maponpaths.
  apply isProofIrrelevantUnit.
Qed.

Definition i_example : weq (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr2 in_out_example))) (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr1 in_out_example))).
  unfold weq.
  exists i_func_example.
  apply (isweq_iso _ i_func_example_reverse is_iso_i_example_1 is_iso_i_example_2).
Defined.

Definition tuple_example : tuple 2 2.
  unfold tuple.
  exists boolset.
  exists in_out_example.
  apply i_example.
Defined.

Lemma setcoprod_injective: ∏ (A B: hSet), ∏ (a: A), ∏ (b: B), (paths (inl a) (inr b)) -> empty.
  intros.
  exact (transportf (coprod_rect (fun (_: setcoprod A B) => Type)  (fun _ => unit) (fun _ => empty)) X tt).
Qed.

Definition acyclicity_tuple_example_1 : acyclic (internal_flow_graph_of tuple_example).
apply topological_order_acyclic.
  unfold topological_order.
  exists (bool_rect _ 1 2).
  intros e.
  unfold internal_flow_graph_of in e.
  unfold tuple_example in e.
  unfold edges_of in e.
  unfold make_graph in e.
  unfold dirprod_pr2 in e.
  unfold make_dirprod in e.
  unfold pr2 in e.
  unfold pr1 in e.
  induction e as [uivj prop].
  unfold vertices in uivj.
  unfold pr1 in uivj.
  unfold out_func in uivj.
  unfold in_func in uivj.
  unfold dirprod_pr2 in uivj.
  unfold dirprod_pr1 in uivj.
  unfold pr1 in uivj.
  unfold pr2 in uivj.
  unfold in_out_example in uivj.
  unfold make_dirprod in uivj.
  unfold I_or_O in uivj.
  induction uivj as [ui vj].
  induction ui as [u i].
  induction vj as [v j].
  unfold i_func in prop.
  unfold in_out_example in prop.
  unfold make_dirprod in prop.
  unfold dirprod_pr1 in prop.
  unfold pr1 in prop.
  unfold pr2 in prop.
  induction u.
  unfold out_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty a).
  induction v.
  unfold out_example in j.
  unfold underlined in j.
  unfold nat_rect in j.
  induction j.
  apply (fromempty a).
  apply (fromempty (setcoprod_injective _ _ _ _ prop)).
  unfold in_example in j.
  unfold underlined in j.
  unfold nat_rect in j.
  induction j.
  apply (fromempty a).
  apply (fromempty (setcoprod_injective _ _ _ _ prop)).
  unfold out_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty a).
  induction v.
  unfold in_example in j.
  unfold underlined in j.
  unfold nat_rect in j.
  induction j.
  apply (fromempty a).
  apply (fromempty (setcoprod_injective _ _ _ _ prop)).
  unfold in_example in j.
  unfold underlined in j.
  unfold nat_rect in j.
  induction j.
  apply (fromempty a).
  apply (fromempty (setcoprod_injective _ _ _ _ prop)).
Defined.

Definition acyclicity_tuple_example_2 : acyclic (internal_flow_graph_of tuple_example).
apply topological_order_acyclic.
  unfold topological_order.
  exists (bool_rect _ 2 1).
  intros e.
  unfold internal_flow_graph_of in e.
  unfold tuple_example in e.
  unfold edges_of in e.
  unfold make_graph in e.
  unfold dirprod_pr2 in e.
  unfold make_dirprod in e.
  unfold pr2 in e.
  unfold pr1 in e.
  induction e as [uivj prop].
  unfold vertices in uivj.
  unfold pr1 in uivj.
  unfold out_func in uivj.
  unfold in_func in uivj.
  unfold dirprod_pr2 in uivj.
  unfold dirprod_pr1 in uivj.
  unfold pr1 in uivj.
  unfold pr2 in uivj.
  unfold in_out_example in uivj.
  unfold make_dirprod in uivj.
  unfold I_or_O in uivj.
  induction uivj as [ui vj].
  induction ui as [u i].
  induction vj as [v j].
  unfold i_func in prop.
  unfold in_out_example in prop.
  unfold make_dirprod in prop.
  unfold dirprod_pr1 in prop.
  unfold pr1 in prop.
  unfold pr2 in prop.
  induction u.
  unfold out_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty a).
  induction v.
  unfold out_example in j.
  unfold underlined in j.
  unfold nat_rect in j.
  induction j.
  apply (fromempty a).
  apply (fromempty (setcoprod_injective _ _ _ _ prop)).
  unfold in_example in j.
  unfold underlined in j.
  unfold nat_rect in j.
  induction j.
  apply (fromempty a).
  apply (fromempty (setcoprod_injective _ _ _ _ prop)).
  unfold out_example in i.
  unfold underlined in i.
  unfold nat_rect in i.
  induction i.
  apply (fromempty a).
  induction v.
  unfold in_example in j.
  unfold underlined in j.
  unfold nat_rect in j.
  induction j.
  apply (fromempty a).
  apply (fromempty (setcoprod_injective _ _ _ _ prop)).
  unfold in_example in j.
  unfold underlined in j.
  unfold nat_rect in j.
  induction j.
  apply (fromempty a).
  apply (fromempty (setcoprod_injective _ _ _ _ prop)).
Defined.

Definition example_of_port_graph : port_graph 2 2.
  unfold port_graph.
  exists tuple_example.
  apply acyclicity_tuple_example_1.
Defined.

Definition example2_of_port_graph : port_graph 2 2.
  unfold port_graph.
  exists tuple_example.
  apply acyclicity_tuple_example_2.
Defined.

Lemma do_acyclisity_proofs_equal : paths acyclicity_tuple_example_1 acyclicity_tuple_example_2.
  apply (propproperty (acyclic (internal_flow_graph_of tuple_example))).
Qed.

Theorem do_examples_equal : paths example_of_port_graph example2_of_port_graph.
  unfold example_of_port_graph.
  unfold example2_of_port_graph.
  apply (maponpaths _ do_acyclisity_proofs_equal).
Qed.

Print example_of_port_graph.

Search natgth.

  (**apply (inr (tpair (fun vi : (boolset × natset)%set => dirprod_pr2 vi > 0 × dirprod_pr2 vi ≤ dirprod_pr1 in_out_example (dirprod_pr1 vi)) (make_dirprod true 1) (make_dirprod (natgthsnn 0) (isreflnatleh 1)))).
  apply (inr (tpair (fun vi : (boolset × natset)%set => dirprod_pr2 vi > 0 × dirprod_pr2 vi ≤ dirprod_pr1 in_out_example (dirprod_pr1 vi)) (make_dirprod false 1) (make_dirprod (natgthsnn 0) (isreflnatleh 1)))).
  induction b as [vi prop].
  induction vi as [v i].
  induction v.
  unfold in_out_example in prop.
  unfold dirprod_pr2 in prop.
  unfold pr2 in prop.
  unfold make_dirprod in prop.
  unfold out_example in prop.
  induction i.
  apply (fromempty (negnatgth0n 0 (pr1 prop))).
  induction i.
  unfold underlined.
  unfold nat_rect.
  apply (inl (inl (inr tt))).**)

(**Definition i_func_example :  (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr2 in_out_example))) -> (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr1 in_out_example))).
  intros out.
  induction out.
  induction a as [n prop].
  induction n.
  unfold hProp_to_hSet in prop.
  apply (fromempty (negnatgth0n 0 (pr1 prop))).
  induction n.
  unfold I_or_O.
  apply (inr (tpair (fun vi : (boolset × natset)%set => dirprod_pr2 vi > 0 × dirprod_pr2 vi ≤ dirprod_pr1 in_out_example (dirprod_pr1 vi)) (make_dirprod false 1) (make_dirprod (natgthsnn 0) (isreflnatleh 1)))).
  induction n.
  apply (inr (tpair (fun vi : (boolset × natset)%set => dirprod_pr2 vi > 0 × dirprod_pr2 vi ≤ dirprod_pr1 in_out_example (dirprod_pr1 vi)) (make_dirprod true 1) (make_dirprod (natgthsnn 0) (isreflnatleh 1)))).
  apply (fromempty (negnatlehsnn 0 ((natlehandplusrinv 1 0 2) (pr2 prop)))).
  induction b as [vi prop].
  induction vi as [v i].
  induction v.
  unfold in_out_example in prop.
  unfold dirprod_pr2 in prop.
  unfold pr2 in prop.
  unfold out_example in prop.
  unfold dirprod_pr1 in prop.
  unfold pr1 in prop.
  unfold make_dirprod in prop.
  induction i.
  apply (fromempty (negnatgth0n 0 (pr1 prop))).
  induction i.
  unfold underlined.
  apply (inl (tpair (fun n : nat => dirprod (natgth n 0) (natleh n 2)) 2 (make_dirprod (natgthsn0 0) (natlehnsn 1)))).
  apply (fromempty (negnatlehsnn 0 ((natlehandplusrinv 1 0 1) (pr2 prop)))).
  unfold in_out_example in prop.
  unfold dirprod_pr2 in prop.
  unfold pr2 in prop.
  unfold out_example in prop.
  unfold dirprod_pr1 in prop.
  unfold pr1 in prop.
  unfold make_dirprod in prop.
  induction i.
  apply (fromempty (negnatgth0n 0 (pr1 prop))).
  induction i.
  unfold underlined.
  apply (inl (tpair (fun n : nat => dirprod (natgth n 0) (natleh n 2)) 1 (make_dirprod (natgthsn0 0) (natlehnsn 1)))).
  apply (fromempty (negnatlehsnn 0 ((natlehandplusrinv 1 0 1) (pr2 prop)))).
Defined.

Definition i_func_example_reverse : (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr1 in_out_example))) -> (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr2 in_out_example))).
intros out.
  induction out.
  induction a as [n prop].
  induction n.
  unfold hProp_to_hSet in prop.
  apply (fromempty (negnatgth0n 0 (pr1 prop))).
  induction n.
  unfold I_or_O.
  apply (inr (tpair (fun vi : (boolset × natset)%set => dirprod_pr2 vi > 0 × dirprod_pr2 vi ≤ dirprod_pr1 in_out_example (dirprod_pr1 vi)) (make_dirprod true 1) (make_dirprod (natgthsnn 0) (isreflnatleh 1)))).
  induction n.
  apply (inr (tpair (fun vi : (boolset × natset)%set => dirprod_pr2 vi > 0 × dirprod_pr2 vi ≤ dirprod_pr1 in_out_example (dirprod_pr1 vi)) (make_dirprod false 1) (make_dirprod (natgthsnn 0) (isreflnatleh 1)))).
  apply (fromempty (negnatlehsnn 0 ((natlehandplusrinv 1 0 2) (pr2 prop)))).
  induction b as [vi prop].
  induction vi as [v i].
  induction v.
  unfold in_out_example in prop.
  unfold dirprod_pr2 in prop.
  unfold pr2 in prop.
  unfold out_example in prop.
  unfold dirprod_pr1 in prop.
  unfold pr1 in prop.
  unfold make_dirprod in prop.
  induction i.
  apply (fromempty (negnatgth0n 0 (pr1 prop))).
  induction i.
  unfold underlined.
  apply (inl (tpair (fun n : nat => dirprod (natgth n 0) (natleh n 2)) 2 (make_dirprod (natgthsn0 0) (natlehnsn 1)))).
  apply (fromempty (negnatlehsnn 0 ((natlehandplusrinv 1 0 1) (pr2 prop)))).
  unfold in_out_example in prop.
  unfold dirprod_pr2 in prop.
  unfold pr2 in prop.
  unfold out_example in prop.
  unfold dirprod_pr1 in prop.
  unfold pr1 in prop.
  unfold make_dirprod in prop.
  induction i.
  apply (fromempty (negnatgth0n 0 (pr1 prop))).
  induction i.
  unfold underlined.
  apply (inl (tpair (fun n : nat => dirprod (natgth n 0) (natleh n 2)) 1 (make_dirprod (natgthsn0 0) (natlehnsn 1)))).
  apply (fromempty (negnatlehsnn 0 ((natlehandplusrinv 1 0 1) (pr2 prop)))).
Defined.

Print i_func_example.

Theorem is_iso_i_example_1 : ∏ out_ : (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr2 in_out_example))), i_func_example_reverse (i_func_example out_) = out_.
  intros out_.
  induction out_.
  induction a as [n prop].
  induction n.
  apply (fromempty (negnatgth0n 0 (pr1 prop))).
  induction n.
  unfold i_func_example.
  unfold nat_rect.
  unfold coprod_rect.
  unfold i_func_example_reverse.
  unfold nat_rect.
  unfold coprod_rect.
  unfold bool_rect.
  unfold in_example.
  unfold out_example.
  unfold pr1.
  unfold pr2.
  unfold dirprod_pr1.
  unfold dirprod_pr2.
  auto.

Definition i_boolset : weq (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr2 in_out_boolset))) (setcoprod (underlined 2) (I_or_O boolset (dirprod_pr1 in_out_boolset))).
  unfold weq.
  unfold I_or_O.

  Check (fun (n : nat) => (fun (u : vertices_of g) => ((paths n 0) -> empty) -> (path_of_length g n v1 u) -> natlth ((pr1 top_order) v1) ((pr1 top_order) u))).
  Check nat_rect (fun (n : nat) => (fun (u : vertices_of g) => ((paths n 0) -> empty) -> (path_of_length g n v1 u) -> natlth ((pr1 top_order) v1) ((pr1 top_order) u))).
  Check nat_rect (fun (n : nat) (u : vertices_of g) => ((paths n 0) -> empty) -> (path_of_length g n v1 u) -> natlth ((pr1 top_order) v1) ((pr1 top_order) u)).
  Check (fun (n : nat) => ((path n 0) -> empty) -> (total2 (fun (u : vertices_of g) => path_of_length g n v1 u)) -> natlth ((pr1 top_order) v1) ((pr1 top_order) u)).
  Check (fun (n : nat) => ((paths n 0) -> empty)) -> (total2 (fun (u : vertices_of g) => path_of_length g n v1 u)) -> natlth ((pr1 top_order) v1) ((pr1 top_order) u).
  Check nat_rect (fun (n : nat) (u : vertices_of g) => ((paths n 0) -> empty) -> (path_of_length g n v1 u) -> natlth ((pr1 top_order) v1) ((pr1 top_order) v2)).

  Check nat_rect (fun (n : nat) => ((paths n 0) -> empty) -> nat_rect (fun (m : nat) (u : vertices_of g) => (path_of_length g m v1 u) -> (pr1 top_order) v1 < (pr1 top_order) u) )

  Check nat_rect.
  Check nat_rect (fun (n : nat) => ((paths n 0) -> empty) -> (path_of_length g n v1 v2) -> natlth ((pr1 top_order) v1) ((pr1 top_order) v2)) case1

Lemma case1 (g : graph) (top_order : topoligical_order g) (v1 v2 : vertices_of g) : ((paths 0 0) -> empty) -> (path_of_length g 0 v1 v2) -> natlth ((pr1 top_order) v1) ((pr1 top_order) v2).
Proof.
  intros prop.
  apply (fromempty (prop (idpath 0))).
Qed.

Check nat_rect.

Lemma case2 (g : graph) (top_order : topoligical_order g) (v1 v2 : vertices_of g) (n : nat) (Pn : ((paths n 0) -> empty) -> (path_of_length g n v1 v2) -> natlth ((pr1 top_order) v1) ((pr1 top_order) v2)) : ((paths (S n) 0) -> empty) -> (path_of_length g (S n) v1 v2) -> natlth

  induction n.
  apply (fromempty (prop (idpath 0))).
  unfold pr1 in path.
  induction n.
  unfold nat_rect in path.
  rewrite (dirprod_pr1 (pr2 path)).
  rewrite (dirprod_pr1 (pr2 (dirprod_pr2 (pr2 path)))).
  rewrite (dirprod_pr2 (pr2 (dirprod_pr2 (pr2 path)))).

   ((pr2 top_order) (pr1 (dirprod_pr2 (pr2 path)))).
  unfold nat_rect in path.

  g : graph
  top_order : ∑ enumeration : vertices_of g → nat,
              ∏ e : edges_of g, enumeration (source_of g e) < enumeration (target_of g e)
  v1, v2 : vertices_of g
  n : ∑ m : nat, m = 0 → ∅
  path : nat_rect (λ _ : nat, vertices_of g → vertices_of g → UU)
           (λ v1 v2 : vertices_of g, v1 = v2)
           (λ (_ : nat) (pths_of_m : vertices_of g → vertices_of g → UU)
            (v1 _ : vertices_of g),
            ∑ u : vertices_of g,
            pths_of_m v1 u × (∑ e : edges_of g, u = source_of g e × u = target_of g e))
           (pr1 n) v1 v2
  ============================
  pr1 top_order v1 < pr1 top_order v2

Print port_graph.

Definition internal_flow_graph_of {m n : nat} (t : tuple m n) : graph := make_graph (vertices t) (total2_hSet (fun ui : I_or_O (vertices t) (out_func t) => hProp_to_hSet (eqset (coprodtobool ((i_func t) (inr ui))) false))).

Record graph (V : UU) := mk_graph {A : UU; s : A -> V; t : A -> V}.

Arguments A {_} _.
Arguments s {_} _.
Arguments t {_} _.

Definition graph_mul {V : UU} := fun (g1 : graph V) (g2 : graph V) => mk_graph V (total2 (fun a1a2 : (dirprod (A g1) (A g2)) => paths ((t g1) (dirprod_pr1 a1a2)) ((s g2) (dirprod_pr2 a1a2)))) (fun a : _ => (s g1) (dirprod_pr1 (pr1 a))) (fun a : _ => (t g2) (dirprod_pr2 (pr1 a))).

Definition power {V : UU} (g : graph V) : nat -> graph V := nat_rect _ g (fun (n : _) (gn : _) => graph_mul g gn).

Definition func_union {A B C : UU} (f1 : A -> C) (f2 : B -> C) : (coprod A B) -> C := coprod_rect _  f1 f2.

Definition graph_union {V : UU} := fun (g1 : graph V) (g2 : graph V) => mk_graph V (coprod (A g1) (A g2)) (func_union (s g1) (s g2)) (func_union (t g1) (t g2)).

Definition transitive_closure {V : UU} (g : graph V) := g. (* to do: should be union of all natural powers of g *)

Definition acyclisity {V : UU} (g : graph V) := forall a : (A g), ((s g) a) <> ((t g) a).

Record port_graph (m n : nat) := mk_port_graph {V : UU; in : V -> nat; out : V -> nat; }

Definition something {S : hSet} {s s' : S} (x x' : paths s s') (prop : isaprop (pr1 (s = s')%set)) : iscontr (paths x x').
Proof.
  unfold isaprop in prop.
  unfold isofhlevel in prop.
  Check prop x x'.
  apply (prop x x').
Defined.

Definition something2 {S : hSet} {s s' : S} {x x' : paths s s'} (contr : iscontr (paths x x')) (e e' : paths x x') : paths e e'.
  unfold iscontr in contr.
  rewrite (pr2 contr e).
  rewrite (pr2 contr e').
  apply (idpath (pr1 contr)).
Defined.

Theorem help (S : hSet) (s s' : S) : isaset (paths s s').
Proof.
  unfold isaset.
  intros x x'.
  unfold isaprop.
  unfold isofhlevel.
  intros e e'.
  unfold iscontr.
  exists (something2 (something x x' (propproperty (eqset s s'))) e e').
  intros t0.
  unfold propproperty.
  unfold eqset.
  unfold pr2.
  unfold make_hProp.
  unfold something.
  unfold something2.
  unfold internal_paths_rew_r.
  Check something x x' (propproperty (eqset s s')).
  Check (propproperty (eqset s s')).

  Definition graph_union {V : UU} := fun (g1 : graph V) (g2 : graph V) => mk_graph V (coprod)

Definition graph (V : UU) {A : UU} := dirprod UU (dirprod UU (dirprod (A -> V) (A -> V))).
Definition make_graph (V A : UU) (s t : A -> V) : graph V := make_dirprod V (make_dirprod A (make_dirprod s t)).

Definition not_set_graph_mul {V : UU} := fun (g1 : graph V) (g2 : graph V) => make_graph V (total2 (fun a1a2 : (dirprod A1 A2) => paths (t1 (dirprod_pr1 a1a2)) (s2 (dirprod_pr2 a1a2)))) (fun x : _ => s1 (dirprod_pr1 (pr1 x))) (fun x : _ => t2 (dirprod_pr2 (pr1 x))) where "A1" := (dirprod_pr1 (dirprod_pr2 g1)).

Fixpoint power (n : nat) {V A1 A2 : UU} {s1 t1 : A1 -> V} {s2 t2 : A2 -> V} (g : not_set_graph V A1 s1 t1) : not_set_graph V A2 s2 t2 :=
  match n with
    | 0 => g
    | S p => (not_set_graph_mul g (power p g))
  end.

Definition graph (V A : hSet) (s t : A -> V) := UU.

Variable (V A1 A2 : hSet) (s1 t1 : A1 -> V) (s2 t2 : A2 -> V) (a1a2 : dirprod_hSet A1 A2).
Check dirprod_hSet A1 A2.
Check paths (t1 (pr1 a1a2)) (s2 (pr2 a1a2)).
Check isaset (paths (t1 (pr1 a1a2)) (s2 (pr2 a1a2))).
Check forall a1a2 : (dirprod_hSet A1 A2), paths (t1 (pr1 a1a2)) (s2 (pr2 a1a2)).
Check total2 (fun a1a2 : (dirprod_hSet A1 A2) => paths (t1 (pr1 a1a2)) (s2 (pr2 a1a2))).
Check paths (t1 (pr1 a1a2)) (s2 (pr2 a1a2)).

Theorem h (e e' : paths (t1 (pr1 a1a2)) (s2 (pr2 a1a2))) (x x' : paths e e') : paths x x'.
  Check setproperty V.
  Print isaset.
  Print isaprop.

Theorem help : isaset (paths (t1 (pr1 a1a2)) (s2 (pr2 a1a2))).
  unfold isaset.
  intros e e'.
  unfold isaprop.
  unfold isofhlevel.
  intros x x'.
  unfold iscontr.
  Check total2_rect.
  Check tpair.
  Check tpair (fun cntr : (paths x x') => forall t : _, paths t cntr).
Check forall_hSet (fun x : (total2 (fun a1a2 : (dirprod_hSet A1 A2) => paths (t1 (pr1 a1a2)) (s2 (pr2 a1a2)))) => pr1 x).
Check pr1.
Check pr1 (total2 (fun a1a2 : (dirprod_hSet A1 A2) => paths (t1 (pr1 a1a2)) (s2 (pr2 a1a2)))).

Definition graph_mul (V : hSet) {A1 A2 : hSet} {s1 t1 : A1 -> V} {s2 t2 : A2 -> V} := fun (g1 : graph V A1 s1 t1) (g2 : graph V A2 s2 t2) => graph V
**)


Require  Export Bool.

Inductive L : Set :=
| L_true  | L_false
| L_disj (l1 l2 : L) | L_conj (l1 l2 : L) | L_impl (l1 l2 : L)
| L_not (l : L).

Fixpoint L_value (l : L): bool :=
 match l with
 | L_true => true
 | L_false => false
 | L_disj l1 l2 => L_value l1 || L_value l2
 | L_conj l1 l2 => L_value l1 &&  L_value l2
 | L_impl l1 l2 => implb (L_value l1) (L_value l2)
 | L_not l1 => negb (L_value l1)
 end.

(* infix notations *)

Declare Scope prop_scope.

Notation "A * B"  := (L_conj A B) : prop_scope.

Notation "A + B"  := (L_disj A B) : prop_scope.

Notation "A <= B" := (L_impl A B) : prop_scope.

Notation "'tt'" := L_true : prop_scope.

Notation "'ff'" := L_false : prop_scope.

Notation "- A" := (L_not A) : prop_scope.

Open Scope prop_scope.

(** Tests :

Compute L_value (tt * ff).

Compute L_value (tt * ff + (tt <= ff)).

Compute L_value (- (tt * ff + (tt <= ff))).
*)


Require Import Coq.Lists.List Coq.Classes.EquivDec Lia. Import ListNotations.
Require Import SyDPaCC.Core.Bmf  SyDPaCC.Support.List.
Set Implicit Arguments.
Generalizable All Variables.

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

(** * Count *)

Section Count.

  Variable A : Type.
  Variable predicate : { pred: A -> bool & { a : A | pred a = true} }.
  Definition p : A->bool := projT1 predicate.

  (** ** Specification of the problem *)

  Definition count_spec (l:list A) : nat :=
    length (filter p l).

  (** ** [count_spec] is both leftwards and rightwards *)

  Definition opl (a:A)(count:nat) : nat :=
    count + (if (p a) then 1 else 0).

  Instance count_leftwards : Leftwards count_spec opl 0.
  Proof.
    constructor; induction l as [ | x xs IH ]; simpl.
    - trivial.
    - rewrite <- IH; clear IH; unfold opl, count_spec; simpl.
      destruct(p x); simpl; lia.
  Qed.

  Definition opr (count:nat)(a:A) : nat :=
    count + (if (p a) then 1 else 0).

  Instance count_rightwards: Rightwards count_spec opr 0.
  Proof.
    constructor; induction l as [ | x xs IH ] using rev_ind; simpl.
    - trivial.
    - unfold count_spec in *; simpl.
      rewrite fold_left_app, filter_app; simpl.
      autorewrite with length. unfold opr at 1.
      destruct(p x); auto.
  Qed.

  (** ** [count_spec] has a weak right inverse if its predicate argument is
      true for at least one element *)

  Definition default : A := proj1_sig (projT2 predicate).
  Lemma default_prop : p default = true.
    unfold p, default; destruct predicate as [ p [ a Ha ]]; simpl;  auto.
  Qed.

  Definition count_inv (n:nat) : list A :=
    map(fun x=>default) (seq 0 n).

  Lemma length_filter_count_inv:
    forall n, length(filter p (count_inv n)) = n.
  Proof.
    intro; unfold count_inv.
    rewrite filter_true
      by (intros a Ha; rewrite in_map_iff in Ha; destruct Ha as [ y [ Heq _ ]];
          rewrite <- Heq; apply default_prop).
    now autorewrite with length.
  Qed.

  Hint Rewrite length_filter_count_inv : length.

  Instance count_right_inverse :
    Right_inverse count_spec count_inv.
  Proof.
    constructor; induction l as [|x xs IH].
    - trivial.
    - unfold count_spec; now autorewrite with length.
  Qed.

  (** ** [count_spec] is an homomorphism *)
  Global Instance count:
    Homomorphic count_spec
                (fun l r=>count_spec(count_inv l ++ count_inv r)).
  typeclasses eauto.
  Qed.

  (** ** Optimization of this homomophism *)

  Global Instance opt_op : Optimised_op count_spec.
  Proof.
    constructor; unfold count_spec; eexists.
    intros a b. rewrite filter_app;  autorewrite with length.
    reflexivity.
  Defined.

  Global Instance opt_f : Optimised_f count_spec.
  Proof.
    constructor; unfold count_spec; eexists; intro a; simpl.
    replace(length (if p a then [a] else [])) with (if p a then 1 else 0).
    reflexivity.
    destruct(p a);auto.
  Defined.

End Count.


Require Import Bool.
Require Import List.
Require Import Arith.

Require Import typed.
Require Import Utils.nat.

Lemma blt_nat_test1: blt_nat 0 0 = false.
Proof. reflexivity. Qed.

Lemma blt_nat_test2: blt_nat 1 0 = false.
Proof. reflexivity. Qed.

Lemma blt_nat_test3: blt_nat 0 1 = true.
Proof. reflexivity. Qed.

Lemma blt_nat_test4: blt_nat 1 1 = false.
Proof. reflexivity. Qed.

Lemma typeDenote_test1: typeDenote Nat = nat.
Proof. reflexivity. Qed.

Lemma typeDenote_test2: typeDenote Bool = bool.
Proof. reflexivity. Qed.

Lemma tbinopDenote_test1: tbinopDenote TPlus = plus.
Proof. reflexivity. Qed.

Lemma tbinopDenote_test2: tbinopDenote TTimes = mult.
Proof. reflexivity. Qed.

Lemma tbinopDenote_test3: tbinopDenote (TEq Nat) = beq_nat.
Proof. reflexivity. Qed.

Lemma tbinopDenote_test4: tbinopDenote (TEq Bool) = eqb.
Proof. reflexivity. Qed.

Lemma tbinopDenote_test5: tbinopDenote TLt = blt_nat.
Proof. reflexivity. Qed.

Lemma texpDenote_test1: texpDenote (TNConst 42) = 42.
Proof. reflexivity. Qed.

Lemma texpDenote_test2: texpDenote (TBConst true) = true.
Proof. reflexivity. Qed.

Lemma texpDenote_test3: texpDenote (TBConst false) = false.
Proof. reflexivity. Qed.

Lemma texpDenote_test4: texpDenote
    ( TBinop TTimes
        (TBinop TPlus (TNConst 2)(TNConst 3))
        (TNConst 7)) = 35.
Proof. reflexivity. Qed.

Lemma texpDenote_test5: texpDenote
    ( TBinop (TEq Nat)
        (TBinop TPlus (TNConst 4) (TNConst 3))
        (TNConst 7)) = true.
Proof. reflexivity. Qed.

Lemma texpDenote_test6: texpDenote
    ( TBinop (TEq Bool)
        (TBinop (TEq Nat) (TNConst 2) (TNConst 3))
        (TBConst false)) = true.
Proof. reflexivity. Qed.

Lemma texpDenote_test7: texpDenote
    ( TBinop TLt
        (TBinop TPlus (TNConst 2) (TNConst 3))
        (TNConst 7)) = true.
Proof. reflexivity. Qed.

Definition x : unit := tt.

(*
Print tcompile.
*)

Lemma tcompile_test1:
    tprogDenote (tcompile (TNConst 42) nil) tt = (42,tt).
Proof. reflexivity. Qed.

Lemma tcompile_test2:
    tprogDenote (tcompile (TBConst true) nil) tt = (true,tt).
Proof. reflexivity. Qed.

Lemma tcompile_test3:
    tprogDenote (tcompile (TBConst false) nil) tt = (false,tt).
Proof. reflexivity. Qed.

Lemma tcompile_test4:
    tprogDenote
        (tcompile
            (TBinop TTimes
                (TBinop TPlus (TNConst 2) (TNConst 3))
                (TNConst 7)) nil) tt = (35,tt).
Proof. reflexivity. Qed.

Lemma tcompile_test5:
    tprogDenote
        (tcompile
            (TBinop (TEq Nat)
                (TBinop TPlus (TNConst 2) (TNConst 3))
                (TNConst 7)) nil) tt = (false, tt).
Proof. reflexivity. Qed.

Lemma tcompile_test6:
    tprogDenote
        (tcompile
            (TBinop (TEq Nat)
                (TBinop TPlus (TNConst 2) (TNConst 3))
                (TNConst 5)) nil) tt = (true, tt).
Proof. reflexivity. Qed.

Lemma tcompile_test7:
    tprogDenote
        (tcompile
            (TBinop (TEq Bool)
                (TBinop (TEq Nat) (TNConst 2) (TNConst 2))
                (TBConst true)) nil) tt = (true, tt).
Proof. reflexivity. Qed.

Lemma tcompile_test8:
    tprogDenote
        (tcompile
            (TBinop (TEq Bool)
                (TBinop (TEq Nat) (TNConst 3) (TNConst 2))
                (TBConst true)) nil) tt = (false, tt).
Proof. reflexivity. Qed.

Lemma tcompile_test9:
    tprogDenote
        (tcompile
            (TBinop TLt
                (TBinop TPlus (TNConst 2) (TNConst 3))
                (TNConst 5)) nil) tt = (false, tt).
Proof. reflexivity. Qed.

Lemma tcompile_test10:
    tprogDenote
        (tcompile
            (TBinop TLt
                (TBinop TPlus (TNConst 2) (TNConst 3))
                (TNConst 6)) nil) tt = (true, tt).
Proof. reflexivity. Qed.

(*
Extraction Language Haskell.
Extraction tcompile.
*)


Require Import Omega List prelim.
Import ListNotations.

(* * H10 *)
Inductive deq :=
| Con (x c: nat)
| Add (x y z: nat)
| Mul (x y z: nat).

Notation "x =ₑ c" := (Con x c) (at level 66).
Notation "x +ₑ y =ₑ z" := (Add x y z) (at level 66, y at next level).
Notation "x *ₑ y =ₑ z" := (Mul x y z) (at level 66, y at next level).
Reserved Notation "sigma ⊢ₑ e" (at level 60, e at level 99).

Inductive sol (sigma: nat -> nat) : deq -> Prop :=
| solC x c: sigma x = c -> sigma ⊢ₑ x =ₑ c
| solA x y z: sigma x + sigma y = sigma z -> sigma ⊢ₑ x +ₑ y =ₑ z
| solM x y z: sigma x * sigma y = sigma z -> sigma ⊢ₑ x *ₑ y =ₑ z
where "sigma ⊢ₑ e" := (sol sigma e).

Definition Sol (sigma: nat -> nat) (E: list deq) := forall e, e ∈ E -> sigma ⊢ₑ e.
Notation "sigma ⊢⁺ₑ E" := (Sol sigma E) (at level 60, E at level 99).
Definition H10 (E: list deq) := exists sigma, sigma ⊢⁺ₑ E.

Definition vars__de (e: deq) :=
  match e with
  | x =ₑ c => [x]
  | x +ₑ y =ₑ z => [x; y; z]
  | x *ₑ y =ₑ z => [x; y; z]
  end.

Definition Vars__de E :=
  nodup Nat.eq_dec (flat_map vars__de E).

Lemma Vars__de_in e E:
  e ∈ E -> forall y, y ∈ vars__de e -> y ∈ Vars__de E.
Proof.
  unfold Vars__de; intros; eapply nodup_In, in_flat_map.
  exists e. intuition.
Qed.


Require Import List.
Export ListNotations.
Require Export ZArith.
Require Import Init.Datatypes.

Inductive IPE2: Type :=
 | zero_pe2
 | one_pe2.

Inductive PE2 : Type :=
 | i_pe2      : IPE2 -> PE2
 | u_pe2      : PE2.

Definition P2 : Type := list PE2.

Function beq_IPE2 (i i' : IPE2) : bool :=
  match i, i' with
    | zero_pe2, zero_pe2 => true
    | one_pe2, one_pe2 => true
    | _, _ => false
  end.

Function beq_PE2 (p p' : PE2) : bool :=
  match p, p' with
    | i_pe2 x, i_pe2 y => beq_IPE2 x y
    | u_pe2, u_pe2 => true
    | _, _ => false
  end.

Function beq_path2 (p q : P2) : bool :=
  match p, q with
    | [], [] => true
    | x :: p', y :: q' => andb (beq_PE2 x y) (beq_path2 p' q')
    | _  , _ => false
  end.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


(* These exercises require inductive proofs. *)
(* Now that you have some experience with Coq,
   you can use 'auto' tactic to avoid solving simple subgoals manually. *)

Require Import b1.
Require Import b2.
Require Import List.
Import ListNotations.

Section NatDict'Proofs.
  Context {V: Type}.

 Lemma n_eq_or_neq (n n': nat): (n=n')\/(n<>n').
  Proof.
  pattern n, n'.
  apply (nat_double_ind).
  {
    intros n0.
    destruct n0.
    auto.
    auto.
  }
  {
    intros n0.
    auto.
  }
  {
    intros n0 m.
    intros h.
    destruct h.
    auto.
    auto.
  }
Qed.

Lemma noeq_impl_nat_eq_false (n1:nat) (n2:nat) : n1 <> n2 -> nat_eq n1 n2 = false.
    Proof.
      intros.
      remember H as H'.
      remember (nat_eq_neg_spec n1 n2) as nat_eq_neg.
      unfold iff in nat_eq_neg.
      destruct nat_eq_neg as (nat_eq_neg_l & nat_eq_neg_r).
      (*Reset Heqn1.*)
      auto.
    Qed.

  (* Prove that 'remove' operation actually removes a key. *)
  (* The list inside nat_dict_list consists of pairs.
     To extract components of such list's head,
     either perform pattern matching in 'induction' tactics
     or directly 'destruct' the element of nat*V type. *)
  Lemma removed_not_contained (d: @nat_dict_list V) (n: nat):
    contains'' (remove'' d n) n = false.
  Proof.
  induction d.
  auto.

(*  unfold contains''.
  unfold get''.*)
  destruct a.
  destruct (n_eq_or_neq n n0).
  {
    apply eq_implies_nat_eq in H.
    simpl.
    rewrite H.
    auto.
  }
  apply noeq_impl_nat_eq_false in H.
  simpl.
  rewrite H.
  simpl.
  rewrite H.

(*rewrite Heqaaa.
  pattern (remove'' d n), n in Heqaaa.

  pattern (remove'' d n), n.
  fold (@contains'' V).
  fold ((contains'' (remove'' d n) n)).
  inversion (get'' (remove'' d n) n).

  fold (@contains'' V).

  unfold contains'' in IHd.

  fold (@contains'' V) n (remove'' d n).
  IHd.
  unfold contains'' in IHd.
  red in IHd.
  rewrite IHd.
  destruct IHd.
  auto.
*)

Admitted.

  (* Define a mapping function similar to one defined for regular lists.
     It should replace values stored in dict but keep them under the same keys. *)
  Fixpoint map'' {W: Type} (f: V -> W) (d: @nat_dict_list V): @nat_dict_list W :=
      (* place your code here *)
      match d with
      | nil => nil
      | cons (k, v) t => cons (k, f v) (map'' f t)
      end.

  (* Prove that a value stored in a mapped dict
     requires a corresponding value stored in an original dict. *)
  Lemma dict_map_get {W: Type} (m: V -> W) (d: @nat_dict_list V):
    forall n w,
      (get'' (map'' m d) n = Some w) <->
      (exists v, get'' d n = Some v /\ m v = w).
  Proof.
  unfold iff.
  split.
  {
    intros.
    induction d as [| a l ih].
    {unfold get''.
      simpl in H.
      inversion H.
    }
    destruct a.
    destruct (n_eq_or_neq n n0).
    {
      rewrite H0.
      simpl.
      exists v.
      (*eapply ex_intro.*)
      rewrite nat_eq_refl.
      split.
      {reflexivity. }
      rewrite H0 in H.
      simpl in H.
      rewrite nat_eq_refl in H.
      inversion H.
      reflexivity.
    }
    simpl in H.
    remember H0 as H0'.
    remember (nat_eq_neg_spec n n0) as nat_eq_neg.
    unfold iff in nat_eq_neg.
    destruct nat_eq_neg as (nat_eq_neg_l & nat_eq_neg_r).
    (*Reset Heqn1.*)
    remember (nat_eq_neg_r H0') as H1.
    rewrite H1 in H.
    apply ih in H.

    unfold get''.
    simpl.
    rewrite H1.
    auto.
    }

    intros.
    destruct H as (v & H).
    destruct H as (H1 & H2).
    induction d as [| a l ih].
    {
      simpl in H1.
      inversion H1.
    }
    destruct a.
    destruct (n_eq_or_neq n n0).
    {
    apply eq_implies_nat_eq in H.
    simpl in H1.
    rewrite H in H1.
    simpl.
    rewrite H.
    inversion H1.
    destruct H2.
    reflexivity.
    }
    apply noeq_impl_nat_eq_false in H.
    simpl in H1.
    rewrite H in H1.
    simpl.
    rewrite H.
    auto.
Qed.

  (* Implement a filtering function.
     The result should contain only those keys whose values satisfy the predicate;
     in this case they remain unchanged. *)
  Fixpoint filter'' {U: Type} (f: U -> bool) (d: @nat_dict_list U): @nat_dict_list U :=
      (* place your code here *)
      match d with
      | nil => nil
      | cons (k, v) t => if (f v) then cons (k, v) (filter'' f t) else (filter'' f t)
      end.

(*...*)

  (* Prove that the result of filtering is actually filtered *)
  Lemma filter_elem (f: V -> bool) (d: @nat_dict_list V):
    forall n,
      (contains'' (filter'' f d) n = true) <->
      (exists v, get'' d n = Some v /\ f v = true).
  Proof.
  intros.
  unfold iff.
  split.
  {
    induction d.
    {
      intros.
      simpl in H.
      inversion H.
    }
    destruct a.
    destruct (n_eq_or_neq n n0).
    {
       apply (eq_implies_nat_eq n n0) in H.
       intros.
       exists v.
       unfold get''.
       simpl.
       rewrite H.
       split.
       reflexivity.
       unfold contains'' in H0.
       simpl in H0.
       remember (bool_true_or_false (f v)).
       destruct o.
       apply e.
       rewrite e in H0.
       apply IHd in H0.
       desrtuct
       red in  H0.

Admitted.

  (* You (most probably) implemented list-based dictionary in a way
     that doesn't distinguish, say, [(1, 2), (3, 4)] and [(3, 4), (1, 2)] dicts. *)
  (* That is, the results of 'insert', 'contains' and other interface operations
     should be the same for them. *)
  (* Such lists are not-equal, though,
     since the only list equal to [(1, 2), (3, 4)] is exactly [(1, 2), (3, 4)]. *)
  (* We can formalize the specific notion of equivalence for dictionaries
     to prove their more complicated properties. *)
  (* Note that this equ ivalence only deals with dict interface
     and not the particular implementation. *)
  Definition sim_dicts (d1 d2: @nat_dict_list V) :=
    forall n, get'' d1 n = get'' d2 n.

(*...*)

  (* Prove that an insertion makes a preceding removal pointless.
     To ease the proof, you may want to prove separately that:
     - sim_dicts relation is transitive
     - an insertion of the same key-value pair preserves sim_dicts
     - a double insertion of the same key-value pair
       is similar (in terms of sim_dicts) to a single insertion
     - insertions of separate keys commute
       (that is, their results are related by sim_dicts).
     Also, it can be easier to operate on level of a higher level of 'insert's
     instead of a lower level of list 'cons'es.
     To replace 'cons' with 'insert', use 'fold' tactic.
*)
  Lemma insert_remove_simpl (d: @nat_dict_list V) (n: nat) (v: V):
    sim_dicts (insert'' (remove'' d n) n v) (insert'' d n v).
  Proof.
Admitted.

End NatDict'Proofs.


(* Concrete Semantics with Isabelle/HOLに出てくるプログラムをCoqで実装 *)

Section Chapter3.
  (* 主にIMPという言語についてのお話 *)
  (* 正直 い つ も の *)
  Require Import String.
  Open Scope string.

  Definition vname := string.
  Inductive aexp :=
    | N : forall n: nat, aexp (* 原文はint *)
    | V : forall s: vname, aexp (* 変数 *)
    | Plus : forall l r: aexp, aexp. (* 加算 *)

  Definition val := nat.
  Definition state := vname -> val. (* コンテキスト *)

  Fixpoint aval (e: aexp) (s: state) : val :=
    match e with
    | N n => n
    | V x => s x
    | Plus l r => aval l s + aval r s
    end.

  Compute aval (Plus (N 3) (V "x")) (fun _ => 5).

  (* 定数同士のPlusのときに簡単にする最適化 *)
  Fixpoint asimp_const (e: aexp) : aexp :=
    match e with
    | N n => N n
    | V x => V x
    | Plus l r =>
      match (asimp_const l, asimp_const r) with
      | (N n0, N n1) => N (n0 + n1)
      | (e0, e1) => Plus e0 e1
      end
    end.

  Compute asimp_const (Plus (V "x") (Plus (N 3) (N 1))).

  (* asimp_constがaexpの意味を変えないことの証明 *)
  Lemma aval_asimp_const : forall (e: aexp) (s: state), aval (asimp_const e) s = aval e s.
  Proof.
    induction e; intros; simpl.
    - reflexivity.
    - reflexivity.
    - specialize (IHe1 s); specialize (IHe2 s).
      rewrite <- IHe1; rewrite <- IHe2.
      destruct (asimp_const e1); destruct (asimp_const e2); simpl; try reflexivity.
  Qed.

  (* asimp_constをより最適化 *)
  Definition plus (l r: aexp) : aexp :=
    match (l, r) with
    | (N n0, N n1) => N (n0 + n1)
    | (N n, e) => if Nat.eqb n 0 then e else Plus (N n) e
    | (e, N n) => if Nat.eqb n 0 then e else Plus e (N n)
    | (e0, e1) => Plus e0 e1
    end.

  (* aval_asimpと同じ感じ *)
  Lemma aval_plus :
    forall (e0 e1: aexp) (s: state), aval (plus e0 e1) s = aval e0 s + aval e1 s.
  Proof.
    SearchPattern (_ = _ + 0).
    induction e0; induction e1; intros; simpl; try reflexivity;
    destruct n; simpl; try apply plus_n_O; try reflexivity.
  Qed.

  (* Plusをplusに置き換え *)
  Fixpoint asimp (e: aexp) : aexp :=
    match e with
    | N n => N n
    | V x => V x
    | Plus e0 e1 => plus (asimp e0) (asimp e1)
    end.

  (* avalのあれ *)
  Lemma aval_asimp : forall (e: aexp) (s: state), aval (asimp e) s = aval e s.
  Proof.
    induction e; intros; simpl; try reflexivity.
    specialize (IHe1 s); specialize (IHe2 s).
    rewrite <- IHe1; rewrite <- IHe2.
    apply aval_plus.
  Qed.

  (* Ex 3.1 *)
  Definition optimal (e: aexp) : Prop :=
    match e with
    | Plus e0 e1 =>
      match (e0, e1) with
      | (N _, N _) => False
      | _ => True
      end
    | _ => True
    end.

  Lemma asimp_const_optimal: forall (e: aexp), optimal (asimp_const e).
  Proof.
    induction e; intros; simpl; try apply I.
    destruct (asimp_const e1); destruct (asimp_const e2); simpl; apply I.
  Qed.

  (* Ex 3.2 *)
  Fixpoint full_asimp (e: aexp) : aexp :=
    match e with
    | N n => N n
    | V x => V x
    | Plus e0 e1 =>
      match (full_asimp e0, full_asimp e1) with
      | (N n0, N n1) => N (n0 + n1)
      | (N n, Plus n0 n1) =>
        match (n0, n1) with
        | (N n', _) => Plus (N (n + n')) n1
        | (_, N n') => Plus n0 (N (n + n'))
        | (_, _) => Plus e0 e1
        end
      | (Plus n0 n1, N n) =>
        match (n0, n1) with
        | (N n', _) => Plus (N (n + n')) n1
        | (_, N n') => Plus n0 (N (n + n'))
        | (_, _) => Plus e0 e1
        end
      | (Plus n0 n1, Plus n2 n3) =>
        match (n0, n1, n2, n3) with
        | (N n0', _, N n2', _) => Plus (N (n0' + n2')) (Plus n1 n3)
        | (N n0', _, _, N n3') => Plus (N (n0' + n3')) (Plus n1 n2)
        | (_, N n1', N n2', _) => Plus (N (n1' + n2')) (Plus n0 n3)
        | (_, N n1', _, N n3') => Plus (N (n1' + n3')) (Plus n0 n2)
        | _ => Plus e0 e1
        end
      | (_, _) => Plus e0 e1 (* どっちかにVがあるとどうしようもない *)
      end
    end.

  Compute full_asimp (Plus (N 1) (Plus (V "x") (N 2))).

  Require Import Lia.

  Fact add_shuffle_4 : forall a b c d: nat, a + b + (c + d) = c + (a + b + d).
  Proof.
    intros; lia.
  Qed.

  Create HintDb chapter3.
  Hint Resolve add_shuffle_4 : chapter3.
  SearchPattern(_ + (_ + _) = _ + (_ + _)).

  Lemma aval_full_asimp :
    forall (e: aexp) (s: state), aval (full_asimp e) s = aval e s.
  Proof.
    induction e; intros; simpl; try reflexivity.
    specialize (IHe1 s); specialize (IHe2 s).
    rewrite <- IHe1; rewrite <- IHe2.
    destruct (full_asimp e1); destruct (full_asimp e2); simpl; try reflexivity;
      try rewrite <- IHe1; try rewrite <- IHe2; simpl; try reflexivity.
    destruct a1; destruct a2; simpl; intuition.
    Focus 2.
  Admitted. (* とてつもなくめんどくさそうなので保留 *)

  Compute (string_dec "hoge" "hoge").

  Fixpoint subst' (s: vname) (e0 e1: aexp) : aexp :=
    match e1 with
    | N n => N n
    | V x =>
      match string_dec s x with
      | left _ => e0
      | right _ => (V x)
      end
    | Plus n0 n1 => Plus (subst' s e0 n0) (subst' s e0 n1)
    end.

  Compute subst' "x" (N 3) (Plus (V "x") (V "y")).

  Lemma subst'_lemma: forall (e0 e1 elm: aexp) (x: vname) (s: state),
      aval e0 s = aval e1 s -> aval (subst' x elm e0) s = aval (subst' x elm e1) s.
  Proof.
    intros.
    induction e0; induction e1.
    simpl in *. assumption.
    simpl.
    repeat match goal with
    | [ |- context[if ?P then _ else _]] => destruct P; simpl; try assumption
    end.
  Admitted.

  (* 証明ムズイ *)

  (* 3.2 *)

  Require Import Bool.

  Inductive bexp :=
  | Bc : forall b: bool, bexp
  | Not : forall b: bexp, bexp
  | And : forall b0 b1: bexp, bexp
  | Less : forall a0 a1: aexp, bexp.

  Fixpoint bval (b: bexp) (s: state) : bool :=
    match b with
    | Bc v => v
    | Not b' => negb (bval b' s)
    | And b0 b1 => andb (bval b0 s) (bval b1 s)
    | Less a0 a1 => Nat.leb (aval a0 s) (aval a1 s)
    end.

  Definition not (b: bexp) : bexp :=
    match b with
    | Bc true => Bc false
    | Bc false => Bc true
    | _ => Not b
    end.

  Definition and (b0 b1: bexp) : bexp :=
    match (b0, b1) with
    | (Bc true, b1') => b1'
    | (b0', Bc true) => b0'
    | (Bc false, _) => Bc false
    | (_, Bc false) => Bc false
    | (_, _) => And b0 b1
    end.

  Definition less (a0 a1: aexp) : bexp :=
    match (a0, a1) with
    | (N n0, N n1) => Bc (Nat.leb n0 n1)
    | (_, _) => Less a0 a1
    end.

  Fixpoint bsimp (b: bexp) : bexp :=
    match b with
    | Bc v => Bc v
    | Not b' => not (bsimp b')
    | And b0 b1 => and (bsimp b0) (bsimp b1)
    | Less a0 a1 => less (asimp a0) (asimp a1)
    end.

  (* 演習は省略 *)

  (* 3.3 *)
  Inductive instr :=
  | LOADI : forall (n: val), instr
  | LOAD  : forall (s: vname), instr
  | ADD : instr.

  Require Import List.

  Definition stack := list nat.

  Definition hd2 (l: list nat) := List.hd 0 (List.tl l).

  Definition tl2 (l: list nat) := List.tl (List.tl l).

  Definition exec1 (i: instr) (s: state) (stk: stack) : stack :=
    match i with
    | LOADI n => n :: stk
    | LOAD  x => (s x) :: stk
    | Add => (hd2 stk + hd 0 stk) :: tl2 stk
    end.

  (* headはデフォルト引数が必要だったらしい *)


Require Export Basics_J.

Module NatList.
  (* Inductive natprod : Type := *)
  (*   pair : nat -> nat -> natprod. *)

  (* Definition fst (p : natprod) : nat := *)
  (*   match p with *)
  (*   | pair x y => x *)
  (*   end. *)

  (* Definition snd (p : natprod) : nat := *)
  (*   match p with *)
  (*   | pair x y => y *)
  (*   end. *)

  (* Notation "( x , y )" := (pair x y). *)

  (* Eval simpl in (fst (3, 4)). *)

  (* Definition fst' (p : natprod) : nat := *)
  (*   match p with *)
  (*   | (x, y) => x *)
  (*   end. *)

  (* Definition snd' (p : natprod) : nat := *)
  (*   match p with *)
  (*   | (x, y) => y *)
  (*   end. *)

  (* Definition swap_pair (p : natprod) : natprod := *)
  (*   match p with *)
  (*   | (x, y) => (y, x) *)
  (*   end. *)

  (* Theorem surjective_pairing' : forall (n m : nat), *)
  (*     (n, m) = (fst (n, m), snd (n, m)). *)
  (* Proof. *)
  (*   reflexivity. *)
  (* Qed. *)

  (* Theorem subjective_pairing : forall (p : natprod), *)
  (*     p = (fst p, snd p). *)
  (* Proof. *)
  (*   intros. destruct p as (n, m). simpl. reflexivity. *)
  (* Qed. *)

  (* Theorem snd_fst_is_swap : forall (p : natprod), *)
  (*     (snd p, fst p) = swap_pair p. *)
  (* Proof. *)
  (*   intros p. destruct p as (n, m). simpl. reflexivity. *)
  (* Qed. *)

  Inductive natlist : Type :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

  Notation "x :: l" := (cons x l) (at level 60, right associativity).
  Notation "[]" := nil.
  Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

  Fixpoint repeat (n count : nat) : natlist :=
    match count with
    | O => nil
    | S count' => n :: (repeat n count')
    end.

  Fixpoint length (l : natlist) : nat :=
    match l with
    | nil => O
    | h :: t => S (length t)
    end.

  Fixpoint app (l1 l2 : natlist) : natlist :=
    match l1 with
    | nil => l2
    | h :: t => h :: (app t l2)
    end.

  Notation "x ++ y" := (app x y) (right associativity, at level 60).

  Example test_app1 : [1, 2, 3] ++ [4, 5] = [1, 2, 3, 4, 5].
  Proof. reflexivity. Qed.
  Example test_app2 : nil ++ [4, 5] = [4, 5].
  Proof. reflexivity. Qed.
  Example test_app3 : [1, 2, 3] ++ nil = [1, 2, 3].
  Proof. reflexivity. Qed.

  Definition hd (default : nat) (l : natlist) : nat :=
    match l with
    | nil => default
    | h :: t => h
    end.

  Definition tail (l : natlist) : natlist :=
    match l with
    | nil => nil
    | h :: t => t
    end.

  Example test_hd1:             hd 0 [1,2,3] = 1.
  Proof. reflexivity.  Qed.
  Example test_hd2:             hd 0 [] = 0.
  Proof. reflexivity.  Qed.
  Example test_tail:            tail [1,2,3] = [2,3].
  Proof. reflexivity.  Qed.

  Fixpoint nonzeros (l:natlist) : natlist :=
    match l with
    | nil => nil
    | h :: t => match h with
                | O => nonzeros t
                | _ => cons h (nonzeros t)
                end
    end.

  Example test_nonzeros:            nonzeros [0,1,0,2,3,0,0] = [1,2,3].
  Proof. reflexivity. Qed.

  Fixpoint oddmembers (l:natlist) : natlist :=
    match l with
    | nil => nil
    | h :: t => match oddb h with
                | true => cons h (oddmembers t)
                | false => oddmembers t
                end
    end.

  Example test_oddmembers:            oddmembers [0,1,0,2,3,0,0] = [1,3].
  Proof. reflexivity. Qed.

  Fixpoint countoddmembers (l:natlist) : nat :=
    match l with
    | nil => O
    | h :: t => match oddb h with
                | true => S (countoddmembers t)
                | false => countoddmembers t
                end
    end.

  Example test_countoddmembers1:    countoddmembers [1,0,3,1,4,5] = 4.
  Proof. reflexivity. Qed.
  Example test_countoddmembers2:    countoddmembers [0,2,4] = 0.
  Proof. reflexivity. Qed.
  Example test_countoddmembers3:    countoddmembers nil = 0.
  Proof. reflexivity. Qed.

  Fixpoint alternate (l1 l2 : natlist) : natlist :=
    match l1 with
    | nil => l2
    | h1 :: t1 => match l2 with
                  | nil => l1
                  | h2 :: t2 => cons h1 (cons h2 (alternate t1 t2))
                  end
    end.

  Example test_alternate1:        alternate [1,2,3] [4,5,6] = [1,4,2,5,3,6].
  Proof. reflexivity. Qed.
  Example test_alternate2:        alternate [1] [4,5,6] = [1,4,5,6].
  Proof. reflexivity. Qed.
  Example test_alternate3:        alternate [1,2,3] [4] = [1,4,2,3].
  Proof. reflexivity. Qed.
  Example test_alternate4:        alternate [] [20,30] = [20,30].
  Proof. reflexivity. Qed.

  Definition bag := natlist.

  Fixpoint count (v:nat) (s:bag) : nat :=
    match s with
    | nil => O
    | h :: t => match beq_nat h v with
                | true => S (count v t)
                | false => count v t
                end
    end.

  Example test_count1:              count 1 [1,2,3,1,4,1] = 3.
  Proof. reflexivity. Qed.
  Example test_count2:              count 6 [1,2,3,1,4,1] = 0.
  Proof. reflexivity. Qed.

  Definition sum : bag -> bag -> bag := app.

  Example test_sum1:              count 1 (sum [1,2,3] [1,4,1]) = 3.
  Proof. reflexivity. Qed.

  Definition add (v:nat) (s:bag) : bag := cons v s.

  Example test_add1:                count 1 (add 1 [1,4,1]) = 3.
  Proof. reflexivity. Qed.
  Example test_add2:                count 5 (add 1 [1,4,1]) = 0.
  Proof. reflexivity. Qed.

  Definition member (v:nat) (s:bag) : bool :=
    blt_nat 0 (count v s).

  Example test_member1:             member 1 [1,4,1] = true.
  Proof. reflexivity. Qed.
  Example test_member2:             member 2 [1,4,1] = false.
  Proof. reflexivity. Qed.

  Fixpoint remove_one (v:nat) (s:bag): bag :=
    match s with
    | nil => nil
    | h :: t => match beq_nat v h with
                | true => t
                | false => h :: (remove_one v t)
                end
    end.

  Example test_remove_one1:         count 5 (remove_one 5 [2,1,5,4,1]) = 0.
  Proof. reflexivity. Qed.
  Example test_remove_one2:         count 5 (remove_one 5 [2,1,4,1]) = 0.
  Proof. reflexivity. Qed.
  Example test_remove_one3:         count 4 (remove_one 5 [2,1,4,5,1,4]) = 2.
  Proof. reflexivity. Qed.
  Example test_remove_one4:
    count 5 (remove_one 5 [2,1,5,4,5,1,4]) = 1.
  Proof. reflexivity. Qed.

  Fixpoint remove_all (v:nat) (s:bag) : bag :=
    match s with
    | nil => nil
    | h :: t => match beq_nat v h with
                | true => remove_all v t
                | false => h :: (remove_all v t)
                end
    end.

  Example test_remove_all1:          count 5 (remove_all 5 [2,1,5,4,1]) = 0.
  Proof. reflexivity. Qed.
  Example test_remove_all2:          count 5 (remove_all 5 [2,1,4,1]) = 0.
  Proof. reflexivity. Qed.
  Example test_remove_all3:          count 4 (remove_all 5 [2,1,4,5,1,4]) = 2.
  Proof. reflexivity. Qed.
  Example test_remove_all4:          count 5 (remove_all 5 [2,1,5,4,5,1,4,5,1,4]) = 0.
  Proof. reflexivity. Qed.

  Fixpoint subset (s1:bag) (s2:bag) : bool :=
    match s1 with
    | nil => true
    | h :: t => match member h s2 with
                | true => subset t (remove_one h s2)
                | false => false
                end
    end.

  Example test_subset1:              subset [1,2] [2,1,4,1] = true.
  Proof. reflexivity. Qed.
  Example test_subset2:              subset [1,2,2] [2,1,4,1] = false.
  Proof. reflexivity. Qed.

  Theorem nil_app : forall l : natlist,
      [] ++ l = l.
  Proof.
    reflexivity.
  Qed.

  Theorem tl_length_pred : forall l : natlist,
      pred (length l) = length (tail l).
  Proof.
    intros l. destruct l as [| n l'].
    Case "l = nil".
      reflexivity.
    Case "l = cons n l'".
      reflexivity.
  Qed.

  Theorem app_ass : forall l1 l2 l3 : natlist,
      (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
  Proof.
    intros l1 l2 l3. induction l1 as [| n l'].
    Case "l1 = nil".
      reflexivity.
    Case "l1 = cons n l1".
      simpl. rewrite -> IHl'. reflexivity.
  Qed.

  Theorem app_length : forall l1 l2 : natlist,
      length (l1 ++ l2) = (length l1) + (length l2).
  Proof.
    intros l1 l2. induction l1 as [| n l'].
    Case "l = nil".
      reflexivity.
    Case "l = cons n l'".
      simpl.  rewrite -> IHl'. reflexivity.
  Qed.

  Fixpoint snoc (l :natlist) (v : nat) : natlist :=
    match l with
    | nil => [v]
    | h :: t => cons h (snoc t v)
    end.

  Fixpoint rev (l : natlist) : natlist :=
    match l with
    | nil => nil
    | h :: t => snoc (rev t) h
    end.

  Example test_rev1:            rev [1,2,3] = [3,2,1].
  Proof. reflexivity.  Qed.
  Example test_rev2:            rev nil = nil.
  Proof. reflexivity.  Qed.

  Theorem length_snoc : forall n : nat, forall l : natlist,
        length (snoc l n) = S (length l).
  Proof.
    intros n l. induction l as [| n' l'].
    Case "l = nil".
      reflexivity.
    Case "l = n' l'".
      simpl. rewrite -> IHl'. reflexivity.
  Qed.

  Theorem rev_length_firsttry : forall l : natlist,
      length (rev l) = length l.
  Proof.
    intros l. induction l as [| n l'].
    Case "l = nil".
      reflexivity.
    Case "l = n l'".
      simpl. rewrite -> length_snoc. rewrite <- IHl'. reflexivity.
  Qed.

  Theorem app_nil_end : forall l : natlist,
      l ++ [] = l.
  Proof.
    intros l. induction l as [| n l'].
    Case "l = nil".
      reflexivity.
    Case "l = n l'".
      simpl. rewrite -> IHl'. reflexivity.
  Qed.

  Theorem rev_snoc : forall l : natlist, forall n : nat,
      rev (snoc l n) = n :: (rev l).
  Proof.
    intros. induction l as [| n' l'].
    Case "l = nil".
      reflexivity.
    Case "l = n' l'".
      simpl. rewrite -> IHl'. simpl. reflexivity.
  Qed.

  Theorem rev_involutive : forall l : natlist,
      rev (rev l) = l.
  Proof.
    intros l. induction l as [| n l'].
    Case "l = nil".
      reflexivity.
    Case "l = n l'".
      simpl. rewrite -> rev_snoc. rewrite -> IHl'. reflexivity.
  Qed.

  Theorem snoc_append : forall l1 l2 : natlist, forall n : nat,
      snoc (l1 ++ l2) n = l1 ++ snoc l2 n.
  Proof.
    intros l1 l2 n. induction l1 as [| n' l1'].
    Case "l1 = nil".
      reflexivity.
    Case "l1 = n' ++ l1'".
      simpl. rewrite IHl1'. reflexivity.
  Qed.

  Theorem distr_rev : forall l1 l2 : natlist,
      rev (l1 ++ l2) = (rev l2) ++ (rev l1).
  Proof.
    intros l1 l2. induction l1 as [| n l1'].
    Case "l1 = nil".
      simpl. rewrite -> app_nil_end. reflexivity.
    Case "l1 = n l1'".
      simpl. rewrite IHl1'. rewrite snoc_append. reflexivity.
  Qed.

  Theorem app_ass4 : forall l1 l2 l3 l4 : natlist,
      l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
  Proof.
    intros l1 l2 l3 l4. rewrite -> app_ass. rewrite -> app_ass. reflexivity.
  Qed.

  Theorem snoc_appended : forall (l : natlist) (n : nat),
      snoc l n = l ++ [n].
  Proof.
    intros l n. induction l as [| n' l'].
    Case "l = nil".
      reflexivity.
    Case "l = n' :: l'".
      simpl. rewrite -> IHl'. reflexivity.
    Qed.

  Lemma nonzeros_length : forall l1 l2 : natlist,
      nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
  Proof.
    intros l1 l2. induction l1 as [| n' l1'].
    Case "l1 = nil".
      reflexivity.
    Case "l1 = n' :: l1'".
      simpl. induction n' as [| n''].
      rewrite -> IHl1'. reflexivity.
      simpl. rewrite IHl1'. reflexivity.
  Qed.

  Theorem count_member_nonzero : forall (s : bag),
      ble_nat 1 (count 1 (1 :: s)) = true.
  Proof.
    intros s. reflexivity.
  Qed.

  Theorem ble_n_Sn : forall n,
      ble_nat n (S n) = true.
  Proof.
    intros n. induction n as [| n'].
    Case "O".
      simpl. reflexivity.
    Case "S n".
      simpl. rewrite -> IHn'. reflexivity.
  Qed.

  Theorem remove_decreases_count: forall (s : bag),
      ble_nat (count 0 (remove_one 0 s)) (count 0 s) = true.
  Proof.
    intros s. induction s as [| n s'].
    Case "s = 0".
      reflexivity.
    Case "s = n :: s'".
      simpl. induction n as [| n'].
      simpl. rewrite -> ble_n_Sn. reflexivity.
      simpl. rewrite IHs'. reflexivity.
  Qed.

  Theorem rev_injective : forall (l1 l2 : natlist),
      rev l1 = rev l2 -> l1 = l2.
  Proof.
    intros l1 l2 H.
    rewrite <- rev_involutive.
    rewrite <- H.
    rewrite -> rev_involutive.
    reflexivity.
  Qed.

  Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

  Fixpoint index_bad (n : nat) (l : natlist) : nat :=
    match l with
    | nil => 42
    | a :: l' => match beq_nat n O with
                 | true => a
                 | false => index_bad (pred n) l'
                 end
    end.

  Fixpoint index (n : nat) (l : natlist) : natoption :=
    match l with
    | nil => None
    | a :: l' => match beq_nat n O with
                 | true => Some a
                 | false => index (pred n) l'
                 end
    end.

  Example test_index1 : index 0 [4,5,6,7] = Some 4.
  Proof. reflexivity. Qed.
  Example test_index2 :    index 3 [4,5,6,7]  = Some 7.
  Proof. reflexivity.  Qed.
  Example test_index3 :    index 10 [4,5,6,7] = None.
  Proof. reflexivity.  Qed.

  Definition option_elim (o : natoption) (d : nat) : nat :=
    match o with
    | Some n' => n'
    | None => d
    end.

  Definition hd_opt (l : natlist) : natoption :=
    match l with
    | nil => None
    | h :: t => Some h
    end.

  Example test_hd_opt1 : hd_opt [] = None.
  Proof. reflexivity. Qed.

  Example test_hd_opt2 : hd_opt [1] = Some 1.
  Proof. reflexivity. Qed.

  Example test_hd_opt3 : hd_opt [5,6] = Some 5.
  Proof. reflexivity. Qed.

  Theorem option_elim_hd : forall (l:natlist) (default:nat),
      hd default l = option_elim (hd_opt l) default.
  Proof.
    intros l default. induction l as [| n l'].
    Case "l = nil".
    reflexivity.
    Case "l = n :: l'".
    reflexivity.
  Qed.

  Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
    match l1 with
    | nil => match l2 with
             | nil => true
             | h :: t => false
             end
    | h1 :: t1 => match l2 with
                  | nil => false
                  | h2 :: t2 => match beq_nat h1 h2 with
                                | true => beq_natlist t1 t2
                                | false => false
                                end
                  end
    end.

  Example test_beq_natlist1 :   (beq_natlist nil nil = true).
  Proof. simpl. reflexivity. Qed.
  Example test_beq_natlist2 :   beq_natlist [1,2,3] [1,2,3] = true.
  Proof. simpl. reflexivity. Qed.
  Example test_beq_natlist3 :   beq_natlist [1,2,3] [1,2,4] = false.
  Proof. simpl. reflexivity. Qed.

  Theorem beq_natlist_refl : forall l:natlist,
      true = beq_natlist l l.
  Proof.
    intros l. induction l as [|n l'].
    Case "l = nil".
      reflexivity.
    Case "l = n :: l'".
      simpl. replace (beq_nat n n) with (true). rewrite <- IHl'. reflexivity.
      induction n as [| n'].
      reflexivity.
      simpl. rewrite <- IHn'. reflexivity.
  Qed.

  Theorem silly1 : forall (n m o p : nat),
      n = m  ->
      [n,o] = [n,p] ->
      [n,o] = [m,p].
  Proof.
    intros n m o p eq1 eq2.
    rewrite <- eq1.
    apply eq2.
  Qed.

  Theorem silly2 : forall (n m o p : nat),
      n = m  ->
      (forall (q r : nat), q = r -> [q,o] = [r,p]) ->
      [n,o] = [m,p].
  Proof.
    intros n m o p eq1 eq2.
    apply eq2. apply eq1.
  Qed.

  Theorem silly2a : forall (n m : nat),
      (n,n) = (m,m)  ->
      (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
      [n] = [m].
  Proof.
    intros n m eq1 eq2.
    apply eq2. apply eq1.
  Qed.

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

  Theorem silly3_firsttry : forall (n : nat),
      true = beq_nat n 5  ->
      beq_nat (S (S n)) 7 = true.
  Proof.
    intros n H.
    symmetry.
    simpl.
    apply H.
  Qed.

  Theorem rev_exercise1 : forall (l l' : natlist),
      l = rev l' ->
      l' = rev l.
  Proof.
    intros l l' H.
    rewrite -> H.
    symmetry.
    apply rev_involutive.
  Qed.

  Theorem app_ass' : forall l1 l2 l3 : natlist,
      (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
  Proof.
    intros l1. induction l1 as [ | n l1'].
    Case "l1 = nil".
      reflexivity.
    Case "l1 = n :: l1'".
      simpl. intros l2 l3. rewrite IHl1'. reflexivity.
  Qed.

  Theorem beq_nat_sym : forall (n m : nat),
      beq_nat n m = beq_nat m n.
  Proof.
    intros n. induction n as [| n'].
    Case "n = 0".
      destruct m.
        reflexivity.
        reflexivity.
    Case "n = S n'".
      destruct m.
        reflexivity.
        apply IHn'.
  Qed.
End NatList.

Module Dictionary.
  Inductive dictionary : Type :=
  | empty : dictionary
  | record : nat -> nat -> dictionary -> dictionary.

  Definition insert (key value : nat) (d : dictionary) : dictionary :=
    record key value d.

  Fixpoint find (key : nat) (d : dictionary) : option nat :=
    match d with
    | empty => None
    | record k v d' => if (beq_nat key k) then (Some v) else (find key d')
    end.

  Theorem dictionary_invariant1 : forall (d : dictionary) (k v: nat),
      (find k (insert k v d)) = Some v.
  Proof.
    intros.
    simpl.
    replace (beq_nat k k) with true.
    reflexivity.
    apply beq_nat_refl.
  Qed.

  Theorem dictionary_invariant2 : forall (d : dictionary) (m n o: nat),
      (beq_nat m n) = false -> (find m d) = (find m (insert n o d)).
  Proof.
    intros.
    simpl. rewrite H. reflexivity.
  Qed.
End Dictionary.

Definition beq_nat_sym := NatList.beq_nat_sym.


Add LoadPath "..".
Require Import Paths Fibrations Funext UnivalenceAxiom.

(* By using impredicative set and functional extensionality, we can
   *define* a higher inductive type and prove its non-dependent
   computation rule.  Here we do the interval. *)

Definition interval : Set := forall (X : Set) (a b : X) (p : a == b), X.

Definition zero : interval := fun X a b p => a.

Definition one : interval := fun X a b p => b.

Definition segment : zero == one.
Proof.
  apply funext_dep with (f := zero) (g := one); intro X.
  apply funext_dep; intro a.
  apply funext_dep; intro b.
  apply funext_dep; intro p.
  unfold zero, one; exact p.
Defined.

Definition interval_rec : forall (X : Set) (a b : X) (p : a == b), interval -> X :=
  fun X a b p i => i X a b p.

(* It's sort of stupid to use this interval to prove functional
   extensionality, since we already had to assume funext in order to
   define [segment], but it shows that the computation rules really do
   hold definitionally. *)

Definition funext_dep_statement_inSet :=
  forall (X : Set) (P : X -> Set) (f g : forall x : X, P x),
    (forall x : X, f x == g x) -> f == g.

Theorem interval_implies_funext_dep : funext_dep_statement_inSet.
Proof.
  intros X P f g p.
  set (mate := fun (i:interval) x => interval_rec _ _ _ (p x) i).
  path_via (mate zero).
  apply opposite.
  path_via (fun x => f x).
  apply funext_dep; auto.
  path_via (mate one).
  exact segment.
  path_via (fun x => g x).
  apply funext_dep; auto.
Defined.

Definition interval_compute_segment :
  forall (X : Set) (a b : X) (p : a == b),
    map (interval_rec X a b p) segment == p.
Proof.
  intros X a b p.
  unfold interval_rec.
  (* First we change this map into a bunch of [happly_dep]s. *)
  path_via (map ((fun z => z p) ○ (fun z => z b) ○ (fun z => z a) ○ (fun i => i X)) segment).
  do_compose_map.
  change (happly_dep (happly_dep (happly_dep (happly_dep segment X) a) b) p == p).
  unfold segment.
  (* Now each [happly_dep] matches up exactly with one occurrence of
     [funext_dep] in [segment].  Thus we just have to kill them off one
     by one from the inside out. *)
  repeat match goal with | |- ?s == ?t =>
    match s with
      | context cxt [ happly_dep (funext_dep ?P' _ _ ?p') ?x' ] =>
        let mid := context cxt [ p' x' ] in
          apply @concat with (y := mid);
            [ repeat (apply_happly; apply map);
              apply funext_dep_compute with (P := P') (x := x')
              | ]
    end
  end.
  auto.
Defined.

(*
Local Variables:
coq-prog-args: ("-emacs" "-impredicative-set")
End:
*)


(* Definitions of asymptotic notions such as polynomial and negligible functions, and related theory. *)

Set Implicit Arguments.

Require Import StdNat.

Definition polynomial (f : nat -> nat) :=
    exists x c1 c2, forall n,
      (f n <= c1 * expnat n x + c2)%nat.

Definition polynomial_nz(f : nat -> nat) :=
  exists x c1 c2,
    x > 0 /\ c1 > 0 /\ c2 > 0 /\
    forall n,
      (f n <= c1 * expnat n x + c2)%nat.

Theorem polynomial_nz_equiv :
  forall f,
    polynomial f ->
    polynomial_nz f.

  intuition.
  unfold polynomial, polynomial_nz in *.
  do 3 (destruct H).
  exists (S x).
  exists (S x0).
  exists (x0 + S x1).
  intuition.
  rewrite H.
  rewrite plus_assoc.
  eapply plus_le_compat; intuition.
  simpl.
  destruct (eq_nat_dec x 0).
  subst.
  simpl.
  repeat rewrite mult_1_r.
  rewrite <- plus_0_l at 1.
  eapply plus_le_compat; intuition.

  rewrite <- plus_0_l at 1.
  rewrite <- plus_0_r at 1.

  eapply plus_le_compat; intuition.
  eapply plus_le_compat; intuition.
  eapply mult_le_compat; intuition.
  destruct (eq_nat_dec n 0); subst.

  rewrite expnat_0;
    omega.

  rewrite <- mult_1_l at 1.
  eapply mult_le_compat; intuition.
Qed.

Theorem polynomial_plus :
  forall f1 f2 ,
    polynomial f1 ->
    polynomial f2 ->
    polynomial (fun n => f1 n + f2 n).

  intuition.

  apply polynomial_nz_equiv in H.
  apply polynomial_nz_equiv in H0.

  unfold polynomial, polynomial_nz in *.

  Ltac des :=
    match goal with
      | [H : exists _, _ |- _] => destruct H
    end.
  repeat des.
  intuition.
  exists (max x2 x).
  exists (x3 + x0).
  exists (x4 + x1).
  intuition.

  eapply le_trans.
  eapply plus_le_compat.
  eapply H6; trivial.
  eapply H7; trivial.
  rewrite mult_plus_distr_r.
  repeat rewrite plus_assoc.
  eapply plus_le_compat; trivial.
  rewrite plus_comm.
  rewrite plus_assoc.
  eapply plus_le_compat; trivial.
  rewrite plus_comm.
  eapply plus_le_compat;
    eapply mult_le_compat; intuition.

  eapply expnat_exp_le; intuition.
  eapply expnat_exp_le; intuition.
Qed.

Theorem polynomial_const :
  forall c,
    polynomial (fun n => c).

  intuition.
  unfold polynomial.
  exists 0.
  exists 0.
  exists c.
  intuition.
Qed.

Theorem polynomial_ident :
  polynomial (fun n => n).

  unfold polynomial.
  intuition.
  exists 1.
  exists 1.
  exists 0.
  intuition.
  simpl.
  omega.

Qed.

Theorem polynomial_mult :
  forall f1 f2 ,
    polynomial f1 ->
    polynomial f2 ->
    polynomial (fun n => f1 n * f2 n).

  intuition.
  apply polynomial_nz_equiv in H.
  apply polynomial_nz_equiv in H0.

  unfold polynomial, polynomial_nz in *.
  repeat des.
  intuition.
  exists (x + x2).
  exists (3 * (x3 * x0 * x4 * x1)).
  exists (x4 * x1).
  intuition.
  eapply le_trans.
  eapply mult_le_compat.
  eapply H6; intuition.
  eapply H7; intuition.
  repeat rewrite mult_plus_distr_l.
  repeat rewrite mult_plus_distr_r.

  rewrite plus_assoc.
  eapply plus_le_compat; trivial.

  rewrite expnat_plus.
  simpl.
  rewrite plus_0_r.
  repeat rewrite mult_plus_distr_r.
  rewrite plus_assoc.
  eapply plus_le_compat.
  eapply plus_le_compat.
  rewrite (mult_comm (expnat n x)).
  repeat rewrite mult_assoc.
  eapply mult_le_compat; intuition.
  rewrite mult_comm.
  rewrite mult_assoc.
  eapply mult_le_compat; intuition.
  rewrite <- mult_1_r at 1.
  rewrite <- mult_1_r at 1.
  eapply mult_le_compat; intuition.
  eapply mult_le_compat; intuition.
  rewrite mult_comm.
  intuition.

  destruct (eq_nat_dec n 0); subst.
  repeat rewrite expnat_0.
  simpl.
  repeat rewrite mult_0_r.
  intuition.
  trivial.
  trivial.
  rewrite (mult_comm (expnat n x)).
  repeat rewrite mult_assoc.
  eapply mult_le_compat; trivial.
  rewrite <- mult_1_r at 1.
  eapply mult_le_compat; trivial.
  rewrite <- mult_1_r at 1.
  eapply mult_le_compat; trivial.
  rewrite mult_comm.
  eapply mult_le_compat; trivial.
  rewrite <- mult_1_l at 1.
  eapply mult_le_compat; trivial.
  eapply expnat_ge_1.
  omega.

  destruct (eq_nat_dec n 0); subst.
  repeat rewrite expnat_0.
  simpl.
  repeat rewrite mult_0_r.
  intuition.
  trivial.
  trivial.
  rewrite (mult_comm (expnat n x)).
  repeat rewrite mult_assoc.
  rewrite <- mult_1_r at 1.
  eapply mult_le_compat; trivial.
  rewrite <- mult_assoc.
  rewrite (mult_comm (expnat n x2)).
  rewrite mult_assoc.
  eapply mult_le_compat; trivial.
  eapply mult_le_compat; trivial.
  rewrite <- mult_1_r at 1.
  eapply mult_le_compat; trivial.
  rewrite <- mult_1_r at 1.
  eapply mult_le_compat; trivial.
  eapply expnat_ge_1.
  omega.
Qed.

Require Import Rat.
Local Open Scope rat_scope.

Definition negligible(f : nat -> Rat) :=
  forall c, exists n, forall x (pf_nz : nz x),
    x > n ->
    ~ ((1 / expnat x c) <= f x)%rat.

Theorem negligible_eq :
  forall (f1 f2 : nat -> Rat),
    negligible f1 ->
    (forall n, f1 n == f2 n) ->
    negligible f2.

  intuition.
  unfold negligible in *.
  intuition.
  edestruct H.
  econstructor.
  intuition.
  eapply H1.
  eauto.
  rewrite H3.
  rewrite <- H0.
  intuition.

Qed.

Lemma negligible_le :
  forall f1 f2,
    (forall n, f2 n <= f1 n)%rat ->
    negligible f1 ->
    negligible f2.

  intuition.
  unfold negligible in *.
  intuition.
  edestruct H0.
  econstructor.
  intuition.
  eapply H1.
  eauto.
  rewrite H3.
  eauto.

Qed.

Lemma negligible_plus :
  forall f1 f2,
    negligible f1 ->
    negligible f2 ->
    negligible (fun n => f1 n + f2 n)%rat.

  unfold negligible in *.
  intuition.

  destruct (H (S c)).
  destruct (H0 (S c)).
  exists (max 1 (max x x0)).
  intuition.

  apply Nat.max_lub_lt_iff in H3.
  intuition.

  assert (1 / expnat x1 c <= 2/1 * (maxRat (f1 x1) (f2 x1)))%rat.
  eapply leRat_trans.
  eapply H4.

  eapply ratAdd_2_ratMax.

  assert (1 / expnat x1 (S c) <= RatIntro 1 (posnatMult (pos 2) (pos (expnat x1 c))))%rat.
  eapply leRat_terms; intuition.
  unfold natToPosnat, posnatToNat, posnatMult.
  eapply expnat_double_le.
  omega.

  unfold maxRat in *.
  case_eq (bleRat (f1 x1) (f2 x1)); intuition.
  rewrite H8 in H3.

  eapply H2.
  eapply le_lt_trans.
  eapply Max.le_max_r.
  eauto.

  rewrite H7.
  rewrite rat_mult_den.
  rewrite H3.
  rewrite <- ratMult_assoc.

  rewrite <- ratMult_num_den.
  rewrite num_dem_same_rat1.
  rewrite ratMult_1_l.
  intuition.
  unfold posnatMult, natToPosnat, posnatToNat.
  omega.

  rewrite H8 in H3.
  eapply H1.
  eapply le_lt_trans.
  eapply Max.le_max_l.
  eauto.

  rewrite H7.
  rewrite rat_mult_den.
  rewrite H3.
  rewrite <- ratMult_assoc.

  rewrite <- ratMult_num_den.
  rewrite num_dem_same_rat1.
  rewrite ratMult_1_l.
  intuition.
  unfold posnatMult, natToPosnat, posnatToNat.
  omega.
Qed.

(* We need several facts about arithmetic to show that an inverse exponential function is negligible. *)
Local Open Scope nat_scope.
Theorem double_log_plus_3_le_h :
  forall y x,
    y = log2 x ->
    y >= 4 ->
    2 * y + 3 <= x.

  induction y; intuition; simpl in *.
  rewrite plus_0_r in *.

  assert (S (y + S y + 3)  =
    (y + y + 3) + 2).
  omega.
  rewrite H1.

  destruct (eq_nat_dec y 3).
  subst.
  assert (x >= pow 2 4).
  rewrite H.
  eapply Nat.log2_spec.
  destruct (eq_nat_dec x 0).
  subst.
  rewrite log2_0 in H.
  omega.
  omega.

  eapply le_trans.
  Focus 2.
  eapply H2.
  simpl.
  omega.

  assert ( y + y + 3 <= div2 x).
  eapply IHy.

  symmetry.
  apply log2_div2.
  trivial.
  omega.

  assert (2 <= div2 x).
  assert (2 = div2 4).
  trivial.
  rewrite H3.
  eapply div2_le_mono.
  eapply le_trans.
  Focus 2.
  eapply Nat.log2_le_lin.
  destruct (eq_nat_dec 0 x); subst.
  rewrite log2_0 in H.
  omega.
  omega.
  omega.

  eapply le_trans.
  eapply plus_le_compat.
  eapply H2.

  eapply H3.

  eapply div2_ge_double.

Qed.

Theorem S_log_square_lt_h :
  forall y x,
    y = log2 x ->
    6 <= log2 x->
    S y * S y <= x.

  induction y; intuition; simpl in *.
  assert (y = log2 (div2 x)).
  symmetry.
  eapply log2_div2.
  trivial.

  rewrite (mult_comm _ (S (S y))).
  simpl.
  rewrite (mult_comm _ (S y)) in IHy.
  simpl in *.

  assert ( S (S (y + S (S (y + (y + (y + y * y)))))) =
    (S (y + (y + y * y))) + (2 * y + 3)).
  omega.
  rewrite H2.
  clear H2.

  destruct (eq_nat_dec (log2 x) 6).

  assert (y = 5).
  assert (S y = 6).
  rewrite H.
  trivial.
  omega.
  rewrite H2.
  simpl.
  assert (x >= pow 2 6).
  rewrite <- e.

  eapply Nat.log2_spec.

  destruct (eq_nat_dec x 0).
  subst.
  rewrite log2_0 in H.
  omega.
  omega.

  eapply le_trans.
  Focus 2.
  eapply H3.
  simpl.
  omega.

  assert ( S (y + (y + y * y)) <= div2 x).
  eapply IHy.
  trivial.
  omega.

  assert (2 * y + 3 <= div2 x).
  eapply double_log_plus_3_le_h; trivial.
  omega.
  eapply le_trans.
  eapply plus_le_compat.
  eapply H2.
  eapply H3.

  eapply div2_ge_double.

Qed.

Theorem S_log_square_lt :
  forall x,
    pow 2 6 <= x->
    S (log2 x) * S (log2 x) <= x.

  intuition.
  eapply S_log_square_lt_h; trivial.
  eapply le_trans.
  Focus 2.
  eapply Nat.log2_le_mono.
  eapply H.
  rewrite Nat.log2_pow2; omega.
Qed.

Theorem log_square_lt :
  forall x,
    pow 2 6 <= x->
    log2 x * log2 x < x.

  intuition.

  assert (log2 x < S (log2 x)).
  omega.
  eapply lt_le_trans.

  eapply mult_lt_compat.
  eapply H0.
  eapply H0.
  eapply S_log_square_lt.
  trivial.
Qed.

Theorem poly_lt_exp_ge_6 :
  forall c x,
    x >= (pow 2 c) ->
    x >= (pow 2 6) ->
    pow x c < pow 2 x.

  intuition.

  specialize (Nat.log2_spec_alt); intuition.
  destruct (H1 x).
  eapply lt_le_trans.
  Focus 2.
  eapply H.
  eapply (expnat_2_ge_1 c).

  intuition.
  (* This case split probably isn't necessary *)
  destruct (eq_nat_dec x0 0).
  rewrite e in H3.
  rewrite plus_0_r in *.
  rewrite H3.
  rewrite <- Nat.pow_mul_r.

  eapply Nat.pow_lt_mono_r.
  omega.
  rewrite <- H3.

  assert (c <= log2 x).
  eapply (@Nat.pow_le_mono_r_iff 2).
  omega.
  rewrite <- H3.
  trivial.
  eapply le_lt_trans.
  eapply mult_le_compat.
  eapply le_refl.
  eapply H4.

  eapply log_square_lt.
  eapply le_trans.
  Focus 2.
  eapply H0.
  eapply Nat.pow_le_mono_r.
  omega.
  omega.

  destruct (eq_nat_dec c 0).
  rewrite e.
  simpl.
  eapply le_lt_trans.
  assert (1 <= expnat 2 0).
  trivial.
  eapply H4.
  eapply Nat.pow_lt_mono_r.
  omega.
  omega.

  assert (expnat x c < expnat (2 ^ S (log2 x)) c).
  eapply Nat.pow_lt_mono_l.
  omega.
  eapply log2_spec.
  omega.
  eapply lt_le_trans.
  eapply H4.

  rewrite <- Nat.pow_mul_r.
  eapply Nat.pow_le_mono_r.
  omega.
  assert (c <= S (log2 x)).
  eapply (@Nat.pow_le_mono_r_iff 2).
  omega.
  eapply le_trans.
  eapply H.

  eapply lt_le_weak.
  eapply log2_spec.
  omega.

  eapply le_trans.
  eapply mult_le_compat.
  eapply le_refl.
  eapply H6.

  eapply S_log_square_lt.
  eapply le_trans.
  Focus 2.
  eapply H0.
  eapply Nat.pow_le_mono_r.
  omega.
  omega.
Qed.

Theorem poly_lt_exp :
  forall c,
    exists x,
      forall y, y >= x ->
        expnat y c < expnat 2 y.

  intuition.
  exists (expnat 2 (max c 6)).
  intuition.
  eapply poly_lt_exp_ge_6.
  eapply le_trans.
  Focus 2.
  eapply H.
  eapply Nat.pow_le_mono_r.
  omega.
  eapply Max.le_max_l.

  eapply le_trans.
  Focus 2.
  eapply H.
  eapply Nat.pow_le_mono_r.
  omega.
  eapply Max.le_max_r.
Qed.

Theorem negligible_exp_den :
  negligible (fun n => 1 / expnat 2 n)%rat.

  unfold negligible in *.

  intuition.
  destruct (poly_lt_exp c).
  exists x.
  intuition.

  eapply (rat_num_not_le).
  eapply H1.

  unfold posnatToNat, natToPosnat.
  eapply H.
  omega.
Qed.

Theorem negligible_const_mult :
  forall (n : nat) d f,
    negligible f ->
    negligible (fun x => (RatIntro n d) * (f x))%rat.

  unfold negligible in *.
  intuition.

  destruct (eq_nat_dec n 0).
  subst.
  exists 1.
  intuition.

  assert ((1 / expnat x c) == 0)%rat.

  eapply leRat_0_eq.
  rewrite H1.
  rewrite rat_num_0.
  rewrite ratMult_0_l.
  intuition.

  eapply rat_num_nz; [idtac | eauto].
  omega.

  destruct (H (c + n)).
  exists (x + n)%nat.
  intuition.
  eapply H0.
  omega.

  assert (1 / expnat x0 (c + n) == RatIntro 1 (pos  (expnat x0 c)) * RatIntro 1 (pos (expnat x0 n)))%rat.
  rewrite <- ratMult_num_den.
  eapply eqRat_terms.
  symmetry.
  eapply mult_1_r.
  unfold natToPosnat, posnatToNat, posnatMult.
  rewrite expnat_plus.
  trivial.

  rewrite H3.
  rewrite H2.
  rewrite ratMult_comm.
  rewrite <- ratMult_assoc.

  eapply leRat_trans.
  Focus 2.
  eapply eqRat_impl_leRat.
  rewrite <- ratMult_1_l.
  eapply eqRat_refl.
  eapply ratMult_leRat_compat; intuition.

  eapply rat_le_1.
  destruct d.
  unfold natToPosnat, posnatToNat, posnatMult.
  rewrite mult_comm.
  eapply mult_le_compat.

  eapply le_trans.
  eapply le_expnat_2.
  eapply expnat_base_le.
  omega.
  omega.

Qed.

Theorem negligible_mult_ident :
  forall f,
    negligible f ->
    negligible (fun x => (x / 1) * (f x))%rat.

  unfold negligible in *.
  intuition.

  destruct (H (S c)).
  exists x.
  intuition.
  eapply H0.
  omega.
  simpl.

  assert ( (RatIntro 1 (natToPosnat (expnat_nz (S c) pf_nz)))  ==
    RatIntro 1 (posnatMult (pos x0) (pos expnat x0 c)) )%rat.
  eapply eqRat_terms; trivial.

  simpl in *.
  rewrite H3.
  rewrite ratMult_denom.
  rewrite H2.
  rewrite <- ratMult_assoc.
  rewrite <- ratMult_num_den.
  rewrite num_dem_same_rat1.
  rewrite ratMult_1_l.
  intuition.
  unfold natToPosnat, posnatToNat, posnatMult.
  omega.
Qed.

Theorem negligible_exp :
  forall z,
    negligible (fun n => expnat n z / expnat 2 n)%rat.

  induction z; simpl in *; intuition.

  eapply negligible_exp_den.

  eapply negligible_eq.
  eapply negligible_mult_ident.
  eauto.
  intuition.
  rewrite <- ratMult_num_den.
  eapply eqRat_terms; trivial.
  unfold posnatToNat, natToPosnat, posnatMult.
  eapply mult_1_l.

Qed.

Theorem negligible_const_num :
  forall k,
    negligible (fun n => k / expnat 2 n)%rat.

  intuition.
  eapply negligible_eq.
  eapply (@negligible_const_mult k (pos 1)).
  eapply negligible_exp_den.
  intuition.
  rewrite <- ratMult_num_den.
  eapply eqRat_terms.
  eapply mult_1_r.
  unfold natToPosnat, posnatToNat, posnatMult.
  eapply mult_1_l.
Qed.

Theorem negligible_poly_num :
  forall f,
    polynomial f ->
    negligible (fun n => f n / expnat 2 n)%rat.

  intuition.
  unfold polynomial in *.
  do 3 destruct H.
  eapply negligible_le.
  intuition.
  eapply leRat_terms.
  eapply H.
  eapply le_refl.

  eapply negligible_eq.
  eapply negligible_plus.
  eapply negligible_const_mult.
  eapply negligible_exp.
  eapply negligible_const_num.

  intuition.
  symmetry.

  rewrite ratAdd_num.
  eapply ratAdd_eqRat_compat.
  rewrite <- ratMult_num_den.
  eapply eqRat_terms.
  eauto.
  assert (posnatToNat (pos expnat 2 n) = posnatToNat (posnatMult (pos 1) (pos expnat 2 n))).
  unfold natToPosnat, posnatToNat, posnatMult.
  symmetry.
  eapply mult_1_l.
  eapply H0.
  eapply eqRat_refl.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_NCdistinct.
Require Export GeoCoq.Elements.OriginalProofs.proposition_28A.
Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearparallel.
Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelsymmetric.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_28D :
   forall B D E G H,
   BetS E G H -> CongA E G B G H D -> OS B D G H ->
   Par G B H D.
Proof.
intros.
assert (nCol G H B) by (conclude_def OS ).
assert (nCol G H D) by (conclude_def OS ).
assert (neq H D) by (forward_using lemma_NCdistinct).
assert (neq D H) by (conclude lemma_inequalitysymmetric).
assert (neq G B) by (forward_using lemma_NCdistinct).
assert (neq B G) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists A, (BetS B G A /\ Cong G A G B)) by (conclude lemma_extension);destruct Tf as [A];spliter.
assert (BetS A G B) by (conclude axiom_betweennesssymmetry).
let Tf:=fresh in
assert (Tf:exists C, (BetS D H C /\ Cong H C H D)) by (conclude lemma_extension);destruct Tf as [C];spliter.
assert (BetS C H D) by (conclude axiom_betweennesssymmetry).
assert (Par A B C D) by (conclude proposition_28A).
assert (Col D H C) by (conclude_def Col ).
assert (Col C D H) by (forward_using lemma_collinearorder).
assert (neq H D) by (forward_using lemma_NCdistinct).
assert (Par A B H D) by (conclude lemma_collinearparallel).
assert (Par H D A B) by (conclude lemma_parallelsymmetric).
assert (Col B G A) by (conclude_def Col ).
assert (Col A B G) by (forward_using lemma_collinearorder).
assert (Par H D G B) by (conclude lemma_collinearparallel).
assert (Par G B H D) by (conclude lemma_parallelsymmetric).
close.
Qed.

End Euclid.


Require Import List.
(* Require Import Arith. *)

Definition length_tl :
  forall (A : Type) (xs : list A), {n : nat | n = length xs}.
Proof.
  intros A xs.

  refine (
      let fix iter n ys :=
          match ys with
            | nil      => n
            | _ :: ys' => iter (S n) ys'
          end
      in exist _ (iter 0 xs) _
    ).

  info assert (Hiter: forall ys n, iter n ys = n + iter 0 ys).
  info (induction ys; simpl).

  apply plus_n_O.

  intro n.
  rewrite (IHys (S n)), (IHys 1).
  apply plus_n_Sm.

  induction xs; simpl.
  reflexivity.

  rewrite <- IHxs.
  apply Hiter.
Qed.


Require Import NArith.

Generalizable All Variables.

Definition lift `(f:A->B) : option A -> option B :=
  fun x => match x with
        | Some v => Some(f v)
        | None => None
        end.

Definition decr :=
  lift (fun x => (x - 1)%N).

Definition incr :=
  lift (fun x => (x + 1)%N).


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2019   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.R_sqrt.
Require Reals.Rbasic_fun.
Require Reals.Rtrigo_def.
Require Reals.Rtrigo1.
Require Reals.Ratan.
Require BuiltIn.
Require real.Real.
Require real.Abs.
Require real.Square.

Require Import Reals.

(* Why3 comment *)
(* cos is replaced with (Reals.Rtrigo_def.cos x) by the coq driver *)

(* Why3 comment *)
(* sin is replaced with (Reals.Rtrigo_def.sin x) by the coq driver *)

(* Why3 goal *)
Lemma Pythagorean_identity :
  forall (x:Reals.Rdefinitions.R),
  (((Reals.RIneq.Rsqr (Reals.Rtrigo_def.cos x)) +
    (Reals.RIneq.Rsqr (Reals.Rtrigo_def.sin x)))%R
   = 1%R).
Proof.
intros x.
rewrite Rplus_comm.
apply sin2_cos2.
Qed.

(* Why3 goal *)
Lemma Cos_le_one :
  forall (x:Reals.Rdefinitions.R),
  ((Reals.Rbasic_fun.Rabs (Reals.Rtrigo_def.cos x)) <= 1%R)%R.
Proof.
intros x.
apply Abs.Abs_le.
apply COS_bound.
Qed.

(* Why3 goal *)
Lemma Sin_le_one :
  forall (x:Reals.Rdefinitions.R),
  ((Reals.Rbasic_fun.Rabs (Reals.Rtrigo_def.sin x)) <= 1%R)%R.
Proof.
intros x.
apply Abs.Abs_le.
apply SIN_bound.
Qed.

(* Why3 goal *)
Lemma Cos_0 : ((Reals.Rtrigo_def.cos 0%R) = 1%R).
Proof.
apply cos_0.
Qed.

(* Why3 goal *)
Lemma Sin_0 : ((Reals.Rtrigo_def.sin 0%R) = 0%R).
Proof.
apply sin_0.
Qed.

(* Why3 comment *)
(* pi is replaced with Reals.Rtrigo1.PI by the coq driver *)

(* Why3 goal *)
Lemma Pi_double_precision_bounds :
  ((7074237752028440 / 2251799813685248)%R < Reals.Rtrigo1.PI)%R /\
  (Reals.Rtrigo1.PI < (7074237752028441 / 2251799813685248)%R)%R.
Proof.
replace PI with (4 * (PI / 4))%R by field.
rewrite <- atan_1.
admit. (* to avoid a dependency on CoqInterval *)
(*
Require Import Interval_tactic.
split ; interval with (i_prec 55).
*)
Admitted.

(* Why3 goal *)
Lemma Cos_pi : ((Reals.Rtrigo_def.cos Reals.Rtrigo1.PI) = (-1%R)%R).
Proof.
apply cos_PI.
Qed.

(* Why3 goal *)
Lemma Sin_pi : ((Reals.Rtrigo_def.sin Reals.Rtrigo1.PI) = 0%R).
Proof.
apply sin_PI.
Qed.

(* Why3 goal *)
Lemma Cos_pi2 :
  ((Reals.Rtrigo_def.cos ((5 / 10)%R * Reals.Rtrigo1.PI)%R) = 0%R).
Proof.
replace (5 / 10 * PI)%R with (PI / 2)%R by field.
apply cos_PI2.
Qed.

(* Why3 goal *)
Lemma Sin_pi2 :
  ((Reals.Rtrigo_def.sin ((5 / 10)%R * Reals.Rtrigo1.PI)%R) = 1%R).
Proof.
replace (5 / 10 * PI)%R with (PI / 2)%R by field.
apply sin_PI2.
Qed.

(* Why3 goal *)
Lemma Cos_plus_pi :
  forall (x:Reals.Rdefinitions.R),
  ((Reals.Rtrigo_def.cos (x + Reals.Rtrigo1.PI)%R) =
   (-(Reals.Rtrigo_def.cos x))%R).
Proof.
intros x.
apply neg_cos.
Qed.

(* Why3 goal *)
Lemma Sin_plus_pi :
  forall (x:Reals.Rdefinitions.R),
  ((Reals.Rtrigo_def.sin (x + Reals.Rtrigo1.PI)%R) =
   (-(Reals.Rtrigo_def.sin x))%R).
Proof.
intros x.
apply neg_sin.
Qed.

(* Why3 goal *)
Lemma Cos_plus_pi2 :
  forall (x:Reals.Rdefinitions.R),
  ((Reals.Rtrigo_def.cos (x + ((5 / 10)%R * Reals.Rtrigo1.PI)%R)%R) =
   (-(Reals.Rtrigo_def.sin x))%R).
Proof.
intros x.
rewrite cos_sin.
replace (PI / 2 + (x + 5 / 10 * PI))%R with (x + PI)%R by field.
apply neg_sin.
Qed.

(* Why3 goal *)
Lemma Sin_plus_pi2 :
  forall (x:Reals.Rdefinitions.R),
  ((Reals.Rtrigo_def.sin (x + ((5 / 10)%R * Reals.Rtrigo1.PI)%R)%R) =
   (Reals.Rtrigo_def.cos x)).
Proof.
intros x.
rewrite cos_sin.
apply f_equal.
field.
Qed.

(* Why3 goal *)
Lemma Cos_neg :
  forall (x:Reals.Rdefinitions.R),
  ((Reals.Rtrigo_def.cos (-x)%R) = (Reals.Rtrigo_def.cos x)).
Proof.
intros x.
apply cos_neg.
Qed.

(* Why3 goal *)
Lemma Sin_neg :
  forall (x:Reals.Rdefinitions.R),
  ((Reals.Rtrigo_def.sin (-x)%R) = (-(Reals.Rtrigo_def.sin x))%R).
Proof.
intros x.
apply sin_neg.
Qed.

(* Why3 goal *)
Lemma Cos_sum :
  forall (x:Reals.Rdefinitions.R) (y:Reals.Rdefinitions.R),
  ((Reals.Rtrigo_def.cos (x + y)%R) =
   (((Reals.Rtrigo_def.cos x) * (Reals.Rtrigo_def.cos y))%R -
    ((Reals.Rtrigo_def.sin x) * (Reals.Rtrigo_def.sin y))%R)%R).
Proof.
intros x y.
apply cos_plus.
Qed.

(* Why3 goal *)
Lemma Sin_sum :
  forall (x:Reals.Rdefinitions.R) (y:Reals.Rdefinitions.R),
  ((Reals.Rtrigo_def.sin (x + y)%R) =
   (((Reals.Rtrigo_def.sin x) * (Reals.Rtrigo_def.cos y))%R +
    ((Reals.Rtrigo_def.cos x) * (Reals.Rtrigo_def.sin y))%R)%R).
Proof.
intros x y.
apply sin_plus.
Qed.

(* Why3 goal *)
Lemma tan_def :
  forall (x:Reals.Rdefinitions.R),
  ((Reals.Rtrigo1.tan x) =
   ((Reals.Rtrigo_def.sin x) / (Reals.Rtrigo_def.cos x))%R).
Proof.
intros x.
apply eq_refl.
Qed.

(* Why3 comment *)
(* atan is replaced with (Reals.Ratan.atan x) by the coq driver *)

(* Why3 goal *)
Lemma Tan_atan :
  forall (x:Reals.Rdefinitions.R),
  ((Reals.Rtrigo1.tan (Reals.Ratan.atan x)) = x).
Proof.
intros x.
apply atan_right_inv.
Qed.