Require Import List Arith ZArith Uint63.
From cube_puzzle Require Import cube_explore.

Definition remain (result :  intmap.t int * nat + list (int * int) * intmap.t int) :
          list (int * int)  :=
  match result with
  | inr (w, db) =>
    starting_positions (new_ones w db)
  | inl _ => nil
  end.

Definition one_more_step (res : intmap.t int * nat + list (int * int) * intmap.t int) :
    intmap.t int * nat + list (int * int) * intmap.t int :=
  match res with
  | inr(w, db) =>
    inr(bfs.bfs_aux _ _ _ bfs_find bfs_add reverse_steps w nil db)
  | inl _ => inr(nil, empty)
  end.

Definition get_db (res : intmap.t int * nat + list (int * int) * intmap.t int) :
    intmap.t int :=
  match res with
  | inl(db, _) => db
  | inr(_, db) => db
  end.

Definition get_w (res : intmap.t int * nat + list (int * int) * intmap.t int) :
    list (int * int) :=
  match res with inl _ => nil | inr(w, _) => w end.

Definition res17 := cube_explore 17.

Definition db17 := get_db res17.

Definition res18 := one_more_step res17.

Definition res19 := one_more_step res18.

Time Compute hd (0, 0) (remain res17).
(* This returns (118872, 4)  after 560 seconds on nardis, recomputing
   takes 4 seconds(res4 is memorized, the processing of remain is redone *)

Import String.
Compute print_state 118872.

Time Compute state_left 118872.
(* This returns 53336 *)

Time Compute List.length (make_solution 53336 db17).
(* This returns 16 *)
(* So 118872 is at depth 17, as it is not in db17, but it moves in one
  step to 53336 which is in db17 and at depth 16. *)

(* TODO: complain about the huge time for this definition :
Definition res18 :=
  match res17 with
  | inr(w, db) =>
    inr(bfs.bfs_aux _ _ _ bfs_find bfs_add reverse_steps w nil db)
  | inl _ => inr(nil, empty)
  end.
*)

Time Compute List.length (get_w res18).
(* The answer is 4216, the computation takes 4.2 seconds. *)
Time Compute hd (0, 0) (remain res18).
Compute List.length (remain res18).
(* There is no starting position at depth 18. *)
Time Compute List.length (new_ones (get_w res18) (get_db res18)).
(* But there are 136 position that are not at depth 17 or less. *)

Time Compute List.length (get_w res19).
Time Compute List.length (new_ones (get_w res19) (get_db res19)).
(* There are no positions that are not at depth 18 or less.
  In other words, all positions are at depth 18 or less.  but
  since there are no starting position at depth 18, the deeper
  positions are at depth 17.
*)

Compute List.length (make_solution 118872 (get_db res19)).
(* This reiterates that the length of path for 118872 is 17 *)
Import ListNotations.

Definition hard17 :=
  map of_Z (nodup Z.eq_dec (map (fun x => to_Z (fst x))
          (remain res17))).
Compute hard17.
(* The answer is
[118872; 301578; 301322; 886029; 565417; 565401; 45224; 365581; 20684;
        365833; 838661; 626777; 821771; 643145; 118812; 86108; 446601; 636937;
        988429; 172171; 249937; 932362; 964618; 407818; 902405; 901389; 696467;
        694285; 172195; 364683; 700429; 996106; 700584; 176289; 700553; 372873;
        176259; 700457; 372749; 569489; 987356; 692393; 15112; 364813; 692493;
        333069; 496901; 610460; 432649; 741592; 774296; 269066; 249089; 430603;
        364937; 692617; 565425; 497925; 372761; 494853; 493837; 905477; 708873;
        379141; 628761; 741529; 643097; 446489; 819379; 643153; 741465; 432153;
        86045; 430109; 626955; 268555; 924171; 428555; 237619; 432139; 628747;
        931851; 643083; 446475] *)

Compute List.length hard17.
(* So there are only 84 different positions that require 17 steps to solve.
   modulo symmetry, that gives 21.  Let's list the one
    whose positions are in the top left corner. *)

Import Bool.
Definition top_left_hard :=
  filter (fun s => (get_position s =? 0) ||
                         (get_position s =? 1) ||
                         (get_position s =? 4) ||
                         (get_position s =? 5)) hard17.
Compute List.length top_left_hard.

Compute fold_right (fun s buffer =>
  (print_position (get_position s) ++
  print_board (get_board s) ++ string_return ++
  buffer)%string) ""%string top_left_hard.

Compute get_position 102610.
Compute print_board (get_board 102610).
Compute ((get_board 102610 >> 1) land 1).
(* If I write

Time Compute make_solution 0x0620E
     match result with inl(t, _) => t | _ => empty end.

Then the computation is unreasonably long. *)
Time Compute make_solution 0x0620E all_positions.
(* This one still takes 8 mn? *)

(* The next computation takes not time, because all_positions is already
  memorized. *)
Time Compute make_solution 0xF0C63 all_positions.


From isla Require Import opsem.

Definition a4 : isla_trace :=
  WriteReg "R3" [] (RegVal_Base (Val_Bits (BV 64%N 0x0%Z))) Mk_annot :t:
  Smt (DeclareConst 46%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
  Smt (DefineConst 47%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 46%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 47%Z)) Mk_annot :t:
  tnil
.


Require Import Coq.ZArith.BinInt.
Require Import Coq.Classes.EquivDec.
Require Import Coq.ZArith.Zcomplements.

Require Import compcert.lib.Integers.
Require Import VST.floyd.sublist.

Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.graph_model.
Require Export CertiGraph.graph.FiniteGraph.
Require Import CertiGraph.graph.path_lemmas.

Section Mathematical_Edge_Labeled_Graph_Model.

  Coercion pg_lg: LabeledGraph >-> PreGraph.
  Coercion lg_gg: GeneralGraph >-> LabeledGraph.

  Local Open Scope Z_scope.

  Definition V : Type := Z.
  Definition E : Type := V * V * Z. (* src, dst, out-edge-number *)
  Definition DV: Type := list V. (* the vertices I point to *)
  Definition DE : Type := Z. (* the cost itself *)
  Definition DG: Type := unit.

  Instance V_EqDec : EqDec V eq.
  Proof.
    hnf. intros. apply Z.eq_dec.
  Defined.

  Instance E_EqDec: EqDec E eq.
  Proof.
    apply (prod_eqdec (prod_eqdec V_EqDec V_EqDec) Z.eq_dec).
  Defined.

  Context {size : Z}.
  (* The instantiator will have to supply the number of vertices *)

  (* This is the basic LabeledGraph for all our Edge-Labeled representations. *)
  Definition EdgeLabLG := (@LabeledGraph V E _ _ DV DE DG).
  (* We need some further restrictions, which we will place
     in the GeneralGraph's soundness condition.
   *)

  (* Each field of the class is a "plugin"
     which further restricts various aspects of the graph
   *)
  Class SoundEdgeLab (g: EdgeLabLG) :=
    {
    sr: (* size_representable *)
      0 < size <= Int.max_signed;
    vm: (* vvalid_meaning *)
      forall v, vvalid g v <-> 0 <= v < size;
    em: (* evalid_meaning *)
      forall src dst out,
        evalid g (src, dst, out) <->
        Int.min_signed <= elabel g (src, dst, out) <= Int.max_signed /\
        0 <= out < Zlength (vlabel g src) /\
        Znth out (vlabel g src) = dst;
    ese: (* evalid_strong_evalid *)
      forall e, evalid g e -> strong_evalid g e;
    esf: (* edge_src_fst *)
      forall e, src g e = fst (fst e);
    eds: (* edge_dst_snd *)
      forall e, dst g e = snd (fst e);
    fin:
      FiniteGraph g
    }.

  (* Academic example of how to instantiate the above *)
  Definition EdgeLabGG := (GeneralGraph V E DV DE DG (fun g => SoundEdgeLab g)).
  (* In reality, clients may want to:
     1. create a new soundness condition where one of the
        plugins is "SounndEdgeLab" above
     2. add further program-specific restrictions in
        other plugins
     3. use this new accreted soundness condition to
        build their GeneralGraph, as shown above.
   *)

  (* Getters for the plugins *)

  Definition size_representable (g: EdgeLabGG) :=
    @sr g ((@sound_gg _ _ _ _ _ _ _ _ g)).

  Definition vvalid_meaning (g: EdgeLabGG) :=
    @vm g ((@sound_gg _ _ _ _ _ _ _ _ g)).

  Definition evalid_meaning (g: EdgeLabGG) :=
    @em g ((@sound_gg _ _ _ _ _ _ _ _ g)).

  Definition evalid_strong_evalid (g: EdgeLabGG) :=
    @ese g ((@sound_gg _ _ _ _ _ _ _ _ g)).

  Definition edge_src_fst (g: EdgeLabGG) :=
    @esf g ((@sound_gg _ _ _ _ _ _ _ _ g)).

  Definition edge_dst_snd (g: EdgeLabGG) :=
    @eds g ((@sound_gg _ _ _ _ _ _ _ _ g)).

  Definition finGraph (g: EdgeLabGG) :=
    @fin g ((@sound_gg _ _ _ _ _ _ _ _ g)).

  (* Some lemmas from the above soundness plugins *)

  Lemma valid_path_app_cons:
    forall (g: EdgeLabGG) src links2u u i o,
      valid_path g (src, links2u) ->
      pfoot g (src, links2u) = u ->
      strong_evalid g (u,i, o) ->
      valid_path g (src, links2u +:: (u,i, o)).
  Proof.
    intros.
    apply valid_path_app.
    split; [assumption|].
    simpl; split; trivial.
    destruct H1.
    rewrite (edge_src_fst g); simpl; assumption.
  Qed.

  Lemma path_ends_app_cons:
    forall (g: EdgeLabGG) a b c o a' a2b,
      a = a' ->
      path_ends g (a, a2b) a b ->
      path_ends g (a, a2b +:: (b, c, o)) a' c.
  Proof.
    split; trivial.
    rewrite pfoot_last.
    rewrite (edge_dst_snd g); trivial.
  Qed.

  Lemma step_in_range:
    forall (g: EdgeLabGG) x x0,
      valid_path g x ->
      In x0 (snd x) ->
      vvalid g (src g x0).
  Proof.
    intros.
    rewrite (surjective_pairing x) in H.
    pose proof (valid_path_strong_evalid g _ _ _ H H0).
    destruct H1 as [? [? _]]. trivial.
  Qed.

  Lemma step_in_range2:
    forall (g: EdgeLabGG) x x0,
      valid_path g x ->
      In x0 (snd x) ->
      vvalid g (dst g x0).
  Proof.
    intros.
    rewrite (surjective_pairing x) in H.
    pose proof (valid_path_strong_evalid g _ _ _ H H0).
    destruct H1 as [? [_ ?]]. trivial.
  Qed.

End Mathematical_Edge_Labeled_Graph_Model.


Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Op.
Require Import NeedDomain.
Require Import RTL.

(** Neededness analysis for IA32 operators *)

Definition op1 (nv: nval) := nv :: nil.
Definition op2 (nv: nval) := nv :: nv :: nil.

Definition needs_of_condition (cond: condition): list nval :=
  match cond with
  | Cmaskzero n | Cmasknotzero n => op1 (maskzero n)
  | _ => nil
  end.

Definition needs_of_addressing (addr: addressing) (nv: nval): list nval :=
  match addr with
  | Aindexed n => op1 (modarith nv)
  | Aindexed2 n => op2 (modarith nv)
  | Ascaled sc ofs => op1 (modarith (modarith nv))
  | Aindexed2scaled sc ofs => op2 (modarith nv)
  | Aglobal s ofs => nil
  | Abased s ofs => op1 (modarith nv)
  | Abasedscaled sc s ofs => op1 (modarith (modarith nv))
  | Ainstack ofs => nil
  end.

Definition needs_of_operation (op: operation) (nv: nval): list nval :=
  match op with
  | Omove => op1 nv
  | Ointconst n => nil
  | Ofloatconst n => nil
  | Oindirectsymbol id => nil
  | Ocast8signed => op1 (sign_ext 8 nv)
  | Ocast8unsigned => op1 (zero_ext 8 nv)
  | Ocast16signed => op1 (sign_ext 16 nv)
  | Ocast16unsigned => op1 (zero_ext 16 nv)
  | Oneg => op1 (modarith nv)
  | Osub => op2 (default nv)
  | Omul => op2 (modarith nv)
  | Omulimm n => op1 (modarith nv)
  | Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv)
  | Oand => op2 (bitwise nv)
  | Oandimm n => op1 (andimm nv n)
  | Oor => op2 (bitwise nv)
  | Oorimm n => op1 (orimm nv n)
  | Oxor => op2 (bitwise nv)
  | Oxorimm n => op1 (bitwise nv)
  | Onot => op1 (bitwise nv)
  | Oshl => op2 (default nv)
  | Oshlimm n => op1 (shlimm nv n)
  | Oshr => op2 (default nv)
  | Oshrimm n => op1 (shrimm nv n)
  | Oshrximm n => op1 (default nv)
  | Oshru => op2 (default nv)
  | Oshruimm n => op1 (shruimm nv n)
  | Ororimm n => op1 (ror nv n)
  | Oshldimm n => op1 (default nv)
  | Olea addr => needs_of_addressing addr nv
  | Onegf | Oabsf => op1 (default nv)
  | Oaddf | Osubf | Omulf | Odivf => op2 (default nv)
  | Osingleoffloat => op1 (singleoffloat nv)
  | Ointoffloat | Ofloatofint => op1 (default nv)
  | Omakelong => op2 (default nv)
  | Olowlong | Ohighlong => op1 (default nv)
  | Ocmp c => needs_of_condition c
  end.

Definition operation_is_redundant (op: operation) (nv: nval): bool :=
  match op with
  | Ocast8signed => sign_ext_redundant 8 nv
  | Ocast8unsigned => zero_ext_redundant 8 nv
  | Ocast16signed => sign_ext_redundant 16 nv
  | Ocast16unsigned => zero_ext_redundant 16 nv
  | Oandimm n => andimm_redundant nv n
  | Oorimm n => orimm_redundant nv n
  | Osingleoffloat => singleoffloat_redundant nv
  | _ => false
  end.

Ltac InvAgree :=
  match goal with
  | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree
  | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree
  | _ => idtac
  end.

Ltac TrivialExists :=
  match goal with
  | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto
  | _ => idtac
  end.

(** [CompCertX:test-compcert-param-memory] We create section [WITHMEM] and associated
 contexts to parameterize the proof over the memory model. *)
Section WITHMEM.
Context `{memory_model: Mem.MemoryModel}.

Section SOUNDNESS.

Variable ge: genv.
Variable sp: block.
Variables m m': mem.
Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p.

Lemma needs_of_condition_sound:
  forall cond args b args',
  eval_condition cond args m = Some b ->
  vagree_list args args' (needs_of_condition cond) ->
  eval_condition cond args' m' = Some b.
Proof.
  intros. destruct cond; simpl in H;
  try (eapply default_needs_of_condition_sound; eauto; fail);
  simpl in *; FuncInv; InvAgree.
- eapply maskzero_sound; eauto.
- destruct (Val.maskzero_bool v i) as [b'|] eqn:MZ; try discriminate.
  erewrite maskzero_sound; eauto.
Qed.

Lemma needs_of_addressing_sound:
  forall (ge: genv) sp addr args v nv args',
  eval_addressing ge (Vptr sp Int.zero) addr args = Some v ->
  vagree_list args args' (needs_of_addressing addr nv) ->
  exists v',
     eval_addressing ge (Vptr sp Int.zero) addr args' = Some v'
  /\ vagree v v' nv.
Proof.
  unfold needs_of_addressing; intros.
  destruct addr; simpl in *; FuncInv; InvAgree; TrivialExists;
  auto using add_sound, mul_sound with na.
  apply add_sound; auto with na. apply add_sound; rewrite modarith_idem; auto.
  apply add_sound; auto. apply add_sound; rewrite modarith_idem; auto with na.
  apply mul_sound; rewrite modarith_idem; auto with na.
Qed.

Lemma needs_of_operation_sound:
  forall op args v nv args',
  eval_operation ge (Vptr sp Int.zero) op args m = Some v ->
  vagree_list args args' (needs_of_operation op nv) ->
  nv <> Nothing ->
  exists v',
     eval_operation ge (Vptr sp Int.zero) op args' m' = Some v'
  /\ vagree v v' nv.
Proof.
  unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail);
  simpl in *; FuncInv; InvAgree; TrivialExists.
- apply sign_ext_sound; auto. compute; auto.
- apply zero_ext_sound; auto. omega.
- apply sign_ext_sound; auto. compute; auto.
- apply zero_ext_sound; auto. omega.
- apply neg_sound; auto.
- apply mul_sound; auto.
- apply mul_sound; auto with na.
- apply and_sound; auto.
- apply andimm_sound; auto.
- apply or_sound; auto.
- apply orimm_sound; auto.
- apply xor_sound; auto.
- apply xor_sound; auto with na.
- apply notint_sound; auto.
- apply shlimm_sound; auto.
- apply shrimm_sound; auto.
- apply shruimm_sound; auto.
- apply ror_sound; auto.
- eapply needs_of_addressing_sound; eauto.
- apply singleoffloat_sound; auto.
- destruct (eval_condition c args m) as [b|] eqn:EC; simpl in H2.
  erewrite needs_of_condition_sound by eauto.
  subst v; simpl. auto with na.
  subst v; auto with na.
Qed.

Lemma operation_is_redundant_sound:
  forall op nv arg1 args v arg1' args',
  operation_is_redundant op nv = true ->
  eval_operation ge (Vptr sp Int.zero) op (arg1 :: args) m = Some v ->
  vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) ->
  vagree v arg1' nv.
Proof.
  intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst.
- apply sign_ext_redundant_sound; auto. omega.
- apply zero_ext_redundant_sound; auto. omega.
- apply sign_ext_redundant_sound; auto. omega.
- apply zero_ext_redundant_sound; auto. omega.
- apply andimm_redundant_sound; auto.
- apply orimm_redundant_sound; auto.
- apply singleoffloat_redundant_sound; auto.
Qed.

End SOUNDNESS.

End WITHMEM.


Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.DownUpSemantics_Fail.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Lemma sound_sepcon_comm {L: Language} {minL: MinimumLanguage L} {sepconL: SepconLanguage L} {wandL: WandLanguage L} {MD: Model} {kMD: KripkeModel MD} (M: Kmodel) {R: Relation (Kworlds M)} {po_R: PreOrder Krelation} {J: Join (Kworlds M)} {SA: SeparationAlgebra (Kworlds M)} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {kminSM: KripkeMinimumSemantics L MD M SM} {dusSM: DownUpSemantics_Fail.SeparatingSemantics L MD M SM}:
  forall x y: expr,
    forall m,
      KRIPKE: M, m |= x * y --> y * x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0 |- *; intros.
  destruct H0 as [m0 [m1 [m2 [? [? [? ?]]]]]].
  exists m0, m2, m1.
  split; [| split; [| split]]; auto.
  apply join_comm; auto.
Qed.

Lemma sound_sepcon_assoc {L: Language} {minL: MinimumLanguage L} {iffpL: IffLanguage L} {sepconL: SepconLanguage L} {wandL: WandLanguage L} {MD: Model} {kMD: KripkeModel MD} (M: Kmodel) {R: Relation (Kworlds M)} {po_R: PreOrder Krelation} {J: Join (Kworlds M)} {SA: SeparationAlgebra (Kworlds M)} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {kminSM: KripkeMinimumSemantics L MD M SM} {kiffpSM: KripkeIffSemantics L MD M SM} {dusSM: DownUpSemantics_Fail.SeparatingSemantics L MD M SM}:
  forall x y z: expr,
    forall m,
      KRIPKE: M, m |= x * (y * z) <--> (x * y) * z.
Proof.
  intros.
  apply sat_iffp.
  split; intros.
  + rewrite sat_sepcon in H0.
    destruct H0 as [m0 [m1 [m2 [? [? [? ?]]]]]].
    (* fail *)
Abort.


From Undecidability.FOL Require Import Syntax.Facts Semantics.Tarski.FullFacts Semantics.FiniteTarski.Full.
Require Import Undecidability.Synthetic.Definitions.
Require Import Vector Lia.

Set Default Goal Selector "!".

Section Signature.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Definition exclosure phi : form :=
    let (N, _) := find_bounded phi in exist_times N phi.

  Lemma exclosure_closed phi :
    bounded 0 (exclosure phi).
  Proof.
    unfold exclosure. destruct find_bounded as [N HN]. now apply exists_close_form.
  Qed.

  Definition form2cform phi : cform :=
    exist _ (exclosure phi) (exclosure_closed phi).

  Theorem reduction :
    FSATd ⪯ FSATdc.
  Proof.
    exists form2cform. intros phi; unfold FSATdc; cbn.
    unfold exclosure. destruct find_bounded as [N HN].
    split; intros (D & M & rho & H1 & H2 & H3 & H4); exists D, M.
    - exists rho. repeat split; trivial. eapply subst_exist_sat; eauto.
    - apply subst_exist_sat2 in H4 as [sigma H]. exists sigma. repeat split; trivial.
  Qed.
End Signature.


Require Import RamifyCoq.sample_mark.env_dispose_bi.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.spanning_tree.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.msl_application.Graph.
Require Import RamifyCoq.msl_application.GraphBi.
Require Import RamifyCoq.msl_application.GraphBi_Mark.
Require Import RamifyCoq.data_structure.spatial_graph_dispose_bi.
Require Import RamifyCoq.data_structure.spatial_graph_unaligned_bi_VST.
Require Import RamifyCoq.floyd_ext.share.
Require RamifyCoq.graph.weak_mark_lemmas.
Import RamifyCoq.graph.weak_mark_lemmas.WeakMarkGraph.

Require Import VST.msl.wand_frame.
Require Import VST.floyd.reassoc_seq.
Require Import VST.floyd.field_at_wand.

Local Coercion Graph_LGraph: Graph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion Graph_GeneralGraph: Graph >-> GeneralGraph.
Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Notation vertices_at sh g P := (@vertices_at _ _ _ _ _ _ (@SGP pSGG_VST bool unit (sSGG_VST sh)) _ g P).
Notation graph sh x g := (@reachable_vertices_at _ _ _ _ _ _ _ _ _ _ (@SGP pSGG_VST bool unit (sSGG_VST sh)) _ x g).
Notation Graph := (@Graph pSGG_VST bool unit unit).
Existing Instances MGS biGraph maGraph finGraph RGF.

Definition mark_spec :=
 DECLARE _mark
  WITH sh: wshare, g: Graph, x: pointer_val
  PRE [ _x OF (tptr (Tstruct _Node noattr))]
          PROP  (weak_valid g x)
          LOCAL (temp _x (pointer_val_val x))
          SEP   (graph sh x g)
  POST [ Tvoid ]
        EX g': Graph,
        PROP (mark x g g')
        LOCAL()
        SEP (graph sh x g').

Definition spanning_spec :=
  DECLARE _spanning
  WITH sh: wshare, g: Graph, x: pointer_val
  PRE [ _x OF (tptr (Tstruct _Node noattr))]
          PROP  (vvalid g x; fst (fst (vgamma g x)) = false)
          LOCAL (temp _x (pointer_val_val x))
          SEP   (graph sh x g)
  POST [ Tvoid ]
        EX g': Graph,
        PROP (spanning_tree g x g')
        LOCAL()
        SEP (vertices_at sh (reachable g x) g').

Definition dispose_spec :=
  DECLARE _dispose
  WITH sh: wshare, g: Graph, x: pointer_val
  PRE [ _x OF (tptr (Tstruct _Node noattr))]
          PROP  (weak_valid g x)
          LOCAL (temp _x (pointer_val_val x))
          SEP   (!!is_tree g x && graph sh x g)
  POST [ Tvoid ]
        PROP ()
        LOCAL()
        SEP (emp).

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog nil gv
  POST [ tint ] main_post prog nil gv.

Definition Gprog : funspecs := ltac:(with_library prog [mark_spec ; spanning_spec ; dispose_spec ; main_spec]).

Lemma graph_local_facts: forall sh x (g: Graph), vvalid g x -> @derives mpred Nveric (graph sh x g) (valid_pointer (pointer_val_val x)).
Proof.
  intros.
  eapply derives_trans; [apply (@va_reachable_root_stable_ramify pSGG_VST _ _ _ (sSGG_VST sh) g x (vgamma g x)); auto |].
  simpl vertex_at. unfold trinode. entailer!.
Qed.

Lemma graph_left_local_facts: forall sh x (g: Graph) d l r, vvalid g x -> vgamma g x = (d, l, r) -> graph sh x g |-- valid_pointer (pointer_val_val l).
Proof.
  intros.
  eapply derives_trans; [apply (@graph_ramify_aux1_left pSGG_VST (sSGG_VST sh) g x d l r); auto | ].
  assert (weak_valid g l) by (apply (gamma_left_weak_valid g x d l r); auto). destruct H1.
  - simpl in H1. subst l. simpl pointer_val_val. apply sepcon_valid_pointer1. entailer!.
  - apply sepcon_valid_pointer1. apply graph_local_facts; auto.
Qed.

Lemma graph_right_local_facts: forall sh x (g1 g2: Graph) l l' r,
    vvalid g1 x -> vgamma g1 x = (true, l, r) -> vvalid g2 x -> vgamma g2 x = (true, l', r) -> edge_spanning_tree g1 (x, L) g2 ->
    vertices_at sh (reachable g1 x) g2 |-- valid_pointer (pointer_val_val r).
Proof.
  intros.
  eapply derives_trans; [apply (@graph_ramify_aux1_right pSGG_VST (sSGG_VST sh) g1 g2 x l r); auto | ].
  assert (weak_valid g2 r) by (apply (gamma_right_weak_valid g2 x true l' r); auto). destruct H4.
  - simpl in H4. subst r. simpl pointer_val_val. apply sepcon_valid_pointer1. entailer!.
  - apply sepcon_valid_pointer1. apply graph_local_facts; auto.
Qed.

Lemma body_spanning: semax_body Vprog Gprog f_spanning spanning_spec.
Proof.
  start_function.
  remember (vgamma g x) as dlr eqn:?H.
  destruct dlr as [[d l] r].
  assert (d = false) by (simpl in H1; auto).
  subst.
  assert (Hisptr: isptr (pointer_val_val x)). {
    destruct x. simpl. auto.
    apply (valid_not_null g) in H. exfalso; auto.
    reflexivity.
  }
  localize [data_at sh node_type (Vint (Int.repr 0), (pointer_val_val l, pointer_val_val r))
                    (pointer_val_val x)].
  forward. 1: entailer!; destruct l; simpl; auto.
  forward. 1: entailer!; destruct r; simpl; auto.
  forward.
  unlocalize [graph sh x (Graph_vgen g x true)].
  1: {
    apply (@root_update_ramify _ (sSGG_VST sh) g x _ (false, l, r) (true, l, r)); auto.
    eapply Graph_vgen_vgamma; eauto.
  }
  (* if (l) { *)
  symmetry in H1.
  pose proof Graph_vgen_true_mark1 g x _ _ H1 H.
  assert (H_GAMMA_g1: vgamma (Graph_vgen g x true) x = (true, l, r)) by
   (eapply Graph_vgen_vgamma; eauto).
  assert (vvalid (Graph_vgen g x true) x) by
      (destruct H2 as [[? _] _]; apply H2; auto).
  forget (Graph_vgen g x true) as g1.
  forward_if
    (EX g2: Graph,
     PROP  (edge_spanning_tree g1 (x, L) g2)
     LOCAL (temp _r (pointer_val_val r);
            temp _l (pointer_val_val l);
            temp _x (pointer_val_val x))
     SEP (vertices_at sh (reachable g1 x) g2)).
  - apply denote_tc_test_eq_split. 2: entailer!. apply (graph_left_local_facts _ _ _ true l r); auto.
  - (* root_mark = l -> m; *)
    localize [data_at sh node_type (vgamma2cdata (vgamma g1 l)) (pointer_val_val l)].
    remember (vgamma g1 l) as dlr in |-*.
    destruct dlr as [[dd ll] rr].
    forward. simpl vgamma2cdata at 1.
    replace (if dd then 1 else 0) with (if node_pred_dec (marked g1) l then 1 else 0).
    2: {
      destruct (node_pred_dec (marked g1)); destruct dd; auto; symmetry in Heqdlr.
      apply vgamma_is_false in Heqdlr. simpl in a. unfold unmarked in Heqdlr. hnf in Heqdlr.
      unfold Ensembles.In in Heqdlr. simpl in Heqdlr. apply Heqdlr in a. exfalso; auto.
      apply vgamma_is_true in Heqdlr. exfalso; auto.
    }
    rewrite Heqdlr. clear dd ll rr Heqdlr.
    unlocalize [graph sh x g1].
    + destruct (vgamma g1 l) as [[dd ll] rr] eqn:? .
      assert (vvalid g1 l). {
        assert (weak_valid g1 l) by (eapply gamma_left_weak_valid; eauto).
        destruct H5; auto. hnf in H5. subst. exfalso; intuition.
      } unfold vgamma2cdata.
      apply (@va_reachable_internal_stable_ramify pSGG_VST _ _ _ (sSGG_VST sh) g1 x l (dd, ll, rr)); auto.
      apply (gamma_left_reachable_included g1 _ _ _ _ H3 H_GAMMA_g1 l).
      apply reachable_by_refl; auto.
    + (* if (root_mark == 0) { *)
      Opaque node_pred_dec.
      Opaque pSGG_VST.
      (* remember (if node_pred_dec (marked g1) l then 1 else 0). *)
      forward_if
        (EX g2: Graph,
         PROP  (edge_spanning_tree g1 (x, L) g2)
         LOCAL (temp _r (pointer_val_val r);
                temp _l (pointer_val_val l);
                temp _x (pointer_val_val x))
         SEP (vertices_at sh (reachable g1 x) g2)).
      * (* spanning(l); *)
        Transparent node_pred_dec.
        Transparent pSGG_VST.
        destruct (node_pred_dec (marked g1) l). 1: inversion H5.
        localize [graph sh l g1].
        assert (vvalid g1 l). {
          apply gamma_left_weak_valid in H1. 2: auto.
          destruct H2.
          rewrite (weak_valid_si _ _ _ H2) in H1.
          destruct H1. 2: auto.
          hnf in H1. subst l.
          simpl in H4. exfalso; auto.
        } assert (fst (fst (vgamma g1 l)) = false). {
          simpl in n.
          simpl. destruct (vlabel g1 l) eqn:? ; auto.
          symmetry in Heqb. apply n in Heqb. inversion Heqb.
        } forward_call (sh, g1, l).
        Intros g'.
        unlocalize [vertices_at sh (reachable g1 x) g'] using g' assuming H8.
        1: apply (@graph_ramify_aux1_left _ (sSGG_VST sh) g1 x true l r); auto.
        Exists g'. entailer!.
        assert (l = dst g1 (x, L)) by (simpl in H_GAMMA_g1; inversion H_GAMMA_g1; auto).
        unfold edge_spanning_tree. if_tac; subst l; [exfalso |]; auto.
      * (* x -> l = 0; *)
        destruct (node_pred_dec (marked g1) l). 2: exfalso; auto.
        localize [data_at sh node_type (Vint (Int.repr 1), (pointer_val_val l, pointer_val_val r)) (pointer_val_val x)].
        forward.
        unlocalize [vertices_at sh (reachable g1 x) (Graph_gen_left_null g1 x)].
        1: apply (@graph_gen_left_null_ramify _ (sSGG_VST sh) g1 x true l r); auto.
        Exists (Graph_gen_left_null g1 x).
        entailer!.
        apply (edge_spanning_tree_left_null g1 x true l r); auto.
  - forward. Exists g1. entailer!. 2: apply derives_refl. apply edge_spanning_tree_invalid.
    + apply (@left_valid _ _ _ _ _ _ g1 _ _) in H3; auto.
    + intro. apply (valid_not_null g1 l).
      * assert (l = dst g1 (x, L)) by (simpl in H_GAMMA_g1; inversion H_GAMMA_g1; auto). rewrite H9. apply H8.
      * hnf. destruct l. 1: inversion H4. auto.
  - (* if (r) { *)
    Intros g2.
    assert (vvalid g2 x) by (rewrite <- (edge_spanning_tree_left_vvalid g1 g2 x); auto).
    destruct (edge_spanning_tree_left_vgamma g1 g2 x l r H3 H_GAMMA_g1 H4) as [l' H_GAMMA_g2].
    forward_if
      (EX g3: Graph,
       PROP  (edge_spanning_tree g2 (x, R) g3)
       LOCAL (temp _r (pointer_val_val r);
              temp _l (pointer_val_val l);
              temp _x (pointer_val_val x))
       SEP (vertices_at sh (reachable g1 x) g3)).
    + apply denote_tc_test_eq_split. 2: entailer!. apply (graph_right_local_facts _ _ _ _ l l' r); auto.
    + (* root_mark = r -> m; *)
      localize [data_at sh node_type (vgamma2cdata (vgamma g2 r)) (pointer_val_val r)].
      remember (vgamma g2 r) as dlr in |-*. destruct dlr as [[dd ll] rr].
      forward. simpl vgamma2cdata at 1.
      replace (if dd then 1 else 0) with (if node_pred_dec (marked g2) r then 1 else 0).
      2: {
        destruct (node_pred_dec (marked g2)); destruct dd; auto; symmetry in Heqdlr.
        apply vgamma_is_false in Heqdlr. simpl in a. unfold unmarked in Heqdlr. hnf in Heqdlr.
        unfold Ensembles.In in Heqdlr. simpl in Heqdlr. apply Heqdlr in a. exfalso; auto.
        apply vgamma_is_true in Heqdlr. exfalso; auto.
      } rewrite Heqdlr. clear dd ll rr Heqdlr.
      unlocalize [vertices_at sh (reachable g1 x) g2].
      * destruct (vgamma g2 r) as [[dd ll] rr] eqn:? .
        assert (vvalid g1 r). {
          assert (weak_valid g1 r) by (eapply gamma_right_weak_valid; eauto).
          destruct H7; auto. hnf in H7; subst. exfalso; intuition.
        } unfold vgamma2cdata; apply (@vertices_at_ramif_1_stable _ _ _ _ _ _ _ (SGA_VST sh) _ _ r (dd, ll, rr)); auto.
        apply (gamma_right_reachable_included g1 _ _ _ _ H3 H_GAMMA_g1 r).
        apply reachable_by_refl; auto.
      * (* if (root_mark == 0) { *)
        Opaque node_pred_dec.
        Opaque pSGG_VST.
        forward_if
          (EX g3: Graph,
           PROP  (edge_spanning_tree g2 (x, R) g3)
           LOCAL (temp _r (pointer_val_val r);
                  temp _l (pointer_val_val l);
                  temp _x (pointer_val_val x))
           SEP (vertices_at sh (reachable g1 x) g3)).
        -- (* spanning(r); *)
          Transparent node_pred_dec.
          Transparent pSGG_VST.
          destruct (node_pred_dec (marked g2) r). 1: inversion H7.
          localize [graph sh r g2].
          assert (vvalid g1 r). {
            assert (weak_valid g1 r) by (eapply gamma_right_weak_valid; eauto).
            destruct H8; auto. hnf in H8; subst. exfalso; intuition.
          }
          assert (vvalid g2 r) by (rewrite <- (edge_spanning_tree_left_vvalid g1 g2 x); auto).
          assert (fst (fst (vgamma g2 r)) = false). {
            simpl in n |-* . destruct (vlabel g2 r) eqn:? ; auto.
            symmetry in Heqb. apply n in Heqb. exfalso; auto.
          }
          forward_call (sh, g2, r).
          Intros g3.
          unlocalize [vertices_at sh (reachable g1 x) g3] using g3 assuming H11.
          1: apply (@graph_ramify_aux1_right _ (sSGG_VST sh) g1 g2 x l r); auto.
          Exists g3. entailer!.
          assert (r = dst g2 (x, R)) by (simpl in H_GAMMA_g2; inversion H_GAMMA_g2; auto).
          unfold edge_spanning_tree. if_tac; subst r; [exfalso |]; auto.
        -- (* x -> r = 0; *)
          destruct (node_pred_dec (marked g2) r). 2: exfalso; auto.
          localize [data_at sh node_type (Vint (Int.repr 1), (pointer_val_val l', pointer_val_val r)) (pointer_val_val x)].
          forward.
          unlocalize [vertices_at sh (reachable g1 x) (Graph_gen_right_null g2 x)].
          1: apply (@graph_gen_right_null_ramify _ (sSGG_VST sh) g1 g2 x true l' r); auto.
          Exists (Graph_gen_right_null g2 x).
          entailer!. apply (edge_spanning_tree_right_null g2 x true l' r); auto.
    + forward. Exists g2. entailer!. apply edge_spanning_tree_invalid.
      * apply (@right_valid _ _ _ _ _ _ g2 _ _) in H5; auto.
      * intro. apply (valid_not_null g2 r).
        -- assert (r = dst g2 (x, R)) by (simpl in H_GAMMA_g2; inversion H_GAMMA_g2; auto). rewrite H11. apply H10.
        -- hnf. destruct r. 1: inversion H6. auto.
    + (* return *)
      Intros g3. forward. Exists g3. entailer!.
      * apply (edge_spanning_tree_spanning_tree g g1 g2 g3 x l r); auto.
      * destruct H2. apply derives_refl'. apply vertices_at_Same_set. rewrite H2; reflexivity.
Qed. (* original: 5500 sec, VST 2.*: 8.91 secs *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O X Y Z Zprime Xprime : Universe, ((wd_ O X /\ (wd_ X Xprime /\ (wd_ Z O /\ (wd_ O Zprime /\ (wd_ Z Zprime /\ (wd_ O Xprime /\ (wd_ O Z /\ (col_ Z O Zprime /\ (col_ Y Xprime Zprime /\ (col_ O X Xprime /\ col_ Xprime O Z)))))))))) -> col_ Z O X)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** * Coinductive trees (cotrees) algebraic CPO. *)

Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import
  Basics
  Equivalence
  Lia
  Morphisms
  Equality
.
Local Open Scope program_scope.
Local Open Scope equiv_scope.

From Coq Require Import
  Reals
  Raxioms
  Rpower
  FunctionalExtensionality
  ClassicalChoice
.

From algco Require Import
  aCPO
  axioms
  cpo
  misc
  order
  tactics
.

Local Open Scope order_scope.

Create HintDb cotree.

(** This is just to match the paper. In Coq, we use the Inductive and
    CoInductive mechanisms to define the actual types rather than
    taking the lfp and gfp of this functor explicitly (although the
    latter could be done but I believe it still requires the use of
    Inductive and CoInductive). *)
Variant cotreeF (X I A : Type) : Type :=
  | cobotF : cotreeF X I A
  | coleafF : A -> cotreeF X I A
  | conodeF : (I -> X) -> cotreeF X I A.

(** The type of cotrees. *)
CoInductive cotree (I A : Type) : Type :=
| cobot : cotree I A
| coleaf : A -> cotree I A
| conode : (I -> cotree I A) -> cotree I A.

(** The canonical divergent cotree. *)
CoFixpoint omega {I A} : cotree I A := conode (fun _ => omega).

Definition unf {I A} (t : cotree I A) :=
  match t with
  | cobot => cobot
  | coleaf x => coleaf x
  | conode k => conode k
  end.

Lemma unf_eq {I A} (t : cotree I A) : t = unf t.
Proof. destruct t; auto. Qed.

(** Cotrees with finite index type form an algebraic CPO, meaning that
  there is a basis of compact elements that can be used to approximate
  cotrees (see, e.g., chapter 5 of the Gunter book). We obtain the
  basis by taking the least fixed point of the tree functor rather
  than the greatest. *)

(** Finite trees. The finite trees serve as a compact basis for the
  cotrees when the index type I is finite. *)
Inductive atree (I A : Type) : Type :=
| abot : atree I A
| aleaf : A -> atree I A
| anode : (I -> atree I A) -> atree I A.

Definition bintree (A : Type) : Type := atree bool A.

Fixpoint atree_map {I A B} (f : A -> B) (t : atree I A) : atree I B :=
  match t with
  | abot => abot
  | aleaf x => aleaf (f x)
  | anode k => anode (atree_map f ∘ k)
  end.

Inductive atree_le {I A} : atree I A -> atree I A -> Prop :=
| atree_le_bot : forall t, atree_le abot t
| atree_le_leaf : forall x, atree_le (aleaf x) (aleaf x)
| atree_le_node : forall f g,
    (forall x, atree_le (f x) (g x)) ->
    atree_le (anode f) (anode g).

#[global]
  Instance Reflexive_atree_le {I A} : Reflexive (@atree_le I A).
Proof. intro t; induction t; constructor; auto. Qed.

#[global]
  Instance Transitive_atree_le {I A} : Transitive (@atree_le I A).
Proof.
  intro x; induction x; intros y z Hxy Hyz.
  - constructor.
  - inv Hxy; auto.
  - inv Hxy; inv Hyz; constructor; eauto.
Qed.

#[global]
  Instance PreOrder_atree_le {I A} : PreOrder (@atree_le I A).
Proof. constructor; typeclasses eauto. Qed.

#[global]
  Instance OType_atree {I A} : OType (atree I A) :=
  { leq := atree_le }.

#[global]
  Program
  Instance PType_atree {I A} : PType (atree I A) :=
  { bot := abot }.
Next Obligation. constructor. Qed.

Lemma atree_le_antisym {I A} (a b : atree I A) :
  a ⊑ b ->
  b ⊑ a ->
  a = b.
Proof.
  intro H; induction H; intro Hle; inv Hle; auto.
  replace g with f; auto; ext x; apply H0, H3.
Qed.

Lemma equ_atree {I A} (a b : atree I A) :
  a === b -> a = b.
Proof. intro Heq; apply atree_le_antisym; apply Heq. Qed.

Fixpoint tprefix {I A} (n : nat) (t : cotree I A) : atree I A :=
  match n with
  | O => abot
  | S n' => match t with
            | cobot => abot
            | coleaf x => aleaf x
            | conode k => anode (tprefix n' ∘ k)
            end
  end.

Fixpoint coprefix {I A} (n : nat) (t : cotree I A) : cotree I A :=
  match n with
  | O => cobot
  | S n' => match t with
            | cobot => cobot
            | coleaf x => coleaf x
            | conode k => conode (coprefix n' ∘ k)
            end
  end.

Fixpoint tinj {I A} (t : atree I A) : cotree I A :=
  match t with
  | abot => cobot
  | aleaf x => coleaf x
  | anode f => conode (tinj ∘ f)
  end.

Lemma tinj_tprefix_coprefix {I A} (t : cotree I A) (n : nat) :
  tinj (tprefix n t) = coprefix n t.
Proof.
  revert t; induction n; intro t; simpl; auto.
  destruct t; simpl; auto.
  - unfold compose; f_equal; ext i; apply IHn.
Qed.

CoInductive cotree_le {I A} : cotree I A -> cotree I A -> Prop :=
| cotree_le_bot : forall t, cotree_le cobot t
| cotree_le_leaf : forall x, cotree_le (coleaf x) (coleaf x)
| cotree_le_node : forall f g,
    (forall x, cotree_le (f x) (g x)) ->
    cotree_le (conode f) (conode g).

#[global]
  Instance Reflexive_cotree_le {I A} : Reflexive (@cotree_le I A).
Proof. cofix CH; intros []; constructor; eauto. Qed.

#[global]
  Instance Transitive_cotree_le {I A} : Transitive (@cotree_le I A).
Proof.
  cofix CH; intros x y z Hxy Hyz.
  inv Hxy.
  - constructor.
  - inv Hyz; constructor.
  - inv Hyz; constructor; eauto.
Qed.

#[global]
  Instance PreOrder_cotree_le {I A} : PreOrder (@cotree_le I A).
Proof. constructor; typeclasses eauto. Qed.

#[global]
  Instance OType_cotree {I A} : OType (cotree I A) :=
  { leq := cotree_le }.

#[global]
  Program
  Instance PType_cotree {I A} : PType (cotree I A) :=
  { bot := cobot }.
Next Obligation. constructor. Qed.

#[global]
  Instance monotone_conode {I A} : Proper (leq ==> leq) (@conode I A).
Proof. intros a b Hab; constructor; auto. Qed.
#[global] Hint Resolve monotone_conode : cotree.

Lemma continuous_conode {I A} :
  continuous (@conode I A).
Proof.
  intros ch Hch s Hs; split.
  - intro i; constructor; apply Hs.
  - intros x Hx.
    destruct x; try solve [specialize (Hx (S O)); inv Hx].
    constructor; apply Hs.
    intro i; specialize (Hx i); inv Hx; auto.
Qed.
#[global] Hint Resolve continuous_conode : cotree.

Lemma leq_cotree_le {I A} (a b : cotree I A) :
  a ⊑ b ->
  cotree_le a b.
Proof. auto. Qed.

CoInductive cotree_eq {I A} : cotree I A -> cotree I A -> Prop :=
| cotree_eq_bot : cotree_eq cobot cobot
| cotree_eq_leaf : forall x, cotree_eq (coleaf x) (coleaf x)
| cotree_eq_node : forall f g,
    (forall x, cotree_eq (f x) (g x)) ->
    cotree_eq (conode f) (conode g).

(** Extensionality axiom for cotrees. *)
Axiom cotree_ext : forall {I A} (a b : cotree I A), cotree_eq a b -> a = b.

Lemma cotree_eq_refl {I A} (t : cotree I A) :
  cotree_eq t t.
Proof. revert t; cofix CH; intros []; constructor; eauto. Qed.

#[global]
  Instance Reflexive_cotree_eq {I A} : Reflexive (@cotree_eq I A).
Proof. intro t; apply cotree_eq_refl. Qed.

Lemma cotree_eq_equ {I A} (a b : cotree I A) :
  cotree_eq a b -> a === b.
Proof.
  intro Hab; split; revert Hab; revert a b; cofix CH;
    intros a b Hab; inv Hab; try constructor; try intro x; apply CH; auto.
Qed.

Lemma equ_cotree_eq {I A} (a b : cotree I A) :
  a === b -> cotree_eq a b.
Proof.
  revert a b; cofix CH; intros a b [Hab Hba].
  inv Hab; inv Hba; constructor; try intro x;
    apply CH; split; try apply H; apply H2.
Qed.

Lemma cotree_equ_eq {I A} (a b : cotree I A) :
  a === b -> a = b.
Proof. intro H; apply cotree_ext, equ_cotree_eq; auto. Qed.

#[global]
  Instance ExtType_cotree {I A} : ExtType (cotree I A).
Proof.
  constructor; intros a b Hab; apply cotree_ext, equ_cotree_eq; auto.
Qed.

#[global]
  Instance Proper_cotree_le' {I A}
  : Proper (cotree_eq ==> cotree_eq ==> flip impl) (@cotree_le I A).
Proof.
  intros a b Hab c d Hcd Hle.
  apply cotree_eq_equ in Hab; destruct Hab.
  apply cotree_eq_equ in Hcd; destruct Hcd.
  etransitivity; eauto; etransitivity; eauto.
Qed.

Definition bstep_node {I A} (i : I) (t : atree I A) : atree I A :=
  match t with
  | anode k => k i
  | _ => abot
  end.

Definition step_node {I A} (i : I) (t : cotree I A) : cotree I A :=
  match t with
  | conode k => k i
  | _ => cobot
  end.

Definition not_cobot {I A} (t : cotree I A) : Prop :=
  match t with
  | cobot => False
  | _ => True
  end.

Definition not_abot {I A} (t : atree I A) : Prop :=
  match t with
  | abot => False
  | _ => True
  end.

Definition is_abotb {I A} (t : atree I A) : bool :=
  match t with
  | abot => true
  | _ => false
  end.

Lemma not_cobot_dec {I A} (t : cotree I A) : { not_cobot t } + { ~ not_cobot t }.
Proof.
  destruct t.
  - right; intro HC; inv HC.
  - left; constructor.
  - left; constructor.
Qed.

Lemma not_abot_dec {I A} (t : atree I A) : { not_abot t } + { ~ not_abot t }.
Proof.
  destruct t.
  - right; intro HC; inv HC.
  - left; constructor.
  - left; constructor.
Qed.

(* The supremum of a chain of cotrees. Uses strong LPO. *)
CoFixpoint cotree_sup {I A} (ch : nat -> cotree I A) : cotree I A :=
  match LPO_option (fun n => not_cobot_dec (ch n)) with
  | Some n => match ch n with
             | cobot => cobot
             | coleaf x => coleaf x
             | conode _ => conode (fun x => cotree_sup (step_node x ∘ ch))
             end
  | None => cobot
  end.

Lemma directed_step_node {I A} (ch : nat -> cotree I A) (x : I) :
  directed ch ->
  directed (step_node x ∘ ch).
Proof.
  intros Hch i j; specialize (Hch i j); destruct Hch as [k [Hk Hk']].
  unfold bstep_node, compose.
  exists k; split.
  - destruct (ch i) eqn:Hchi; try constructor; inv Hk; apply H1.
  - destruct (ch j) eqn:Hchj; try constructor; inv Hk'; apply H1.
Qed.

Lemma directed_bstep_node {I A} (ch : nat -> atree I A) (x : I) :
  directed ch ->
  directed (bstep_node x ∘ ch).
Proof.
  intros Hch i j; specialize (Hch i j); destruct Hch as [k [Hk Hk']].
  unfold bstep_node, compose.
  exists k; split.
  - destruct (ch i) eqn:Hchi; try constructor; inv Hk; apply H1.
  - destruct (ch j) eqn:Hchj; try constructor; inv Hk'; apply H1.
Qed.

Lemma directed_leaf_node {I A} (ch : nat -> cotree I A) i j x k :
  directed ch ->
  ch i = coleaf x ->
  ch j = conode k ->
  False.
Proof.
  intros Hch Hi Hj.
  specialize (Hch i j); destruct Hch as [l [Hl Hl']].
  rewrite Hi in Hl; rewrite Hj in Hl'.
  inv Hl; rewrite <- H in Hl'; inv Hl'.
Qed.

Lemma cotree_sup_ub {I A} (ch : nat -> cotree I A) :
  directed ch ->
  upper_bound (cotree_sup ch) ch.
Proof.
  revert ch.
  cofix CH; intros ch Hch i.
  simpl.
  replace (cotree_sup ch) with (unf (cotree_sup ch)).
  2: { rewrite <- unf_eq; reflexivity. }
  simpl.
  destruct (LPO_option (fun n : nat => not_cobot_dec (ch n))) eqn:Ho.
  - apply LPO_option_some in Ho.
    destruct (ch n) eqn:Hchn.
    + inv Ho.
    + clear Ho.
      specialize (Hch i n); destruct Hch as [k [Hk Hk']].
      rewrite Hchn in Hk'; inv Hk'.
      rewrite <- H in Hk.
      inv Hk; constructor.
    + clear Ho.
      destruct (ch i) eqn:Hchi.
      { constructor. }
      { eapply directed_leaf_node in Hchi; eauto; contradiction. }
      { constructor; intro x.
        replace (c0 x) with ((step_node x ∘ ch) i).
        2: { unfold compose; rewrite Hchi; reflexivity. }
        apply CH, directed_step_node; auto. }
  - apply LPO_option_none with (n:=i) in Ho.
    destruct (ch i); try constructor; exfalso; apply Ho; constructor.
Qed.

Lemma upper_bound_step_node {I A} (k : I -> cotree I A) (ch : nat -> cotree I A) (x : I) :
  upper_bound (conode k) ch ->
  upper_bound (k x) (step_node x ∘ ch).
Proof.
  intros Hub i; specialize (Hub i); unfold compose.
  destruct (ch i) eqn:Hchi; inv Hub; simpl; auto; constructor.
Qed.

Lemma cotree_sup_const {I A} (t : cotree I A) :
  cotree_eq (cotree_sup (fun _ : nat => t)) t.
Proof.
  revert t; cofix CH; intro t.
  rewrite unf_eq; simpl.
  destruct (LPO_option (fun _ : nat => not_cobot_dec t)) eqn:H.
  - apply LPO_option_some in H.
    destruct t; constructor; intro i; unfold compose; apply CH.
  - apply LPO_option_none with (n:=O) in H.
    destruct t; try constructor; exfalso; apply H; constructor.
Qed.

Lemma upper_bound_coleaf_cotree_sup {I A} (ch : nat -> cotree I A) (a : A) :
  upper_bound (coleaf a) ch ->
  cotree_sup ch ⊑ coleaf a.
Proof.
  revert ch a; cofix CH; intros ch a Ha.
  rewrite unf_eq; simpl.
  destruct (LPO_option (fun n : nat => not_cobot_dec (ch n))) eqn:Ho.
  2: { constructor. }
  destruct (ch n) eqn:Hchn.
  - constructor.
  - specialize (Ha n); rewrite Hchn in Ha; auto.
  - specialize (Ha n); rewrite Hchn in Ha; inv Ha.
Qed.

Lemma cotree_sup_lub {I A} (ch : nat -> cotree I A) (ub : cotree I A) :
  directed ch ->
  upper_bound ub ch ->
  cotree_sup ch ⊑ ub.
Proof.
  revert ch ub.
  cofix CH; intros ch ub Hch Hub.
  destruct ub.
  - replace ch with (fun _ : nat => @cobot I A).
    + rewrite cotree_sup_const; reflexivity.
    + ext i; specialize (Hub i); destruct (ch i); auto; inv Hub.
  - apply upper_bound_coleaf_cotree_sup; auto.
  - rewrite unf_eq; simpl.
    destruct (LPO_option (fun n : nat => not_cobot_dec (ch n))) eqn:Ho.
    2: { constructor. }
    destruct (ch n) eqn:Hchn.
    + constructor.
    + specialize (Hub n); rewrite Hchn in Hub; inv Hub.
    + constructor; intro i; apply CH.
      * apply directed_step_node; auto.
      * eapply upper_bound_step_node; eauto.
Qed.

Lemma cotree_sup_supremum {I A} (ch : nat -> cotree I A) :
  directed ch ->
  supremum (cotree_sup ch) ch.
Proof.
  intro Hch; split.
  - apply cotree_sup_ub; auto.
  - intros; apply cotree_sup_lub; auto.
Qed.

#[global]
  Instance CPO_cotree {I A} : CPO (@cotree I A).
Proof.
  constructor; intros ch Hch.
  exists (cotree_sup ch); apply cotree_sup_supremum; auto.
Qed.
#[global] Hint Resolve CPO_cotree : cotree.

Lemma supremum_coleaf {I A} (x : A) (ch : nat -> cotree I A) :
  supremum (coleaf x) ch ->
  exists i, ch i = coleaf x.
Proof.
  intros [Hub Hlub].
  destruct (strong_LPO (fun n => not_cobot_dec (ch n))).
  - destruct e as [n H].
    specialize (Hub n).
    destruct (ch n) eqn:Hchn.
    + inv H.
    + inv Hub; exists n; auto.
    + inv Hub.
  - assert (H: upper_bound cobot ch).
    { intro i; specialize (Hub i); destruct (ch i) eqn:Hchi.
      + constructor.
      + exfalso; apply n; exists i; rewrite Hchi; constructor.
      + inv Hub. }
    apply Hlub in H; inv H.
Qed.

Lemma supremum_aleaf {I A} (x : A) (ch : nat -> atree I A) :
  supremum (aleaf x) ch ->
  exists i, ch i = aleaf x.
Proof.
  intros [Hub Hlub].
  destruct (strong_LPO (fun n => not_abot_dec (ch n))).
  - destruct e as [n H].
    specialize (Hub n).
    destruct (ch n) eqn:Hchn.
    + inv H.
    + inv Hub; exists n; auto.
    + inv Hub.
  - assert (H: upper_bound abot ch).
    { intro i; specialize (Hub i); destruct (ch i) eqn:Hchi.
      + constructor.
      + exfalso; apply n; exists i; rewrite Hchi; constructor.
      + inv Hub. }
    apply Hlub in H; inv H.
Qed.

Lemma supremum_conode {I A} (f : I -> cotree I A) (ch : nat -> cotree I A) :
  supremum (conode f) ch ->
  exists i g, ch i = conode g.
Proof.
  intros [Hub Hlub].
  destruct (strong_LPO (fun n => not_cobot_dec (ch n))).
  - destruct e as [n H].
    specialize (Hub n).
    destruct (ch n) eqn:Hchn.
    + inv H.
    + inv Hub.
    + exists n, c; auto.
  - assert (H: upper_bound cobot ch).
    { intro i; specialize (Hub i); destruct (ch i) eqn:Hchi.
      + constructor.
      + inv Hub.
      + exfalso; apply n; exists i; rewrite Hchi; constructor. }
    apply Hlub in H; inv H.
Qed.

Lemma supremum_anode' {I A} (f : I -> atree I A) (ch : nat -> atree I A) :
  supremum (anode f) ch ->
  exists i g, ch i = anode g /\ g ⊑ f.
Proof.
  intros [Hub Hlub].
  destruct (strong_LPO (fun n => not_abot_dec (ch n))).
  - destruct e as [n H].
    specialize (Hub n).
    destruct (ch n) eqn:Hchn; inv H; inv Hub; exists n, a; auto.
  - assert (H: upper_bound abot ch).
    { intro i; specialize (Hub i); destruct (ch i) eqn:Hchi.
      + constructor.
      + inv Hub.
      + exfalso; apply n; exists i; rewrite Hchi; constructor. }
    apply Hlub in H; inv H.
Qed.

Lemma supremum_step_node {I A} (k : I -> cotree I A) (ch : nat -> cotree I A) (x : I) :
  supremum (conode k) ch ->
  supremum (k x) (step_node x ∘ ch).
Proof.
  intros [Hub Hlub]; split.
  - intro i; specialize (Hub i); unfold compose.
    inv Hub; simpl; auto; constructor.
  - unfold compose; intros y Hy.
    unfold upper_bound in Hy.
    simpl in Hy.
    assert (H: upper_bound (conode (fun z => if classicT (z = x) then y else k z)) ch).
    { intro i.
      specialize (Hy i); simpl in Hy.
      destruct (ch i) eqn:Hchi.
      - constructor.
      - specialize (Hub i); simpl in Hub; rewrite Hchi in Hub; inv Hub.
      - specialize (Hub i); simpl in Hub; rewrite Hchi in Hub; inv Hub.
        constructor; intro z.
        destruct_classic; subst; auto. }
    apply Hlub in H; inv H.
    specialize (H2 x).
    destruct_classic; auto; congruence.
Qed.

Lemma supremum_bstep_node {I A} (k : I -> atree I A) (ch : nat -> atree I A) (x : I) :
  supremum (anode k) ch ->
  supremum (k x) (bstep_node x ∘ ch).
Proof.
  intros [Hub Hlub]; split.
  - intro i; specialize (Hub i); unfold compose.
    inv Hub; simpl; auto; constructor.
  - unfold compose; intros y Hy.
    unfold upper_bound in Hy.
    simpl in Hy.
    assert (H: upper_bound (anode (fun z => if classicT (z = x) then y else k z)) ch).
    { intro i.
      specialize (Hy i); simpl in Hy.
      destruct (ch i) eqn:Hchi.
      - constructor.
      - specialize (Hub i); simpl in Hub; rewrite Hchi in Hub; inv Hub.
      - specialize (Hub i); simpl in Hub; rewrite Hchi in Hub; inv Hub.
        constructor; intro z.
        destruct_classic; subst; auto. }
    apply Hlub in H; inv H.
    specialize (H2 x).
    destruct_classic; auto; congruence.
Qed.

Lemma supremum_cobot {I A} (ch : nat -> cotree I A) :
  supremum cobot ch ->
  ch = const cobot.
Proof.
  intros [Hub Hlub]; ext i; unfold const.
  specialize (Hub i); inv Hub; reflexivity.
Qed.

Lemma conode_supremum {I A} (k : I -> cotree I A) (ch : nat -> I -> cotree I A) :
  (forall i, supremum (k i) (flip ch i)) ->
  supremum (conode k) (fun i => conode (ch i)).
Proof.
  intro Hsup; split.
  - intro i; constructor; intro x; apply Hsup.
  - intros x Hx; destruct x; try solve [specialize (Hx (S O)); inv Hx].
    constructor; intro x; apply Hsup.
    intro i; specialize (Hx i); inv Hx; apply H1.
Qed.

Lemma tprefix_monotone {I A} (n : nat) :
  monotone (@tprefix I A n).
Proof.
  induction n; intros a b Hab; simpl; try constructor.
  destruct a; inv Hab; constructor; intro i; apply IHn; simpl; auto.
Qed.

Lemma tprefix_monotone' {I A} (t : cotree I A) :
  monotone (fun n => tprefix n t).
Proof.
  intro i; revert t; induction i; intros t j Hij; simpl.
  - apply atree_le_bot.
  - destruct t.
    + apply atree_le_bot.
    + destruct j; simpl.
      * inv Hij.
      * constructor.
    + destruct j; simpl.
      * inv Hij.
      * constructor.
        intro x; eapply IHi; simpl in *; lia.
Qed.

Lemma tprefix_continuous {I A} (n : nat) :
  continuous (@tprefix I A n).
Proof.
  induction n; intros ch Hch x Hx; unfold compose; simpl.
  { apply supremum_const. }
  destruct x.
  - apply supremum_cobot in Hx.
    apply supremum_const'.
    apply equ_arrow; intro i; rewrite Hx; reflexivity.
  - apply supremum_coleaf in Hx.
    destruct Hx as [i Hi].
    apply const_supremum''.
    + intro j; specialize (Hch i j); destruct Hch as [k [Hk Hk']].
      rewrite Hi in Hk; inv Hk.
      rewrite <- H in Hk'; inv Hk'; constructor.
    + exists i; rewrite Hi; reflexivity.
  - assert (Hc: forall x, supremum (c x) (step_node x ∘ ch)).
    { intro i; apply supremum_step_node; auto. }
    split.
    + intro i; destruct (ch i) eqn:Hchi; simpl.
      * constructor.
      * destruct Hx as [Hub Hlub].
        specialize (Hub i); rewrite Hchi in Hub; inv Hub.
      * constructor; intro x.
        replace ((tprefix n ∘ c0) x) with ((tprefix n ∘ (step_node x ∘ ch)) i).
        2: { unfold compose; rewrite Hchi; reflexivity. }
        specialize (Hc x).
        apply IHn; auto.
        apply directed_step_node; auto.
    + intros ub Hub; destruct ub.
      * assert (H: forall i, ch i = cobot).
        { intro i; specialize (Hub i); simpl in Hub.
          destruct (ch i); auto; inv Hub. }
        assert (supremum cobot ch).
        { apply supremum_const'; apply equ_arrow; intro i.
          unfold const; rewrite H; reflexivity. }
        eapply supremum_unique in Hx; eauto.
        apply equ_cotree_eq in Hx; inv Hx.
      * assert (H: upper_bound (coleaf a) ch).
        { intro i; specialize (Hub i); simpl in Hub.
          destruct (ch i); inv Hub; constructor. }
        apply Hx in H; inv H.
      * constructor; intro x.
        eapply IHn.
        2: { eauto. }
        { apply directed_step_node; auto. }
        intro i; unfold compose.
        specialize (Hub i); simpl in Hub.
        destruct (ch i) eqn:Hchi; simpl.
        { destruct n; constructor. }
        { destruct n; constructor. }
        inv Hub; apply H1.
Qed.

Lemma cotree_le_atree_le {I A} (a b : atree I A) :
  cotree_le (tinj a) (tinj b) ->
  atree_le a b.
Proof.
  revert b; induction a; simpl; intros b Hab.
  - constructor.
  - destruct b; inv Hab; constructor.
  - destruct b; inv Hab; constructor; intro i; apply H, H2.
Qed.

Lemma atree_le_cotree_le {I A} (a b : atree I A) :
  atree_le a b ->
  cotree_le (tinj a) (tinj b).
Proof.
  revert b; induction a; simpl; intros b Hab.
  - constructor.
  - destruct b; inv Hab; constructor.
  - destruct b; inv Hab; constructor; intro i; apply H, H2.
Qed.

Lemma chain_tprefix {I A} (t : cotree I A) :
  chain (fun n : nat => tprefix n t).
Proof.
  apply monotone_chain.
  - apply tprefix_monotone'.
  - intro i; simpl; lia.
Qed.

Lemma bintree_compact {A} (t : bintree A) (ch : nat -> bintree A) :
  directed ch ->
  supremum t ch ->
  exists i, ch i = t.
Proof.
  revert ch; induction t; intros ch Hch Ht.
  - exists O; apply equ_atree; split; try constructor; apply Ht.
  - apply supremum_aleaf in Ht; auto.
  - destruct (is_abotb (a false)) eqn:H'.
    { destruct (a false) eqn:Hal; inv H'.
      destruct (is_abotb (a true)) eqn:H'.
      - destruct (a true) eqn:Har; inv H'.
        apply supremum_anode' in Ht.
        destruct Ht as [i [g [Hi Hg]]].
        exists i; rewrite Hi; f_equal; ext b; destruct b.
        + specialize (Hg true); rewrite Har in Hg; inv Hg; auto.
        + specialize (Hg false); rewrite Hal in Hg; inv Hg; auto.
      - pose proof Ht as Hr.
        apply supremum_bstep_node with (x:=true) in Hr.
        apply H in Hr; clear H.
        2: { apply directed_bstep_node; auto. }
        destruct Hr as [j Hr]; exists j.
        unfold bstep_node, compose in Hr.
        destruct (ch j) eqn:Hchj; try solve [rewrite <- Hr in H'; inv H'].
        f_equal; ext b; destruct b; auto; rewrite Hal.
        destruct Ht as [Hub Hlub].
        specialize (Hub j); rewrite Hchj in Hub; inv Hub.
        specialize (H1 false); rewrite Hal in H1.
        inv H1; auto. }
    { destruct (is_abotb (a true)) eqn:H''.
      - destruct (a true) eqn:Har; inv H''.
        pose proof Ht as Hr.
        apply supremum_bstep_node with (x:=false) in Hr.
        apply H in Hr; clear H.
        2: { apply directed_bstep_node; auto. }
        destruct Hr as [j Hr]; exists j.
        unfold bstep_node, compose in Hr.
        destruct (ch j) eqn:Hchj; try solve [rewrite <- Hr in H'; inv H'].
        f_equal; ext b; destruct b; auto; rewrite Har.
        destruct Ht as [Hub Hlub].
        specialize (Hub j); rewrite Hchj in Hub; inv Hub.
        specialize (H1 true); rewrite Har in H1.
        inv H1; auto.
      - pose proof Ht as Hl.
        apply supremum_bstep_node with (x:=false) in Hl.
        pose proof Ht as Hr.
        apply supremum_bstep_node with (x:=true) in Hr.
        apply H in Hl.
        2: { apply directed_bstep_node; auto. }
        apply H in Hr.
        2: { apply directed_bstep_node; auto. }
        clear H.
        destruct Hl as [i Hi].
        destruct Hr as [j Hj].
        specialize (Hch i j); destruct Hch as [k [Hk Hk']]; exists k.
        unfold bstep_node, compose in *.
        destruct (ch k) eqn:Hchk.
        + inv Hk; rewrite <- H0 in Hi; rewrite <- Hi in H'; inv H'.
        + inv Hk; rewrite <- H0 in Hi; rewrite <- Hi in H'; inv H'.
        + inv Hk.
          { rewrite <- H0 in Hi; rewrite <- Hi in H'; inv H'. }
          rewrite <- H in Hi.
          inv Hk'.
          { rewrite <- H2 in Hj; rewrite <- Hj in H''; inv H''. }
          rewrite <- H0 in Hj.
          destruct Ht as [Hub Hlub].
          specialize (Hub k); rewrite Hchk in Hub; inv Hub.
          f_equal; ext b; destruct b.
          * apply equ_atree; split.
            { apply H5. }
            { rewrite <- Hj; apply H3. }
          * apply equ_atree; split.
            { apply H5. }
            { rewrite <- Hi; apply H1. } }
Qed.

Lemma coprefix_le {I A} (t : cotree I A) (n : nat) :
  coprefix n t ⊑ t.
Proof.
  revert t; induction n; intro t; simpl; try constructor.
  destruct t; constructor; intro x; apply IHn.
Qed.

Lemma coprefix_supremum {I A} (t : cotree I A) :
  supremum t (fun n => coprefix n t).
Proof.
  split.
  - intro i; apply coprefix_le.
  - revert t; cofix CH; intros t ub Hub.
    destruct ub.
    + specialize (Hub (S O)).
      destruct t; inv Hub; constructor.
    + specialize (Hub (S O)).
      destruct t; inv Hub; constructor.
    + destruct t.
      * constructor.
      * specialize (Hub (S O)); inv Hub.
      * constructor; intro x; apply CH.
        intro i.
        specialize (Hub (S i)); simpl in Hub.
        inv Hub; apply H1.
Qed.

#[global]
  Instance Compact_atree {A} : Compact (atree bool A).
Proof.
  constructor; intros a f Hf Ha.
  apply bintree_compact in Ha; auto.
  destruct Ha as [i Ha]; subst; exists i; reflexivity.
Qed.

#[global]
  Instance Dense_cotree {I A} : Dense (cotree I A) (atree I A) :=
  { incl := tinj
  ; ideal := flip tprefix }.

#[global]
  Instance aCPO_cotree {A} : aCPO (cotree bool A) (atree bool A).
Proof.
  constructor.
  - intros a b; split.
    + apply atree_le_cotree_le.
    + apply cotree_le_atree_le.
  - apply chain_tprefix.
  - intros a b Hab i; apply tprefix_monotone; auto.
  - apply tprefix_continuous.
  - intro a; simpl; unfold compose, flip.
    replace (fun i => tinj (tprefix i a)) with (fun i => coprefix i a).
    + apply coprefix_supremum.
    + ext i; rewrite tinj_tprefix_coprefix; reflexivity.
Qed.

Inductive atree_cotree_le {I A} : atree I A -> cotree I A -> Prop :=
| atree_cotree_le_bot : forall t, atree_cotree_le abot t
| atree_cotree_le_leaf : forall x, atree_cotree_le (aleaf x) (coleaf x)
| atree_cotree_le_node : forall f g,
    (forall i, atree_cotree_le (f i) (g i)) ->
    atree_cotree_le (anode f) (conode g).

#[global]
  Instance antimonotone_atree_cotree_le {I A}
  : Proper (leq ==> flip leq) (@atree_cotree_le I A).
Proof.
  intro a; induction a; intros b Hab c Hc; inv Hab; auto.
  - constructor.
  - inv Hc; constructor; intro i.
    specialize (H1 i); apply H in H1; apply H1; auto.
Qed.
#[global] Hint Resolve antimonotone_atree_cotree_le : cotree.

Definition cotree_le' {A} : cotree bool A -> cotree bool A -> Prop :=
  coop atree_cotree_le.

Lemma atree_cotree_le_ideal {I A} (a b : cotree I A) (i : nat) :
  cotree_le a b ->
  atree_cotree_le (ideal a i) b.
Proof.
  revert a b; induction i; intros a b Hab; simpl; unfold flip; simpl.
  - constructor.
  - simpl in IHi; unfold flip in IHi.
    destruct a; inv Hab; constructor; auto.
    intro x; apply IHi, H0.
Qed.

Lemma cotree_le'_inv_leaf {A} (x : A) (t : cotree bool A) :
  cotree_le' (coleaf x) t ->
  t = coleaf x.
Proof.
  intro Hle.
  apply coop_elim2 with (i := S O) in Hle; eauto with cotree order.
  simpl in Hle; unfold flip in Hle; simpl in Hle.
  destruct t; inv Hle; reflexivity.
Qed.

Lemma cotree_le'_inv_node {A} (f : bool -> cotree bool A) (t : cotree bool A) :
  cotree_le' (conode f) t ->
  exists g, t = conode g /\ forall i, cotree_le' (f i) (g i).
Proof.
  intro Hle.
  destruct t; try solve [apply coop_elim2 with (i := S O) in Hle;
                         eauto with cotree order; inv Hle].
  exists c; split; auto.
  intro b; apply coop_intro2; eauto with cotree order; intro i.
  apply coop_elim2 with (i := S i) in Hle; eauto with cotree order.
  inv Hle; apply H1.
Qed.

Lemma cotree_le_cotree_le' {A} (a b : cotree bool A) :
  cotree_le a b <-> cotree_le' a b.
Proof.
  split.
  - intro Hab.
    unfold cotree_le'.
    eapply coop_intro2; eauto with cotree order.
    intro i; apply atree_cotree_le_ideal; auto.
  - revert a b; cofix CH; intros a b Hab.
    destruct a.
    + constructor.
    + apply cotree_le'_inv_leaf in Hab; subst; constructor.
    + apply cotree_le'_inv_node in Hab.
      destruct Hab as [g [? Hg]]; subst.
      constructor; intro b; apply CH, Hg.
Qed.

Fixpoint tfold {I A B}
  (z : B) (f : A -> B) (g : (I -> B) -> B) (t : atree I A) : B :=
  match t with
  | abot => z
  | aleaf x => f x
  | anode k => g (tfold z f g ∘ k)
  end.

#[global]
  Instance monotone_tfold {I A B} `{OType B} (z : B) (f : A -> B) (g : (I -> B) -> B)
  {Hz : forall b, z ⊑ tfold z f g b}
  {Hg : Proper (leq ==> leq) g}
  : Proper (leq ==> leq) (tfold z f g).
Proof.
  intro a; revert Hz Hg; revert f;
    induction a; intros f Hz Hg b Hab; inv Hab; simpl.
  - apply Hz.
  - reflexivity.
  - apply Hg; intro x; apply H0; auto; apply H2.
Qed.
#[global] Hint Resolve monotone_tfold : cotree.

#[global]
  Instance antimonotone_tfold {I A B} `{OType B}
  (z : B) (f : A -> B) (h : (I -> B) -> B)
  {Hz : forall b, tfold z f h b ⊑ z}
  {Hh : Proper (leq ==> leq) h}
  : Proper (leq ==> flip leq) (tfold z f h).
Proof.
  intro a; revert Hz Hh; revert f;
    induction a; simpl; unfold flip; intros f Hz Hh b Hab; inv Hab.
  - apply Hz.
  - reflexivity.
  - apply Hh.
    intro x; unfold compose; simpl.
    eapply H0; auto; apply H2.
Qed.
#[global] Hint Resolve antimonotone_tfold : cotree.

(** Computation lemmas for co tfolds. *)

Lemma co_tfold_bot {A B} `{CPO B} (z : B) (f : A -> B) (h : (bool -> B) -> B) :
  co (tfold z f h) cobot === z.
Proof.
  apply supremum_sup, supremum_const', equ_arrow; intros []; reflexivity.
Qed.

Lemma co_tfold_bot' {A B} `{o : OType B} `{@CPO B o} `{@ExtType B o}
  (z : B) (f : A -> B) (h : (bool -> B) -> B) :
  co (tfold z f h) cobot = z.
Proof. apply ext, co_tfold_bot. Qed.

Lemma co_tfold_leaf {A B} `{CPO B}
  (z : B) (f : A -> B) (h : (bool -> B) -> B) (x : A) :
  z ⊑ f x ->
  co (tfold z f h) (coleaf x) === f x.
Proof.
  intro Hz.
  apply supremum_sup.
  apply supremum_eventually_constant_at.
  { intros []; simpl; auto; reflexivity. }
  exists (S O); intros n Hn; destruct n; try lia; reflexivity.
Qed.

Lemma co_tfold_leaf' {A B} `{o : OType B} `{@CPO B o} `{@ExtType B o}
  (z : B) (f : A -> B) (h : (bool -> B) -> B) (x : A) :
  z ⊑ f x ->
  co (tfold z f h) (coleaf x) = f x.
Proof. intro Hz; apply ext, co_tfold_leaf; auto. Qed.

Lemma co_tfold_node {A B} `{CPO B}
  (z : B) (f : A -> B) (h : (bool -> B) -> B) (k : bool -> cotree bool A) :
  wcontinuous h ->
  (forall b, z ⊑ tfold z f h b) ->
  z ⊑ h (fun _ => z) ->
  co (tfold z f h) (conode k) === h (co (tfold z f h) ∘ k).
Proof.
  intros Hh Hz Hhz.
  assert (Hh': monotone h).
  { apply wcontinuous_monotone; auto. }
  apply supremum_sup.
  apply shift_supremum'' with
    (f := fun i => h (fun x => tfold z f h (ideal (k x) i))); auto.
  { apply Hh.
    { apply monotone_chain.
      - intros i j Hij b; simpl; unfold flip.
        apply monotone_tfold; auto.
        apply tprefix_monotone'; auto.
      - apply chain_id. }
    { apply supremum_apply; intro x.
      apply sup_spec.
      { apply monotone_directed; auto with cotree order.
        apply chain_directed, chain_ideal. } } }
  apply equ_arrow; intro i; reflexivity.
Qed.

Lemma co_tfold_node' {A B} `{o : OType B} `{@CPO B o} `{@ExtType B o}
  (z : B) (f : A -> B) (g : (bool -> B) -> B) (k : bool -> cotree bool A) :
  wcontinuous g ->
  (forall b, z ⊑ tfold z f g b) ->
  z ⊑ g (fun _ => z) ->
  co (tfold z f g) (conode k) = g (co (tfold z f g) ∘ k).
Proof. intros Hg Hz Hg'; apply ext, co_tfold_node; auto. Qed.

(** Computation lemmas for coop tfolds. *)
Lemma coop_tfold_bot {A B} `{lCPO B} (z : B) (f : A -> B) (h : (bool -> B) -> B) :
  coop (tfold z f h) cobot === z.
Proof.
  apply infimum_inf, infimum_const', equ_arrow; intros []; reflexivity.
Qed.

Lemma coop_tfold_leaf {A B} `{lCPO B}
  (z : B) (f : A -> B) (h : (bool -> B) -> B) (x : A) :
  f x ⊑ z ->
  coop (tfold z f h) (coleaf x) === f x.
Proof.
  intro Hz.
  apply infimum_inf.
  apply infimum_eventually_constant_at.
  { intros []; simpl; auto; reflexivity. }
  exists (S O); intros n Hn; destruct n; try lia; reflexivity.
Qed.

Lemma coop_tfold_node {A B} `{lCPO B}
  (z : B) (f : A -> B) (h : (bool -> B) -> B) (k : bool -> cotree bool A) :
  dec_wcontinuous h ->
  (forall b, tfold z f h b ⊑ z) ->
  h (fun _ => z) ⊑ z ->
  coop (tfold z f h) (conode k) === h (coop (tfold z f h) ∘ k).
Proof.
  intros Hh Hz Hhz.
  assert (Hh': monotone h).
  { apply dec_wcontinuous_monotone; auto. }
  apply infimum_inf.
  apply shift_infimum'' with
    (f := fun i => h (fun x => tfold z f h (ideal (k x) i))); auto.
  { apply Hh.
    { intros i b; apply antimonotone_tfold; auto; apply chain_ideal. }
    { apply infimum_apply; intro x.
      apply inf_spec.
      { apply antimonotone_downward_directed; auto with cotree order.
        apply chain_directed, chain_ideal. } } }
  apply equ_arrow; intro i; reflexivity.
Qed.

Definition tcofold {A B} `{PType B} (f : A -> B) (g : (bool -> B) -> B)
  : cotree bool A -> B :=
  co (tfold ⊥ f g).

Lemma tcofold_bot {A B} `{o : OType B} `{@PType B o} `{@CPO B o}
  (f : A -> B) (g : (bool -> B) -> B) :
  tcofold f g cobot === ⊥.
Proof. apply co_tfold_bot. Qed.

Lemma tcofold_leaf {A B} `{o : OType B} `{@PType B o} `{@CPO B o}
  (f : A -> B) (g : (bool -> B) -> B) (x : A) :
  tcofold f g (coleaf x) === f x.
Proof. apply co_tfold_leaf, bot_le. Qed.

Lemma tcofold_leaf' {A B} `{o : OType B} `{@PType B o} `{@CPO B o}
  `{@ExtType B o} (f : A -> B) (g : (bool -> B) -> B) (x : A) :
  tcofold f g (coleaf x) = f x.
Proof. apply ext, co_tfold_leaf, bot_le. Qed.

Lemma tfold_le_tcofold {A B} `{o : OType B} `{@PType B o} `{@CPO B o}
  (t : cotree bool A) i (f : A -> B) g :
  Proper (leq ==> leq) g ->
  tfold ⊥ f g (tprefix i t) ⊑ tcofold f g t.
Proof.
  revert f g t; induction i; intros f g t Hg; simpl.
  { apply bot_le. }
  destruct t; simpl.
  - apply bot_le.
  - rewrite tcofold_leaf; reflexivity.
  - unfold compose. simpl.
    apply le_sup with (i := S i).
    + apply monotone_directed; eauto with cotree order.
      apply chain_directed, chain_ideal.
    + reflexivity.
Qed.

Fixpoint cotree_fold {I A B}
  (z : B) (f : A -> B) (g : (I -> B) -> B) (n : nat) (t : cotree I A) : B :=
  match n with
  | O => z
  | S n' =>
      match t with
      | cobot => z
      | coleaf x => f x
      | conode k => g (cotree_fold z f g n' ∘ k)
      end
  end.

Lemma tfold_cotree_fold {I A B} (z : B) (f : A -> B) (g : (I -> B) -> B) (n : nat) (t : cotree I A) :
  tfold z f g (tprefix n t) = cotree_fold z f g n t.
Proof.
  revert z f g t; induction n; intros z f g t; simpl; auto.
  destruct t; simpl; auto.
  unfold compose.
  f_equal; ext i; auto.
Qed.

Lemma tcofold_node {A B} `{o : OType B} `{@PType B o} `{@CPO B o}
  (f : A -> B) (g : (bool -> B) -> B) (k : bool -> cotree bool A) :
  wcontinuous g ->
  tcofold f g (conode k) === g (tcofold f g ∘ k).
Proof. intro Hg; apply co_tfold_node; auto with order. Qed.

Definition tcoopfold {A B} `{TType B} (f : A -> B) (g : (bool -> B) -> B)
  : cotree bool A -> B :=
  coop (tfold ⊤ f g).

Lemma tcoopfold_bot {A B} `{o : OType B} `{@TType B o} `{@lCPO B o}
  (f : A -> B) (g : (bool -> B) -> B) :
  tcoopfold f g cobot === ⊤.
Proof. apply coop_tfold_bot. Qed.

Lemma tcoopfold_leaf {A B} `{o : OType B} `{@TType B o} `{@lCPO B o}
  (f : A -> B) (g : (bool -> B) -> B) (x : A) :
  tcoopfold f g (coleaf x) === f x.
Proof. apply coop_tfold_leaf; apply le_top. Qed.

Lemma tcoopfold_node {A B} `{o : OType B} `{@TType B o} `{@lCPO B o}
  (f : A -> B) (g : (bool -> B) -> B) (k : bool -> cotree bool A) :
  dec_wcontinuous g ->
  tcoopfold f g (conode k) === g (tcoopfold f g ∘ k).
Proof. intro Hg; apply coop_tfold_node; auto with order. Qed.

(** Extraction primitive for tcofold. Only safe for total cotrees (no
    occurrences of cobot). *)
Extract Constant tcofold => "
  \ o p f g t ->
    case t of
      Cobot -> bot o p
      Coleaf a -> f a
      Conode k -> g (tcofold o p f g Prelude.. k)
".

Inductive exists_bot {I A} : cotree I A -> Prop :=
| exists_bot_bot : exists_bot cobot
| exists_bot_node : forall k i,
    exists_bot (k i) ->
    exists_bot (conode k).

(** This still allows trees with infinite nodes and no leaves. *)
Definition total {I A} (t : cotree I A) : Prop :=
  ~ exists_bot t.

CoInductive productive {I A} : cotree I A -> Prop :=
| productive_leaf : forall a, productive (coleaf a)
| productive_node : forall k,
    (forall b, productive (k b)) ->
    productive (conode k).

Lemma total_productive {I A} (t : cotree I A) :
  total t <-> productive t.
Proof.
  split.
  - revert t; cofix CH; intros t Ht.
    destruct t.
    + exfalso; apply Ht; constructor.
    + constructor.
    + constructor; intro i; apply CH.
      intro HC; apply Ht; econstructor; eauto.
  - intros Ht HC.
    revert Ht.
    induction HC.
    + intro HC; inv HC.
    + intro Ht; inv Ht.
      apply IHHC; auto.
Qed.

CoFixpoint cotree_bind' {A B} (t : cotree bool A) (k : A -> cotree bool B) : cotree bool B :=
  match t with
  | cobot => cobot
  | coleaf a => k a
  | conode f => conode (fun x => cotree_bind' (f x) k)
  end.

Definition atree_cotree_bind {I A B} (k : A -> cotree I B) : atree I A -> cotree I B :=
  tfold ⊥ k (@conode I B).

Definition cotree_bind {A B} (t : cotree bool A) (k : A -> cotree bool B) : cotree bool B :=
  tcofold k (@conode bool B) t.

#[global]
  Instance monotone_atree_cotree_bind {I A B} (k : A -> cotree I B) :
  Proper (leq ==> leq) (atree_cotree_bind k).
Proof.
  intro a; revert k; induction a; intros k b Hab; inv Hab; simpl.
  - constructor.
  - reflexivity.
  - constructor; intro x; apply H, H1.
Qed.

(** Computation lemmas for bind. *)

Lemma cotree_bind_bot {A B} (k : A -> cotree bool B) :
  cotree_bind cobot k = cobot.
Proof.
  apply cotree_ext, equ_cotree_eq.
  unfold cotree_bind, tcofold.
  rewrite co_tfold_bot; reflexivity.
Qed.

Lemma cotree_bind_leaf {A B} (k : A -> cotree bool B) (x : A) :
  cotree_bind (coleaf x) k = k x.
Proof.
  apply cotree_ext, equ_cotree_eq.
  unfold cotree_bind, tcofold.
  rewrite co_tfold_leaf; try reflexivity; constructor.
Qed.

Lemma cotree_bind_node {A B} (k : A -> cotree bool B) (f : bool -> cotree bool A) :
  cotree_bind (conode f) k = conode (fun x => cotree_bind (f x) k).
Proof.
  apply cotree_ext, equ_cotree_eq.
  unfold cotree_bind, tcofold.
  rewrite co_tfold_node; auto with cotree order;
    try reflexivity; intros; constructor.
Qed.

Lemma atree_cotree_le_tprefix {I A} (t : cotree I A) (i : nat) :
  atree_cotree_le (tprefix i t) t.
Proof.
  revert t; induction i; intro t; simpl.
  { constructor. }
  destruct t; constructor.
  intro j; apply IHi.
Qed.

Lemma cotree_bind_cotree_bind' {A B} (t : cotree bool A) (k : A -> cotree bool B) :
  cotree_bind t k = cotree_bind' t k.
Proof.
  apply ext; split; apply cotree_le_cotree_le'.
  - apply coop_intro2.
    { apply antimonotone_atree_cotree_le. }
    intro i.
    simpl; unfold flip.
    revert t k; induction i; intros t k; simpl.
    { constructor. }
    destruct t.
    + rewrite cotree_bind_bot; constructor.
    + rewrite cotree_bind_leaf.
      rewrite (@unf_eq _ _ (cotree_bind' _ _)); simpl.
      destruct (k a) eqn:Hka; constructor.
      intro b; apply atree_cotree_le_tprefix.
    + rewrite cotree_bind_node.
      rewrite (@unf_eq _ _ (cotree_bind' _ _)); simpl.
      constructor; intro b; apply IHi.
  - apply coop_intro2.
    { apply antimonotone_atree_cotree_le. }
    intro i.
    simpl; unfold flip.
    revert t k; induction i; intros t k; simpl.
    { constructor. }
    destruct t.
    + rewrite cotree_bind_bot; constructor.
    + rewrite cotree_bind_leaf.
      destruct (k a) eqn:Hka; constructor.
      intro b; apply atree_cotree_le_tprefix.
    + rewrite cotree_bind_node.
      constructor; intro b; apply IHi.
Qed.

Lemma productive_cotree_bind {A B} (t : cotree bool A) (k : A -> cotree bool B) :
  productive t ->
  (forall a, productive (k a)) ->
  productive (cotree_bind t k).
Proof.
  revert t k; cofix CH; intros t k Ht Hk.
  destruct t.
  - inv Ht.
  - destruct (k a) eqn:Hka.
    + specialize (Hk a); rewrite Hka in Hk; inv Hk.
    + unfold cotree_bind, tcofold.
      rewrite co_tfold_leaf'; auto.
      apply bot_le.
    + unfold cotree_bind, tcofold.
      rewrite co_tfold_leaf'; auto.
      apply bot_le.
  - inv Ht.
    unfold cotree_bind, tcofold.
    rewrite co_tfold_node'; auto with cotree order.
    constructor; intro b; apply CH; auto.
Qed.

Definition atree_cotree_map {I A B} (f : A -> B) : atree I A -> cotree I B :=
  tfold ⊥ (@coleaf I B ∘ f) (@conode I B).

Definition cotree_map {A B} (f : A -> B) (t : cotree bool A) : cotree bool B :=
  tcofold (@coleaf bool B ∘ f) (@conode bool B) t.

#[global]
  Instance monotone_atree_cotree_map {I A B} (f : A -> B) :
  Proper (leq ==> leq) (@atree_cotree_map I A B f).
Proof.
  intro a; revert f; induction a; intros f b Hab; inv Hab; simpl.
  - constructor.
  - reflexivity.
  - constructor; intro x; apply H, H1.
Qed.
#[global] Hint Resolve monotone_atree_cotree_map : cotree.

Definition atree_cotree_filter {I A} (P : A -> bool) : atree I A -> cotree I A :=
  tfold ⊥ (fun x => if P x then coleaf x else cobot) (@conode I A).

Definition cotree_filter {A} (P : A -> bool) : cotree bool A -> cotree bool A :=
  tcofold (fun x => if P x then coleaf x else cobot) (@conode bool A).

#[global]
  Instance monotone_atree_cotree_filter {I A} (P : A -> bool) :
  Proper (leq ==> leq) (@atree_cotree_filter I A P).
Proof.
  intro a; revert P; induction a; intros P b Hab; inv Hab; simpl.
  - constructor.
  - compute; destruct (P a); constructor.
  - constructor; intro x; apply H, H1.
Qed.
#[global] Hint Resolve monotone_atree_cotree_filter : cotree.

(* Lifting a relation to atrees. *)
Inductive atreeR {I A B} (R : A -> B -> Prop) : atree I A -> atree I B -> Prop :=
| atreeR_bot : atreeR R abot abot
| atreeR_leaf : forall x y, R x y -> atreeR R (aleaf x) (aleaf y)
| atreeR_node : forall f g,
    (forall i, atreeR R (f i) (g i)) ->
    atreeR R (anode f) (anode g).

Lemma atreeR_map {I A B} (t : atree I A) (f : A -> B) :
  atreeR (fun x y => f x = y) t (atree_map f t).
Proof.
  revert f; induction t; intro f; simpl.
  - constructor.
  - constructor; reflexivity.
  - constructor; intro i; apply H.
Qed.

Lemma cotree_le_bind {A B} (a : cotree bool A) (f g : A -> cotree bool B) :
  (forall x, f x ⊑ g x) ->
  cotree_bind a f ⊑ cotree_bind a g.
Proof.
  intros Hfg.
  apply cotree_le_cotree_le'.
  unfold cotree_le'.
  apply coop_intro2; eauto with cotree order.
  intro i; simpl; unfold flip; simpl.
  revert Hfg; revert a f g.
  induction i; intros a f g Hfg; simpl.
  { constructor. }
  destruct a.
  - rewrite 2!cotree_bind_bot; constructor.
  - rewrite 2!cotree_bind_leaf.
    specialize (Hfg a); inv Hfg; constructor.
    + intro b; apply atree_cotree_le_ideal; auto.
  - rewrite 2!cotree_bind_node; constructor; intro b; apply IHi; auto.
Qed.

(** This can't be defined as a comorphism because (A -> cotree I B) is
    not an aCPO in general. *)
Definition cotree_iter_F {I A} (f : I -> cotree bool (I + A))
  : (I -> cotree bool A) -> I -> cotree bool A :=
  fun g i => cotree_bind (f i) (fun lr => match lr with
                                    | inl j => g j
                                    | inr x => coleaf x
                                    end).

Definition cotree_iter {I A} (f : I -> cotree bool (I + A)) (z : I) : cotree bool A :=
  iter (cotree_iter_F f) (const cobot) z.

Lemma monotone_cotree_iter_F {I A} (f : I -> cotree bool (I + A)) :
  monotone (cotree_iter_F f).
Proof.
  intros g g' Hg i.
  unfold cotree_iter_F.
  apply cotree_le_bind.
  intros []; try constructor; apply Hg.
Qed.
#[global] Hint Resolve monotone_cotree_iter_F : cotree.

Lemma co_tinj_t {A} (t : cotree bool A) :
  co tinj t = t.
Proof.
  cut (co incl t === t).
  { intro H; apply cotree_ext, equ_cotree_eq; apply H. }
  apply co_incl_id'.
Qed.

Lemma supremum_cotree_bind {A B}
  (t : cotree bool A) (f : A -> cotree bool B) (g : nat -> A -> cotree bool B) :
  directed g ->
  supremum f g ->
  supremum (cotree_bind t f) (fun i : nat => cotree_bind t (g i)).
Proof.
  intros Hch Hsup.
  assert (forall x, supremum (f x) (fun i : nat => g i x)).
  { intro x; apply apply_supremum; auto. }
  split.
  - intro i; apply cotree_le_bind; intro x; apply H.
  - intros x Hx.
    unfold upper_bound in Hx.
    apply cotree_le_cotree_le'.
    apply coop_intro2; eauto with cotree order.
    intro i; unfold uncurry; simpl; unfold flip.
    revert Hsup H Hx.
    revert f x t.
    induction i; simpl; intros f x t Hsup H Hx.
    { constructor. }
    destruct t.
    + rewrite cotree_bind_bot; constructor.
    + rewrite cotree_bind_leaf.
      assert (Hle: cotree_le (f a) x).
      { apply H; intro j; specialize (Hx j).
        rewrite cotree_bind_leaf in Hx; apply Hx. }
      destruct (f a) eqn:Hfa.
      * constructor.
      * inv Hle; constructor.
      * inv Hle; constructor.
        intro b; unfold compose.
        apply atree_cotree_le_ideal; auto.
    + rewrite cotree_bind_node.
      pose proof Hx as Hx'.
      specialize (Hx i); rewrite cotree_bind_node in Hx.
      inv Hx.
      constructor.
      intro b.
      apply IHi; auto.
      intro j; specialize (Hx' j); rewrite cotree_bind_node in Hx'.
      inv Hx'; auto.
      apply H3.
Qed.

Lemma wcontinuous_cotree_iter_F {I A} (f : I -> cotree bool (I + A)) :
  wcontinuous (cotree_iter_F f).
Proof.
  intros ch Hch s Hs.
  unfold cotree_iter_F.
  eapply supremum_apply.
  unfold compose.
  intro x.
  apply supremum_cotree_bind.
  { apply chain_directed; intros i []; try constructor; apply Hch. }
  split.
  - intros i []; try constructor; apply Hs.
  - intros g Hg [].
    + unfold upper_bound in Hg. simpl in Hg.
      pose proof Hg as Hg'.
      specialize (Hg O (inl i)); simpl in Hg.
      assert (Hsi: supremum (s i) (fun j => ch j i)).
      { apply apply_supremum; auto. }
      apply Hsi.
      intro j.
      specialize (Hg' j (inl i)); simpl in Hg'; auto.
    + unfold upper_bound in Hg; simpl in Hg.
      pose proof Hg as Hg'.
      specialize (Hg O (inr a)); simpl in Hg.
      inv Hg; reflexivity.
Qed.

Lemma continuous_cotree_iter_F {I A} (f : I -> cotree bool (I + A)) :
  continuous (cotree_iter_F f).
Proof.
  intros ch Hch s Hs.
  unfold cotree_iter_F.
  eapply supremum_apply.
  unfold compose.
  intro x.
  apply supremum_cotree_bind.
  { intros i j; simpl.
    specialize (Hch i j); destruct Hch as [k [Hk Hk']].
    exists k; split.
    - intros [y|a]; try constructor; apply Hk.
    - intros [y|a]; try constructor; apply Hk'. }
  split.
  - intros i []; try constructor; apply Hs.
  - intros g Hg [].
    + unfold upper_bound in Hg. simpl in Hg.
      pose proof Hg as Hg'.
      specialize (Hg O (inl i)); simpl in Hg.
      assert (Hsi: supremum (s i) (fun j => ch j i)).
      { apply apply_supremum; auto. }
      apply Hsi.
      intro j.
      specialize (Hg' j (inl i)); simpl in Hg'; auto.
    + unfold upper_bound in Hg; simpl in Hg.
      pose proof Hg as Hg'.
      specialize (Hg O (inr a)); simpl in Hg.
      inv Hg; reflexivity.
Qed.

(** Unfolding lemma for cotree_iter. *)
Lemma cotree_iter_unfold {I A} (f : I -> cotree bool (I + A)) (i : I) :
  cotree_iter f i = cotree_bind (f i) (fun lr => match lr with
                                              | inl j => cotree_iter f j
                                              | inr x => coleaf x
                                              end).
Proof.
  apply cotree_ext, equ_cotree_eq.
  unfold cotree_iter.
  assert (iter (cotree_iter_F f) (const cobot) ===
            cotree_iter_F f (iter (cotree_iter_F f) (const cobot))).
  { apply iter_unfold.
    - apply continuous_wcontinuous, continuous_cotree_iter_F.
    - constructor. }
  rewrite equ_arrow in H; apply H.
Qed.

(** Extraction primitive for cotree_iter. *)
Extract Constant cotree_iter => "
  \ f i ->
    cotree_bind (f i) (\ lr -> case lr of
                                 Inl j -> cotree_iter f j
                                 Inr x -> coleaf x)".

(** Computation lemmas for cotree_map. *)

Lemma cotree_map_bot {A B} (f : A -> B) :
  @cotree_map A B f cobot = cobot.
Proof.
  apply cotree_equ_eq.
  unfold cotree_map, tcofold.
  rewrite co_tfold_bot; reflexivity.
Qed.

Lemma cotree_map_leaf {A B} (f : A -> B) (x : A) :
  @cotree_map A B f (coleaf x) = coleaf (f x).
Proof.
  apply cotree_equ_eq.
  unfold cotree_map, tcofold.
  rewrite co_tfold_leaf; try reflexivity; constructor.
Qed.

Lemma cotree_map_node {A B} (f : A -> B) (k : bool -> cotree bool A) :
  cotree_map f (conode k) = conode (cotree_map f ∘ k).
Proof.
  apply cotree_equ_eq.
  unfold cotree_map, tcofold.
  rewrite co_tfold_node; auto with cotree order;
    try reflexivity; intros; constructor.
Qed.

(** Computation lemmas for cotree_filter. *)

Lemma cotree_filter_bot {A} (P : A -> bool) :
  @cotree_filter A P cobot = cobot.
Proof.
  apply cotree_equ_eq.
  unfold cotree_filter, tcofold.
  rewrite co_tfold_bot; reflexivity.
Qed.

Lemma cotree_filter_leaf {A} (P : A -> bool) (x : A) :
  @cotree_filter A P (coleaf x) = if P x then coleaf x else cobot.
Proof.
  apply cotree_equ_eq.
  unfold cotree_filter, tcofold.
  rewrite co_tfold_leaf; try reflexivity; intros; constructor.
Qed.

Lemma cotree_filter_node {A} (P : A -> bool) (k : bool -> cotree bool A) :
  cotree_filter P (conode k) = conode (cotree_filter P ∘ k).
Proof.
  apply cotree_equ_eq.
  unfold cotree_filter, tcofold.
  rewrite co_tfold_node; auto with cotree order;
    try reflexivity; intros; constructor.
Qed.

Definition atree_some {I A} (P : A -> Prop) : atree I A -> Prop :=
  tfold False P (fun k => exists i, k i).

Definition atree_all {I A} (P : A -> Prop) : atree I A -> Prop :=
  tfold True P (fun k => forall i, k i).

Definition cotree_some {A} (P : A -> Prop) : cotree bool A -> Prop :=
  co (atree_some P).

Definition cotree_all {A} (P : A -> Prop) : cotree bool A -> Prop :=
  coop (atree_all P).

Lemma monotone_exists {I} :
  Proper (leq ==> leq) (fun k : I -> Prop => exists i : I, k i).
Proof.
  intros f g; simpl; unfold impl; intros Hfg [i Hi].
  exists i; apply Hfg, Hi.
Qed.
#[global] Hint Resolve monotone_exists : cotree.

#[global]
  Instance monotone_atree_some {I A} (P : A -> Prop) : Proper (leq ==> leq) (@atree_some I A P).
Proof. apply monotone_tfold; auto with cotree order; intros ? []. Qed.
#[global] Hint Resolve monotone_atree_some : cotree.

Lemma cotree_some_bot {A} (P : A -> Prop) :
  ~ cotree_some P cobot.
Proof.
  intro HC; apply co_elim in HC; eauto with cotree order.
  destruct HC as [[] []].
Qed.

(** Introduction rule 1 for cotree_some. *)
Lemma cotree_some_intro_leaf {A} (P : A -> Prop) (a : A) :
  P a ->
  cotree_some P (coleaf a).
Proof with eauto with order cotree.
  unfold cotree_some, atree_some.
  rewrite co_tfold_leaf...
  intros [].
Qed.

(** Introduction rule 2 for cotree_some. *)
Lemma cotree_some_intro_node {A} (P : A -> Prop) (b : bool) (k : bool -> cotree bool A) :
  cotree_some P (k b) ->
  cotree_some P (conode k).
Proof with eauto with order cotree.
  unfold cotree_some, atree_some.
  rewrite co_tfold_node...
  { apply continuous_wcontinuous, continuous_exists. }
  { intros ? []. }
  intros [].
Qed.

(** Elimination rule 1 for cotree_some. *)
Lemma cotree_some_elim_leaf {A} (P : A -> Prop) (a : A) :
  cotree_some P (coleaf a) ->
  P a.
Proof with eauto with order cotree.
  unfold cotree_some, atree_some.
  rewrite co_tfold_leaf...
  intros [].
Qed.

(** Elimination rule 2 for cotree_some. *)
Lemma cotree_some_elim_node {A} (P : A -> Prop) (k : bool -> cotree bool A) :
  cotree_some P (conode k) ->
  exists b, cotree_some P (k b).
Proof with eauto with order cotree.
  unfold cotree_some, atree_some.
  rewrite co_tfold_node...
  { apply continuous_wcontinuous, continuous_exists. }
  { intros ? []. }
  intros [].
Qed.

Corollary continuous_cotree_some {A} (P : A -> Prop) :
  continuous (cotree_some P).
Proof. apply continuous_co, monotone_atree_some. Qed.

Lemma monotone_forall {I} :
  Proper (leq ==> leq) (fun k : I -> Prop => forall i : I, k i).
Proof. intros f g; simpl; unfold impl; intros Hfg Hf i; apply Hfg, Hf. Qed.
#[global] Hint Resolve monotone_forall : cotree.

#[global]
  Instance antimonotone_atree_all {I A} (P : A -> Prop)
  : Proper (leq ==> flip leq) (@atree_all I A P).
Proof.
  apply antimonotone_tfold; auto with cotree order; intros ? ?; constructor.
Qed.
#[global] Hint Resolve antimonotone_atree_all : cotree.

(** Introduction rule 1 for cotree_all. *)
Lemma cotree_all_intro_leaf {A} (P : A -> Prop) (a : A) :
  P a ->
  cotree_all P (coleaf a).
Proof with eauto with order cotree.
  unfold cotree_all, atree_all.
  rewrite coop_tfold_leaf...
  intro; apply I.
Qed.

(** Introduction rule 2 for cotree_all. *)
Lemma cotree_all_intro_node {A} (P : A -> Prop) (k : bool -> cotree bool A) :
  (forall b, cotree_all P (k b)) ->
  cotree_all P (conode k).
Proof with eauto with order cotree.
  unfold cotree_all, atree_all.
  rewrite coop_tfold_node...
  { apply dec_continuous_dec_wcontinuous, dec_continuous_forall. }
  { intros ? ?; apply I. }
  intro; apply I.
Qed.

(** Elimination rule 1 for cotree_all. *)
Lemma cotree_all_elim_leaf {A} (P : A -> Prop) (a : A) :
  cotree_all P (coleaf a) ->
  P a.
Proof with eauto with order cotree.
  unfold cotree_all, atree_all.
  rewrite coop_tfold_leaf...
  intro; apply I.
Qed.

(** Elimination rule 2 for cotree_all. *)
Lemma cotree_all_elim_node {A} (P : A -> Prop) (k : bool -> cotree bool A) (b : bool) :
  cotree_all P (conode k) ->
  cotree_all P (k b).
Proof with eauto with order cotree.
  unfold cotree_all, atree_all.
  rewrite coop_tfold_node...
  { intro H; apply H. }
  { apply dec_continuous_dec_wcontinuous, dec_continuous_forall. }
  { intros ? ?; apply I. }
  intro; apply I.
Qed.

Corollary cocontinuous_cotree_all {A} (P : A -> Prop) :
  cocontinuous (cotree_all P).
Proof. apply cocontinuous_coop, antimonotone_atree_all. Qed.

Lemma atree_some_exists {I A} (P : A -> Prop) (t : atree I A) :
  atree_some P t <-> exists x, atree_some (eq x) t /\ P x.
Proof.
  unfold atree_some.
  split.
  - revert P; induction t; simpl; intros P Hsome; firstorder.
    apply H in H0; destruct H0; firstorder.
  - revert P; induction t; simpl; intros P [x [Hsome Hx]]; subst; firstorder.
    eexists; apply H; exists x; split; eauto.
Qed.

Lemma atree_some_map {I A B} (P : B -> Prop) (t : atree I A) (f : A -> B) :
  atree_some P (atree_map f t) ->
  atree_some (P ∘ f) t.
Proof.
  unfold atree_some.
  revert P f; induction t; unfold compose; simpl; auto; intros P f [i Hi].
  exists i; apply H; auto.
Qed.

Lemma atree_map_some {I A B} (P : B -> Prop) (t : atree I A) (f : A -> B) :
  atree_some (P ∘ f) t ->
  atree_some P (atree_map f t).
Proof.
  unfold atree_some.
  revert P f; induction t; simpl; unfold compose; intros P f; auto.
  intros [i Hi]; exists i; apply H; auto.
Qed.

Lemma tprefix_map {A B} (t : cotree bool A) (f : A -> B) (i : nat) :
  tprefix i (cotree_map f t) = atree_map f (tprefix i t).
Proof.
  revert t f; induction i; intros t f; simpl; auto.
  destruct t; simpl.
  - rewrite cotree_map_bot; reflexivity.
  - rewrite cotree_map_leaf; reflexivity.
  - rewrite cotree_map_node; f_equal; ext x; apply IHi.
Qed.

Lemma atree_some_impl {I A} (t : atree I A) (P Q : A -> Prop) :
  (forall x, P x -> Q x) ->
  atree_some P t ->
  atree_some Q t.
Proof.
  unfold atree_some.
  revert P Q; induction t; simpl; intros P Q HPQ; auto.
  intros [i Hi]; exists i; eapply H; eauto.
Qed.

Lemma atree_all_map {I A B} (P : B -> Prop) (t : atree I A) (f : A -> B) :
  atree_all (P ∘ f) t ->
  atree_all P (atree_map f t).
Proof.
  unfold atree_all.
  revert P f; induction t; simpl; firstorder.
Qed.

Lemma atree_all_impl {I A} (t : atree I A) (P Q : A -> Prop) :
  (forall x, P x -> Q x) ->
  atree_all P t ->
  atree_all Q t.
Proof.
  unfold atree_all.
  revert P Q; induction t; simpl; firstorder.
Qed.

Definition atree_disjoint {I A} `{OType A} (a b : atree I A) : Prop :=
  atree_all (fun x => atree_all (incomparable x) b) a /\
    atree_all (fun x => atree_all (incomparable x) a) b.

Definition cotree_disjoint {A} `{OType A} (a b : cotree bool A) : Prop :=
  cotree_all (fun x => cotree_all (incomparable x) b) a /\
    cotree_all (fun x => cotree_all (incomparable x) a) b.

(** Can technically be generalized to arbitrary index type but it's
    cleaner this way for our use case.*)
Inductive atree_pairwise_disjoint {A} `{OType A} : atree bool A -> Prop :=
| atree_pairwise_disjoint_bot : atree_pairwise_disjoint abot
| atree_pairwise_disjoint_leaf : forall x, atree_pairwise_disjoint (aleaf x)
| atree_pairwise_disjoint_node : forall f,
    (forall i, atree_pairwise_disjoint (f i)) ->
    atree_disjoint (f true) (f false) ->
    atree_pairwise_disjoint (anode f).

Definition cotree_pairwise_disjoint {A} `{OType A} : cotree bool A -> Prop :=
  coop (atree_pairwise_disjoint).

#[global]
  Instance antimonotone_atree_pairwise_disjoint {A} `{OType A}
  : Proper (leq ==> flip leq) (@atree_pairwise_disjoint A _).
Proof.
  intro a; induction a; simpl; intros b Hab Hb; inv Hab; auto.
  - constructor.
  - inv Hb; constructor.
    + intro i; eapply H0; eauto; apply H2.
    + destruct H4 as [H4 H4'].
      split.
      * eapply antimonotone_atree_all.
        { apply H2. }
        eapply atree_all_impl; eauto.
        simpl; intros x Hx.
        eapply antimonotone_atree_all; eauto; apply H2.
      * eapply antimonotone_atree_all.
        { apply H2. }
        eapply atree_all_impl; eauto.
        simpl; intros x Hx.
        eapply antimonotone_atree_all; eauto; apply H2.
Qed.
#[global] Hint Resolve antimonotone_atree_pairwise_disjoint : cotree.

Lemma atree_all_true {I A} (t : atree I A) :
  atree_all (const True) t.
Proof. unfold const; induction t; firstorder. Qed.

Lemma atree_all_true' {I A} (P : A -> Prop) (t : atree I A) :
  (forall x, P x) ->
  atree_all P t.
Proof. intro; induction t; firstorder. Qed.

Lemma atree_cotree_bind_assoc {A B C}
  (t : atree bool A) (f : A -> cotree bool B) (g : B -> cotree bool C) :
  cotree_bind (atree_cotree_bind f t) g ===
    atree_cotree_bind (fun x : A => cotree_bind (f x) g) t.
Proof.
  unfold atree_cotree_bind.
  revert f g; induction t; intros f g; simpl.
  - rewrite cotree_bind_bot; reflexivity.
  - reflexivity.
  - rewrite cotree_bind_node.
    apply cotree_eq_equ; constructor; intro b; apply equ_cotree_eq, H.
Qed.

(** cotree_bind is associative. *)
Lemma cotree_bind_assoc {A B C}
  (t : cotree bool A) (f : A -> cotree bool B) (g : B -> cotree bool C) :
  cotree_bind (cotree_bind t f) g = cotree_bind t (fun x => cotree_bind (f x) g).
Proof.
  apply ext.
  unfold cotree_bind, tcofold.
  rewrite co_co''; eauto with cotree order.
  apply Proper_co'; eauto with cotree order; try reflexivity.
  { apply monotone_compose; eauto with cotree order.
    apply monotone_co; eauto with cotree order. }
  apply equ_arrow; unfold compose; intro a.
  apply atree_cotree_bind_assoc.
Qed.

Lemma atree_cotree_bind_tinj {A} :
  atree_cotree_bind (@coleaf bool A) = tinj.
Proof.
  unfold atree_cotree_bind.
  ext t; induction t; simpl; auto.
  f_equal; ext b; unfold compose; rewrite H; reflexivity.
Qed.

(** coleaf is the identity on the right wrt bind. *)
Lemma cotree_bind_id_r {A} (t : cotree bool A) :
  cotree_bind t (@coleaf bool A) = t.
Proof.
  apply ext.
  replace t with (id t) by reflexivity.
  symmetry.
  apply co_unique'; eauto with cotree order.
  intro b.
  unfold id, incl; simpl.
  rewrite <- atree_cotree_bind_tinj; reflexivity.
Qed.

#[global]
  Instance Proper_tinj {I A} : Proper (leq ==> leq) (@tinj I A).
Proof. intros a b Hab; induction Hab; simpl; constructor; auto. Qed.

Definition snip {A} (t : cotree bool (unit + A)) : cotree bool A :=
  cotree_bind t (cotuple (const cobot) (@coleaf bool A)).

Corollary snip_leaf {A} (x : unit + A) :
  snip (coleaf x) = match x with
                    | inl _ => cobot
                    | inr y => coleaf y
                    end.
Proof.
  unfold snip; rewrite cotree_bind_leaf.
  destruct x; reflexivity.
Qed.

Corollary snip_bind {A B} (t : cotree bool (unit + A)) (k : unit + A -> cotree bool (unit + B)) :
  snip (cotree_bind t k) = cotree_bind t (snip ∘ k).
Proof. apply cotree_bind_assoc. Qed.


Require Import LanguageUtil.
Require Import BasicProperties.
Require Import Extraction.

Lemma notin_fv_open_rec : forall x e1 e2 n,
    x # e1 <n> ^^ e2 -> x # e1.
Proof.
  intros. generalize dependent n. induction e1; simpl; intros; eauto.
Qed.

Lemma notin_fv_open_var : forall x e y,
    x # e ^` y -> x # e.
Proof.
  eauto using notin_fv_open_rec.
Qed.

Lemma notin_fv_open : forall x e1 e2,
    x # e1 ^^ e2 -> x # e1.
Proof.
  eauto using notin_fv_open_rec.
Qed.

Hint Resolve notin_fv_open : core.

Lemma fresh_ctx_fresh_expr : forall Γ a A x,
    Γ ⊢ a : A -> x `notin` dom Γ -> x # a.
Proof.
  intros. generalize dependent x.
  dependent induction H; intros; auto 3; simpl.
  - induction G.
    + inversion H0.
    + destruct a. inversion H. subst.
      destruct H0.
      * inversion H0. subst. simpl in H1. auto.
      * apply IHG; auto.
  - pick fresh x0. apply notin_union_3. auto.
    eapply notin_fv_open_var. apply H3; auto.
  - pick fresh x0. apply notin_union_3. auto.
    eapply notin_fv_open_var. apply H3; auto.
  - pick fresh x0. apply notin_union_3; auto.
    eapply notin_fv_open_var. apply H3; auto.
  - pick fresh x0. apply notin_union_3; auto.
    eapply notin_fv_open_var. apply H2; auto.
  - pick fresh x0. apply notin_union_3; auto.
    eapply notin_fv_open_var. apply H4; auto.
  - pick fresh x0. apply notin_union_3; auto.
    eapply notin_fv_open_var. apply H1; auto.
Qed.

Lemma fresh_ctx_fresh_expr_l : forall Γ a b A x,
    Γ ⊢ a <: b : A -> x `notin` dom Γ -> x # a.
Proof.
  intros.
  apply reflexivity_l in H. eauto 2 using fresh_ctx_fresh_expr.
Qed.

Lemma fresh_ctx_fresh_expr_r : forall Γ a b A x,
    Γ ⊢ a <: b : A -> x `notin` dom Γ -> x # b.
Proof.
  intros.
  apply reflexivity_r in H. eauto 2 using fresh_ctx_fresh_expr.
Qed.

Lemma fresh_ctx_fresh_type : forall Γ e1 e2 A x,
    Γ ⊢ e1 <: e2 : A -> x `notin` dom Γ -> x # A.
Proof.
  intros * Sub. induction Sub; intros; simpl in *;
                  eauto 3 using fresh_ctx_fresh_expr.
  - induction G.
    + auto.
    + destruct a. inversion H. subst. destruct H0.
      * inversion H0. subst. eapply fresh_ctx_fresh_expr; eauto.
      * eapply IHG; eauto.
  - pick fresh x'. apply notin_union_3; eauto using fresh_ctx_fresh_expr.
  - apply fresh_open; eauto 3 using fresh_ctx_fresh_expr.
    specialize (IHSub2 H0). auto.
  - pick fresh x'. apply notin_union_3; eauto using fresh_ctx_fresh_expr.
Qed.

Ltac solve_simple_freshness :=
  match goal with
  | _ : ?x `notin` dom ?Γ |- ?x # ?e =>
    match goal with
    | _ : Γ ⊢ e <: _ : _ |- _ => eapply fresh_ctx_fresh_expr_l; eassumption
    | _ : Γ ⊢ _ <: e : _ |- _ => eapply fresh_ctx_fresh_expr_r; eassumption
    | _ : Γ ⊢ _ <: _ : e |- _ => eapply fresh_ctx_fresh_type; eassumption
    end
  end
.

Hint Extern 1 (_ # _) => solve_simple_freshness : core.

Lemma fresh_binded : forall Γ1 x A Γ2,
    ⊢ Γ1 , x : A ,, Γ2 -> x # A.
Proof.
  induction Γ2; simpl; intros.
  - inversion H. subst. eapply fresh_ctx_fresh_expr; eauto.
  - apply IHΓ2. now inversion H.
Qed.

Lemma notin_dom_bind_fresh : forall Γ x A x',
    x' `notin` dom Γ -> x : A ∈ Γ -> ⊢ Γ -> x' # A.
Proof.
  induction Γ; simpl; intros.
  - inversion H0.
  - destruct a. inversion H1. subst. destruct H0.
    + inversion H0. subst. destruct (eq_dec x' x);
        eauto using fresh_ctx_fresh_expr.
    + apply IHΓ with x; auto.
Qed.

Lemma notin_open_var_notin_open_rec : forall e x n,
    x `notin` fv_eexpr (e ⋆n^^ (ee_var_f x)) ->
    forall v, e ⋆n^^ v = e.
Proof.
  intros e x.
  induction e; unfold open_eexpr_wrt_eexpr in *; simpl; intros; auto;
    try solve [rewrite IHe; auto | rewrite IHe1; auto; rewrite IHe2; auto].
  - destruct (n0 == n).
    + contradict H. simpl. auto.
    + easy.
Qed.

Lemma notin_open_var_notin_open : forall e x v,
    x `notin` fv_eexpr (e ⋆^` x) ->
    e ⋆^^ v = e.
Proof.
  intros.
  eapply notin_open_var_notin_open_rec; auto.
Qed.