Require Import Category.Setoids.
Require Import Category.Types.
Require Import Category.Types_Setoids.
Require Import Category.RComod.
Require Import Category.RComonad.
Require Import Category.Stream.Category.
Require Import Category.Stream.Axioms.
Require Import Theory.Category.
Require Import Theory.InitialTerminal.
Require Import Theory.Functor.
Require Import Theory.RelativeComonad.
Require Import Theory.Comodule.
Require Import Theory.Product.
Require Import Theory.PrecompositionWithProduct.
Require Import Theory.PushforwardComodule.

Generalizable All Variables.

(*------------------------------------------------------------------------------
  -- ＳＴＲＥＡＭ  ＩＳ  ＴＥＲＭＩＮＡＬ  ＩＮ  ＳＴＲＥＡＭ
  ----------------------------------------------------------------------------*)
(** * Stream is terminal in Streams **)

(* begin hide *)
Ltac clean_hyps := repeat match goal with H : _ |- _ => clear H end.
(* end hide *)

Module StreamTerminal (Import Ax : StreamAxioms).

  (** ** -∼- is an equivalence relation **)
  Lemma bisim_refl : ∀ {A} {s : Stream A}, s ∼ s.
  Proof.
    intros. apply bisim_intro with (R := λ s₁ s₂ ∙ s₁ = s₂); [clean_hyps; intros..|auto].
    - subst; reflexivity.
    - subst; reflexivity.
  Qed.

  Lemma bisim_sym : ∀ {A} {s₁ s₂ : Stream A}, s₁ ∼ s₂ → s₂ ∼ s₁.
  Proof.
    intros.
    apply bisim_intro with (R := λ s₁ s₂ ∙ s₂ ∼ s₁); [clean_hyps; intros..|auto].
    - symmetry; now apply bisim_head.
    - now apply bisim_tail.
  Qed.

  Lemma bisim_trans : ∀ {A} {s₁ s₂ s₃ : Stream A}, s₁ ∼ s₂ → s₂ ∼ s₃ → s₁ ∼ s₃.
  Proof.
    intros.
    apply bisim_intro with (R := λ s₁ s₃ ∙ ∃ s₂, s₁ ∼ s₂ ∧ s₂ ∼ s₃);
    [clean_hyps; intros.. | eauto].
    - destruct H as (? & ? & ?).
      etransitivity. eapply bisim_head; eauto.
      now apply bisim_head.
    - destruct H as (? & ? & ?).
      eexists; split; eapply bisim_tail; eauto.
  Qed.

  Instance bisim_equiv : ∀ {A}, Equivalence (@bisim A).
  Proof.
    constructor; repeat intro.
    - now apply bisim_refl.
    - now apply bisim_sym.
    - eapply bisim_trans; eauto.
  Qed.

  Lemma eq_bisim : ∀ {A} {s₁ s₂ : Stream A}, s₁ = s₂ → s₁ ∼ s₂.
  Proof.
    intros. now rewrite H.
  Qed.

  (** ** Stream as a setoid **)
  Program Definition STREAM (A : Type) : Setoids.Obj :=
    Setoids.make ⦃ Carrier ≔ Stream A ; Equiv ≔ bisim ⦄.

  (** ** head & tail are setoids morphisms **)
  Lemma head_cong : ∀ {A} {s₁ s₂ : Stream A}, s₁ ∼ s₂ → head s₁ = head s₂.
  Proof.
    intros A s₁ s₂ eq_s₁s₂. now apply bisim_head.
  Qed.

  Lemma tail_cong : ∀ {A} {s₁ s₂ : Stream A}, s₁ ∼ s₂ → tail s₁ ∼ tail s₂.
  Proof.
    intros A s₁ s₂ eq_s₁s₂. now apply bisim_tail.
  Qed.

  Program Definition 𝒉𝒆𝒂𝒅 {A} : STREAM A ⇒ 𝑬𝑸 A := Setoids.Morphism.make head.
  (** head-cong **)
  Next Obligation.
    now apply head_cong.
  Qed.

  Program Definition 𝒕𝒂𝒊𝒍 {A} : STREAM A ⇒ STREAM A := Setoids.Morphism.make tail.
  (** tail-cong **)
  Next Obligation.
    now apply tail_cong.
  Qed.

  (** ** Cosubstitution for streams **)
  Definition cosubst {A B : 𝑻𝒚𝒑𝒆} (f : Stream A ⇒ B) : Stream A ⇒ Stream B :=
    corec f tail.

  (** ** Stream is a relative comonad over EQ **)
  Obligation Tactic := idtac.
  Program Definition 𝑺𝒕𝒓 : ‵ 𝑹𝑪𝒐𝒎𝒐𝒏𝒂𝒅 𝑬𝑸 ′ :=
    RelativeComonad.make  ⦃ T       ≔ STREAM
                          ; counit  ≔ λ X ∙ 𝒉𝒆𝒂𝒅
                          ; cobind  ≔ λ X Y ∙ λ f ↦ Setoids.Morphism.make (cosubst f) ⦄.
  (** cosubst-cong **)
  Next Obligation.
    intros.
    apply bisim_intro with (λ s₁ s₂ ∙ ∃ x y, x ∼ y ∧ s₁ = cosubst f x ∧ s₂ = cosubst f y)
    ; [clean_hyps; intros..|eauto].
    - destruct H as (x & y & eq_xy & -> & ->).
      unfold cosubst. repeat rewrite head_corec.
      now rewrite eq_xy.
    - destruct H as (x & y & eq_xy & -> & ->).
      exists (tail x). exists (tail y).
      split; [|split].
      + now apply bisim_tail.
      + unfold cosubst at 1. rewrite tail_corec. reflexivity.
      + unfold cosubst at 1. rewrite tail_corec. reflexivity.
  Qed.
  (** cosubst-cong₂ **)
  Next Obligation.
    intros X Y f g eq_fg x y eq_xy. simpl.
    apply bisim_intro with (λ s₁ s₂ ∙ ∃ x y, x ∼ y ∧ s₁ = cosubst f x ∧ s₂ = cosubst g y); [intros..|eauto].
    - destruct H as (x' & y' & eq_xy' & -> & ->).
      unfold cosubst; repeat rewrite head_corec.
      etransitivity. eapply (Setoids.cong f). apply eq_xy'.
      now apply eq_fg.
    - destruct H as (x' & y' & eq_xy' & -> & ->).
      exists (tail x'). exists (tail y').
      split; [|split].
      + now apply bisim_tail.
      + unfold cosubst at 1. rewrite tail_corec. reflexivity.
      + unfold cosubst at 1. rewrite tail_corec. reflexivity.
  Qed.
  (** cobind-counit **)
  Next Obligation.
    simpl. intros.
    apply bisim_intro with (λ s₁ s₂ ∙ ∃ x y, x ∼ y ∧ s₁ = cosubst head x ∧ s₂ = y); [clean_hyps; intros..|eauto].
    - destruct H as (x & y & eq_xy & -> & ->).
      unfold cosubst; rewrite head_corec; now apply head_cong.
    - destruct H as (x & y & eq_xy & -> & ->).
      exists (tail x). exists (tail y).
      split; [|split].
      + now apply bisim_tail.
      + unfold cosubst at 1. rewrite tail_corec. reflexivity.
      + reflexivity.
  Qed.
  (** counit-cobind **)
  Next Obligation.
    repeat intro. rewrite H. simpl. unfold cosubst. now rewrite head_corec.
  Qed.
  (** cobind-cobind **)
  Next Obligation.
    intros X Y Z f g x y eq_xy. rewrite <- eq_xy. clear y eq_xy. simpl.
    apply bisim_intro with (λ s₁ s₂ ∙ ∃ x, s₁ = cosubst g (cosubst f x) ∧ s₂ = cosubst (λ y ∙ g (cosubst f y)) x);
    [clean_hyps; intros..|eauto].
    - destruct H as (x & -> & ->).
      unfold cosubst. repeat rewrite head_corec. reflexivity.
    - destruct H as (x & -> & ->).
      exists (tail x). split.
      + unfold cosubst. now do 2 rewrite tail_corec.
      + unfold cosubst. now rewrite tail_corec.
  Qed.

  (** ** Stream coalgebra **)
  Program Definition 𝑻𝒂𝒊𝒍 : ‵ [𝑺𝒕𝒓] ⇒ [𝑺𝒕𝒓] ′ :=
    Comodule.make ⦃ α ≔ λ A ∙ Setoids.Morphism.make 𝒕𝒂𝒊𝒍 ⦄.
  (** tail-cong **)
  Next Obligation.
    intros A x y eq_xy; now rewrite eq_xy.
  Qed.
  (** α-commutes **)
  Next Obligation.
    intros C D f x y eq_xy. rewrite eq_xy. apply eq_bisim. simpl. unfold cosubst. now rewrite tail_corec.
  Qed.

  Program Definition 𝑺𝑻𝑹 : ‵ 𝑺𝒕𝒓𝒆𝒂𝒎 ′ :=
    Stream.make ⦃ T ≔ 𝑺𝒕𝒓 ; tail ≔ 𝑻𝒂𝒊𝒍 ⦄.

  (** ** 𝑺𝑻𝑹 is a terminal object **)

  Section Defs.

    Variable (Tr : 𝑺𝒕𝒓𝒆𝒂𝒎).

    Notation T                  := (Stream.T Tr).
    Notation "'T⋅tail'"         := (Stream.tail Tr _).
    Notation "'T⋅tail[' A ]"    := (Stream.tail Tr A) (only parsing).
    Notation STR                := (Stream.T 𝑺𝑻𝑹).
    Notation "'STR⋅tail'"       := (Stream.tail 𝑺𝑻𝑹 _).
    Notation "'STR⋅tail[' A ]"  := (Stream.tail 𝑺𝑻𝑹 A) (only parsing).

    Local Notation "a ∼ b" := (SEquiv a b).

    Definition tau {A} : T A → STR A := corec T⋅counit T⋅tail.

    Lemma head_tau : ∀ A (t : T A), STR⋅counit (tau t) = T⋅counit t.
    Proof.
      intros. unfold tau. simpl. now rewrite head_corec.
    Qed.

    Lemma tail_tau : ∀ A (t : T A), STR⋅tail (tau t) = tau (T⋅tail t).
    Proof.
      intros. unfold tau. simpl. now rewrite tail_corec.
    Qed.

    Lemma tau_cong : ∀ A (x y : T A), x ∼ y → tau x ∼ tau y.
    Proof.
      intros.
      apply bisim_intro with (λ s₁ s₂ ∙ ∃ x y, x ∼ y ∧ s₁ = tau x ∧ s₂ = tau y);
      [clean_hyps; intros..|eauto].
      - destruct H as (x & y & eq_xy & -> & ->).
        unfold tau. repeat rewrite head_corec. now rewrite eq_xy.
      - destruct H as (x & y & eq_xy & -> & ->).
        exists (T⋅tail x). exists (T⋅tail y). split; [|split].
        + now rewrite eq_xy.
        + unfold tau. now rewrite tail_corec.
        + unfold tau. now rewrite tail_corec.
    Qed.

    Program Definition Tau {A} : T A ⇒ STR A :=
      Setoids.Morphism.make tau.
    (** tau-cong **)
    Next Obligation.
      intros. now apply tau_cong.
    Qed.

    Lemma tau_counit : ∀ A (t t' : T A), t ∼ t' → T⋅counit t ∼ STR⋅counit (tau t').
    Proof.
      intros A t t' eq_tt'. rewrite eq_tt'. simpl. unfold tau. now rewrite head_corec.
    Qed.

    Lemma tau_cobind : ∀ A B (f : STR A ⇒ 𝑬𝑸 B) x y, x ∼ y → Tau (T⋅cobind (f ∘ Tau) x) ∼ STR⋅cobind f (Tau y).
    Proof.
      intros A B f x y eq_xy. rewrite <- eq_xy. clear y eq_xy.
      apply bisim_intro with (λ s₁ s₂ ∙ ∃ x, s₁ ∼ Tau (T⋅cobind (f ∘ Tau) x) ∧ s₂ ∼ STR⋅cobind f (Tau x));
      [clean_hyps;intros..|eauto].
      - destruct H as (x & ? & ?).
        etransitivity. eapply head_cong. apply H.
        symmetry; etransitivity. eapply head_cong; apply H0.
        simpl. unfold tau, cosubst. repeat rewrite head_corec.
        symmetry. etransitivity. apply (counit_cobind T). reflexivity.
        reflexivity.
      - destruct H as (x & ? & ?).
        exists (T⋅tail x). split.
        etransitivity. eapply tail_cong. apply H.
        simpl. unfold tau. repeat rewrite tail_corec.
        apply tau_cong. etransitivity. apply (α_commutes (Stream.tail Tr)). reflexivity.
        simpl. reflexivity.
        etransitivity. eapply tail_cong. apply H0.
        simpl. unfold tau, cosubst. repeat rewrite tail_corec. reflexivity.
      - exists x; split; reflexivity.
    Qed.

  End Defs.

  (** printing τ #◯# *)

  (** ◯ is a morphism of triangles **)
  Program Definition τ (T : 𝑺𝒕𝒓𝒆𝒂𝒎) : T ⇒ 𝑺𝑻𝑹 :=
    Stream.make ⦃ τ ≔ RelativeComonad.make ⦃ τ ≔ λ A ∙ Tau T ⦄ ⦄.
  (** τ-counit **)
  Next Obligation.
    repeat intro. now apply tau_counit.
  Qed.
  (** τ-cobind **)
  Next Obligation.
    repeat intro. now apply tau_cobind.
  Qed.
  (** τ-commutes **)
  Next Obligation.
    repeat intro. rewrite H. simpl. unfold tau. repeat rewrite tail_corec. reflexivity.
  Qed.

  (* begin hide *)
  Local Notation "⟨ f ⟩" := (RelativeComonad.τ (m := Stream.τ f)) (only parsing).
  (* end hide *)

  (** 𝑺𝑻𝑹 is a terminal object **)
  Program Definition Terminality : Terminal 𝑺𝒕𝒓𝒆𝒂𝒎 :=
    Terminal.make  ⦃ one  ≔ 𝑺𝑻𝑹
                   ; top  ≔ τ ⦄.
  (** top-unique **)
  Next Obligation.
    intros A f X x y eq_xy. rewrite <- eq_xy. clear y eq_xy. simpl.
    apply bisim_intro with (λ s₁ s₂ ∙ ∃ x, s₁ ∼ ⟨f⟩ _ x ∧ s₂ ∼ tau A x); [clean_hyps; intros..|].
    - destruct H as (? & ? & ?).
      etransitivity. eapply head_cong. apply H.
      symmetry; etransitivity. eapply head_cong. apply H0.
      unfold tau. rewrite head_corec. symmetry. etransitivity. symmetry. apply (τ_counit (Stream.τ f)).
      reflexivity. reflexivity.
    - destruct H as (? & ? & ?).
      exists (Stream.tail A _ x). split.
      + etransitivity. eapply tail_cong. apply H.
        etransitivity. symmetry. eapply (Stream.τ_commutes f). reflexivity.
        reflexivity.
      + etransitivity. eapply tail_cong. apply H0.
        unfold tau. rewrite tail_corec. reflexivity.
    - exists x. split; reflexivity.
  Qed.

End StreamTerminal.


Require Import compcert.lib.Coqlib compcert.lib.Zbits.
Require Import compcert.common.AST compcert.lib.Integers.
Require Import compcert.common.Values compcert.common.Memory.
Require Import compcert.common.Globalenvs compcert.common.Events.

Inductive int_or_ptr: val -> mem -> val -> Prop :=
  | int_or_ptr_int: forall n m,
      Int.and n Int.one = Int.one ->
      int_or_ptr (Vint n) m Vfalse
  | int_or_ptr_ptr: forall b ofs m,
      Mem.range_perm m b (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + 2) Cur Nonempty ->
      Ptrofs.and ofs Ptrofs.one = Ptrofs.zero ->
      int_or_ptr (Vptr b ofs) m Vtrue.

Remark ptrofs_2_aligned: forall ofs,
  Ptrofs.and ofs Ptrofs.one = Ptrofs.zero <-> (2 | Ptrofs.unsigned ofs).
Proof.
  assert (A: forall n, (2 | n) <-> Z.Even n).
  { intros; split; intros [k E]; rewrite E; exists k; ring. }
  assert (B: forall n, Z.Even n <-> Z.testbit n 0 = false).
  { intros. rewrite Z.bit0_odd, <- Z.negb_even, <- Z.even_spec, negb_false_iff. tauto. }
  intros; split; intros.
- apply A. apply B. change false with (Ptrofs.testbit Ptrofs.zero 0). rewrite <- H.
  rewrite Ptrofs.bits_and, Ptrofs.bits_one. simpl. rewrite andb_true_r; auto.
  generalize Ptrofs.wordsize_pos; omega.
- apply A in H. apply B in H. Ptrofs.bit_solve. rewrite Ptrofs.bits_one.
  destruct (zeq i 0); simpl.
  rewrite andb_true_r. subst i. exact H.
  apply andb_false_r.
Qed.

Lemma int_or_ptr_inject:
  forall v m res f v' m',
  int_or_ptr v m res ->
  Val.inject f v v' ->
  Mem.inject f m m' ->
  exists res', int_or_ptr v' m' res' /\ Val.inject f res res'.
Proof.
  destruct 1; intros VI MI; inv VI.
- (* integer *)
  exists Vfalse; split.
+ constructor; auto.
+ constructor.
- (* pointer *)
  assert (AL: (2 | delta)).
  { change 2 with (align_chunk Mint16unsigned). clear H0.
    eauto using Mem.mi_align, Mem.mi_inj, Mem.range_perm_max. }
  assert (OF: Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta)) = Ptrofs.unsigned ofs + delta).
  { eapply Mem.address_inject; eauto. apply H. omega. }
  exists Vtrue; split.
+ constructor.
* rewrite OF. replace (Ptrofs.unsigned ofs + delta + 2) with ((Ptrofs.unsigned ofs + 2) + delta) by omega.
  eapply Mem.range_perm_inject; eauto.
* apply ptrofs_2_aligned in H0. apply ptrofs_2_aligned. rewrite OF.
  apply Z.divide_add_r; auto.
+ constructor.
Qed.


Require Import
  HoTT.Types.Universe
  HoTT.Basics.Decidable
  HoTT.HSet
  HoTT.Basics.PathGroupoids
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.orders.lattices
  HoTT.Classes.theory.lattices
  HoTTClasses.partiality
  HoTT.Classes.implementations.peano_naturals.

Local Set Universe Minimization ToSet.

Definition Sier := partial Unit.

Global Instance SierLe : Le Sier := _.
Arguments SierLe _ _ /.

Global Instance SierBot : Bottom Sier := bot _.

Global Instance SierTop : Top Sier := eta _ tt.

Definition IsTop (s : Sier) : Type0 := top <= s.
Coercion IsTop : Sier >-> Sortclass.

Section contents.
Context `{Funext} `{Univalence}.

Instance Sier_order : PartialOrder SierLe := partial_order _.

Lemma top_greatest : forall x : Sier, x <= top.
Proof.
apply (partial_ind0 _ _).
- intros [];reflexivity.
- apply bot_least.
- intros f IH. apply sup_le_r. exact IH.
Qed.

(* We need this for the bot_least case. *)
Definition SierJoin_aux : forall y : Sier, Sier -> sigT (fun j : Sier => y <= j).
Proof.
intros y. apply (partial_rec Unit _ (fun a b => a.1 <= b.1)).
simple refine (Build_Recursors _ _ _ _ _ _ _ _ _ _ _ _);simpl.
- intros _;exists top. apply top_greatest.
- exists y;reflexivity.
- intros f IH. simpl in IH. simple refine (existT _ _ _);simpl.
  + apply sup. exists (fun n => (f n).1).
    exact IH.
  + transitivity ((f O).1).
    * apply ((f O).2).
    * exact (sup_is_ub _ {| seq := fun n : nat => (f n).1; seq_increasing := IH |} O).
- intros;reflexivity.
- simpl. apply pr2.
- simpl. intros s p x. apply sup_le_l.
- simpl. intros s p x IH. apply sup_le_r.
  apply IH.
- intros a b E1 E2. apply Sigma.path_sigma_hprop.
  apply (antisymmetry le);trivial.
Defined.

Global Instance SierJoin : Join Sier
  := fun x y => (SierJoin_aux y x).1.

Definition SierJoin_top : forall x : Sier, join top x = top
  := fun _ => idpath.

Definition SierJoin_bot : forall x : Sier, join bottom x = x
  := fun _ => idpath.

Instance SierJoin_preserve_le_l : forall y, OrderPreserving (fun x => join x y)
  := fun y => partialLe_rec _ _ (fun a b => a.1 <= b.1) _.

Definition SierJoin_seq_l : IncreasingSequence Sier -> Sier ->
  IncreasingSequence Sier.
Proof.
intros s y;exists (fun n => join (s n) y).
intros n;apply (order_preserving (fun x => join x y)). apply seq_increasing.
Defined.

Definition SierJoin_sup : forall s (y : Sier),
  join (sup _ s) y = sup _ (SierJoin_seq_l s y)
  := fun _ _ => idpath.

Definition SierJoin_ub_r : forall x y : Sier, y <= join x y
  := fun x y => (SierJoin_aux y x).2.

Instance SierJoin_is_join : JoinSemiLatticeOrder SierLe.
Proof.
split.
- apply _.
- intros x y;revert x;apply (partial_ind0 _ _).
  + intros [];reflexivity.
  + apply bot_least.
  + intros s IH. apply sup_le_r.
    intros n. change (join (sup Unit s) y) with (sup Unit (SierJoin_seq_l s y)).
    etransitivity;[apply IH|].
    exact (sup_is_ub _ (SierJoin_seq_l s y) _).
- apply SierJoin_ub_r.
- apply (partial_ind0 _ (fun x => forall y z, _ -> _ -> _)).
  + intros [] y z E1 E2. apply E1.
  + intros y z E1 E2. apply E2.
  + intros s IH y z E1 E2.
    apply (sup_le_r _ (SierJoin_seq_l s y)).
    intros n. apply IH;trivial.
    apply sup_le_l. trivial.
Qed.

Global Instance SierMeet : Meet Sier.
Proof.
intros x y;revert x;apply (partial_rec Unit _ le).
simple refine (Build_Recursors _ _ _ _ _ _ _ _ _ _ _ _);simpl.
- intros _;exact y.
- exact bottom.
- intros f IH;simpl in IH.
  apply sup. exists f. exact IH.
- reflexivity.
- apply bot_least.
- intros s p x IH;apply (sup_le_l _ _ _ IH).
- intros s p x IH;apply sup_le_r. apply IH.
Defined.

Definition SierMeet_top : forall x : Sier, meet top x = x
  := fun _ => idpath.

Definition SierMeet_bot : forall x : Sier, meet bottom x = bottom
  := fun _ => idpath.

Instance SierMeet_preserve_le_l : forall y, OrderPreserving (fun x => meet x y)
  := fun y => partialLe_rec _ _ le _.

Definition SierMeet_seq_l : IncreasingSequence Sier -> Sier ->
  IncreasingSequence Sier.
Proof.
intros s y;exists (fun n => meet (s n) y).
intros n;apply (order_preserving (fun x => meet x y)). apply seq_increasing.
Defined.

Definition SierMeet_sup : forall s (y : Sier),
  meet (sup _ s) y = sup _ (SierMeet_seq_l s y)
  := fun _ _ => idpath.

Lemma SierMeet_is_meet@{} : MeetSemiLatticeOrder SierLe.
Proof.
split.
- apply _.
- intros x y;revert x. apply (partial_ind0 _ _).
  + intros []. apply top_greatest.
  + intros;apply bot_least.
  + intros s IH.
    change (sup Unit s ⊓ y) with (sup _ (SierMeet_seq_l s y)).
    apply sup_le_r. intros n. simpl.
    etransitivity;[apply IH|]. apply sup_is_ub.
- intros x y;revert x. apply (partial_ind0 _ _).
  + reflexivity.
  + apply bot_least.
  + intros s IH.
    change (sup Unit s ⊓ y) with (sup _ (SierMeet_seq_l s y)).
    apply sup_le_r. simpl. intros n;apply IH.
- apply (partial_ind0 _ (fun x => forall y z, _ -> _ -> _)).
  + intros [] y z E1 E2. apply E2.
  + intros y z E1 E2. apply E1.
  + intros s IH y z;revert z y.
    apply (partial_ind0 _ (fun z => forall y, _ -> _ -> _)).
    * intros [] y E1 E2.
      apply (eta_le_sup _) in E1.
      revert E1;apply (Trunc_ind _);intros [n E1].
      transitivity (meet (s n) y);auto.
      exact (sup_is_ub _ (SierMeet_seq_l _ _) _).
    * intros;apply bot_least.
    * intros s' IH' y E1 E2.
      apply sup_le_r. intros n.
      apply IH';(transitivity (sup _ s');[apply sup_is_ub|]);trivial.
Qed.
Existing Instance SierMeet_is_meet.

Section distrib_lattice.

Local Instance Sier_lattice_order : LatticeOrder SierLe := {}.
Local Existing Instance join_sl_order_join_sl.
Local Existing Instance meet_sl_order_meet_sl.

Global Instance Sier_distributive_lattice : DistributiveLattice Sier.
Proof.
repeat (split;try apply _).
- hnf. intros a b. apply (antisymmetry le).
  + apply join_le.
    * reflexivity.
    * apply meet_lb_l.
  + apply join_ub_l.
- hnf. intros a b. apply (antisymmetry le).
  + apply meet_lb_l.
  + apply meet_le.
    * reflexivity.
    * apply join_ub_l.
- hnf. intros a b c. apply (antisymmetry le).
  + apply join_le; apply meet_le.
    * apply join_ub_l.
    * apply join_ub_l.
    * transitivity b.
      { apply meet_lb_l. }
      { apply join_ub_r. }
    * transitivity c.
      { apply meet_lb_r. }
      { apply join_ub_r. }
  + revert a b c. apply (partial_ind0 _ (fun a => forall b c, _)).
    * intros [] b c. reflexivity.
    * reflexivity.
    * intros s IH b c.
      rewrite !SierJoin_sup,SierMeet_sup.
      apply sup_le_r. intros n.
      simpl. rewrite (commutativity (f:=meet)),SierMeet_sup;simpl.
      apply sup_le_r;intros m.
      simpl.
      assert (E : exists k, n <= k /\ m <= k)
      by (destruct (total le n m) as [E|E];eauto).
      destruct E as [k [En Em]].
      etransitivity;[|apply (sup_is_ub _ _ k)].
      simpl. etransitivity;[|apply IH].
      apply meet_le.
      { etransitivity;[apply meet_lb_r|].
        apply join_le;[|apply join_ub_r].
        transitivity (s k);[|apply join_ub_l].
        apply (order_preserving s). trivial. }
      { etransitivity;[apply meet_lb_l|].
        apply join_le;[|apply join_ub_r].
        transitivity (s k);[|apply join_ub_l].
        apply (order_preserving s). trivial. }
Qed.

End distrib_lattice.
Local Existing Instance join_sl_order_join_sl.
Local Existing Instance meet_sl_order_meet_sl.

Fixpoint joined_seq_aux (f : nat -> Sier) (n : nat) : Sier :=
  match n with
  | O => f O
  | S k => join (joined_seq_aux f k) (f n)
  end.

Definition joined_seq (f : nat -> Sier) : IncreasingSequence Sier.
Proof.
exists (joined_seq_aux f).
intros;simpl. apply join_ub_l.
Defined.

Definition CountableSup (f : nat -> Sier) : Sier
  := sup _ (joined_seq f).

Lemma joined_seq_ub_n : forall f n, f n <= joined_seq f n.
Proof.
intros f [|n].
- reflexivity.
- simpl. apply join_ub_r.
Qed.

Lemma countable_sup_ub : forall f n, f n <= CountableSup f.
Proof.
intros. transitivity (joined_seq f n).
- apply joined_seq_ub_n.
- unfold CountableSup. apply sup_is_ub.
Qed.

Lemma joined_seq_least_ub_n' : forall f n x, (forall m, m <= n -> f m <= x) ->
  joined_seq f n <= x.
Proof.
intros f;induction n as [|n IHn];intros x E.
- simpl. apply E. reflexivity.
- simpl. apply join_le.
  + apply IHn. intros m Em;apply E.
    constructor;trivial.
  + apply E. reflexivity.
Qed.

Definition joined_seq_least_ub_n@{} := joined_seq_least_ub_n'@{Set Ularge Set}.

Lemma countable_sup_least_ub : forall f x, (forall n, f n <= x) ->
  CountableSup f <= x.
Proof.
intros f x E. apply sup_le_r.
intros n. apply joined_seq_least_ub_n. intros m _;apply E.
Qed.

Lemma top_le_meet : forall a b : Sier, meet a b <-> a /\ b.
Proof.
unfold IsTop. intros a b;split.
- intros E;split;transitivity (meet a b);trivial.
  + apply meet_lb_l.
  + apply meet_lb_r.
- intros [E1 E2]. apply meet_le;trivial.
Qed.

Lemma top_le_join@{} : forall a b : Sier, join a b <-> hor a b.
Proof.
unfold IsTop. intros a b;split.
- revert a b;apply (partial_ind0 _ (fun a => forall b, _ -> _)).
  + intros [] ? E;apply tr;left;apply E.
  + intros b E;apply tr;right;apply E.
  + intros s IH b E.
    change (top <= sup _ (SierJoin_seq_l s b)) in E.
    apply (eta_le_sup _) in E. revert E. apply (Trunc_ind _).
    intros [n E]. simpl in E.
    apply IH in E. revert E;apply (Trunc_ind _).
    intros [E|E];apply tr;[left|right;trivial].
    transitivity (s n);trivial. apply sup_is_ub.
- apply (Trunc_ind _);intros [E|E].
  + transitivity a;auto. apply join_ub_l.
  + transitivity b;auto. apply join_ub_r.
Qed.

Lemma top_le_joined_seq_n' : forall f n, joined_seq f n <->
  merely (exists m, m <= n /\ f m).
Proof.
unfold IsTop. intros f;induction n as [|n IHn];simpl;
(split;[intros E|apply (Trunc_ind _);intros [m [Em E]]]).
- apply tr;exists 0;split;trivial. reflexivity.
- rewrite (antisymmetry le m 0 Em (zero_least m)) in E. trivial.
- apply top_le_join in E. revert E;apply (Trunc_ind _);intros [E|E].
  + apply IHn in E;revert E;apply (Trunc_ind _);intros [m [E1 E2]].
    apply tr;exists m;split;trivial. constructor;trivial.
  + apply tr;exists (S n);split;trivial. reflexivity.
- apply le_S_either in Em. destruct Em as [Em|Em].
  + transitivity (joined_seq f n);[|apply join_ub_l].
    apply IHn. apply tr;exists m;auto.
  + rewrite <-Em. transitivity (f m);auto. apply join_ub_r.
Qed.

Definition top_le_joined_seq_n@{} := top_le_joined_seq_n'@{Set Ularge Set Set}.

Lemma top_le_sup@{} : forall (s : IncreasingSequence Sier),
  IsTop (sup Unit s) <-> merely@{Set} (exists n, s n).
Proof.
intros s;split.
- intros E.
  apply (eta_le_sup _) in E.
  exact E.
- apply (Trunc_ind _);intros [n E].
  red;transitivity (s n);trivial.
  apply sup_is_ub.
Qed.

Lemma top_le_countable_sup@{} : forall f, CountableSup f <->
  merely (exists n, f n).
Proof.
unfold IsTop. intros f;split.
- intros E.
  apply (eta_le_sup _) in E.
  revert E;apply (Trunc_ind _);intros [n E].
  apply top_le_joined_seq_n in E. revert E;apply (Trunc_ind _);intros [m [_ E]].
  apply tr;exists m;trivial.
- apply (Trunc_ind _);intros [n E].
  transitivity (f n);trivial. apply countable_sup_ub.
Qed.

Lemma countable_sup_meet_distr_r : forall a f,
  meet (CountableSup f) a = CountableSup (fun n => meet (f n) a).
Proof.
intros a f.
unfold CountableSup at 1. rewrite SierMeet_sup.
apply sup_extensionality;simpl.
induction n as [|n IHn];simpl.
- reflexivity.
- simpl in IHn. rewrite <-IHn.
  apply meet_join_distr_r.
Qed.

Lemma countable_sup_meet_distr_l : forall a f,
  meet a (CountableSup f) = CountableSup (fun n => meet a (f n)).
Proof.
intros. rewrite (commutativity (f:=meet)),countable_sup_meet_distr_r.
apply ap,path_forall. intros n. apply commutativity.
Qed.

Section enumerable_sup.
Universe UA.
Variable A : Type@{UA}.

Context `{Enumerable A}.

Definition EnumerableSup@{} (f : A -> Sier)  : Sier
  := CountableSup (f ∘ (enumerator A)).

Lemma enumerable_sup_ub' : forall (f:A->Sier) (x:A), f x <= EnumerableSup f.
Proof.
intros f x.
generalize (center _ (enumerator_issurj _ x)). apply (Trunc_ind _).
intros [a []]. clear x. unfold EnumerableSup.
apply (countable_sup_ub (Compose _ _) a).
Qed.

Definition enumerable_sup_ub@{} := enumerable_sup_ub'@{Uhuge Ularge}.

Lemma enumerable_sup_least_ub@{} : forall (f:A->Sier) s, (forall x, f x <= s) ->
  EnumerableSup f <= s.
Proof.
intros f s E. apply countable_sup_least_ub.
intros;apply E.
Qed.

Lemma top_le_enumerable_sup' : forall f, iff@{Set UA UA} (EnumerableSup f)
  (merely (exists x, f x)).
Proof.
intros f;split.
- intros E. apply top_le_countable_sup in E;revert E;
  apply (Trunc_ind _);intros [n E].
  apply tr;econstructor;apply E.
- apply (Trunc_ind _);intros [x E].
  generalize (center _ (enumerator_issurj _ x)). apply (Trunc_ind _).
  intros [a Ea]. destruct Ea.
  apply top_le_countable_sup. apply tr;exists a;apply E.
Qed.

Definition top_le_enumerable_sup@{} := top_le_enumerable_sup'@{Uhuge Ularge}.

Lemma enumerable_sup_meet_distr_l : forall a f,
  meet a (EnumerableSup f) = EnumerableSup (fun n => meet a (f n)).
Proof.
intros. apply countable_sup_meet_distr_l.
Qed.

Lemma enumerable_sup_meet_distr_r : forall a f,
  meet (EnumerableSup f) a = EnumerableSup (fun n => meet (f n) a).
Proof.
intros. apply countable_sup_meet_distr_r.
Qed.

End enumerable_sup.

Lemma not_bot : ~ (@bottom Sier _).
Proof.
intros E.
apply (not_eta_le_bot@{Set} _ tt). apply E.
Qed.

Lemma SierLe_imply : forall a b : Sier, a <= b -> a -> b.
Proof.
intros a b E E';red;transitivity a;trivial.
Qed.

Definition meet_top_l : forall a : Sier, meet top a = a
  := fun _ => idpath.

Lemma meet_top_r : forall a : Sier, meet a top = a.
Proof.
intros. etransitivity;[|apply meet_top_l]. apply commutativity.
Qed.

Definition meet_bot_l : forall a : Sier, meet bottom a = bottom
  := fun _ => idpath.

Lemma meet_bot_r : forall a : Sier, meet a bottom = bottom.
Proof.
intros. etransitivity;[|apply meet_bot_l]. apply commutativity.
Qed.

Definition join_top_l : forall a : Sier, join top a = top
  := fun _ => idpath.

Lemma join_top_r : forall a : Sier, join a top = top.
Proof.
intros. etransitivity;[|apply join_top_l]. apply commutativity.
Qed.

Definition join_bot_l : forall a : Sier, join bottom a = a
  := fun _ => idpath.

Lemma join_bot_r : forall a : Sier, join a bottom = a.
Proof.
intros. etransitivity;[|apply join_bot_l]. apply commutativity.
Qed.

Lemma top_le_eq : forall a : Sier, a -> a = top.
Proof.
intros a E. apply (antisymmetry le);trivial.
apply top_greatest.
Qed.

Lemma bot_eq : forall a : Sier, a <= bottom -> a = bottom.
Proof.
intros a E. apply (antisymmetry le);trivial.
apply bot_least.
Qed.

Lemma imply_le : forall a b : Sier, (a -> b) -> a <= b.
Proof.
apply (partial_ind0 _ (fun a => forall b, _ -> _)).
- intros [] b E. apply E. apply top_greatest.
- intros;apply bot_least.
- intros s IH b E. apply sup_le_r. intros n.
  apply IH. intros En. apply E.
  red. transitivity (s n);trivial. apply sup_is_ub.
Qed.

Class SemiDecide@{i} (A : Type@{i}) := semi_decide : Sier.
Arguments semi_decide A {_}.

Class SemiDecidable@{i} (A : Type@{i}) `{SemiDecide A}
  := semi_decidable : iff@{Set i i} (semi_decide A) A.

Global Instance decidable_semi_decide@{i} (A:Type@{i}) `{Decidable A}
  : SemiDecide A.
Proof.
red. exact (if dec A then top else bottom).
Defined.
Arguments decidable_semi_decide _ {_} /.

Global Instance decidable_semi_decidable@{i} (A:Type@{i}) `{Decidable A}
  : SemiDecidable@{i} A.
Proof.
red. unfold semi_decide;simpl. destruct (dec A) as [E|E];split;intros E'.
- trivial.
- apply top_greatest.
- apply not_bot in E'. destruct E'.
- destruct (E E').
Qed.

Lemma semidecidable_top@{i} {A:Type@{i} } `{SemiDecidable@{i} A}
  : A -> semi_decide A = top.
Proof.
intros E. apply top_le_eq. apply semi_decidable. trivial.
Qed.

Lemma semidecidable_bot@{i} {A:Type@{i} } `{SemiDecidable@{i} A}
  : ~ A -> semi_decide A = bottom.
Proof.
intros E'. apply bot_eq,imply_le. intros E. apply semi_decidable in E.
destruct (E' E).
Qed.

Lemma semi_decide_meet_le@{i} (A:Type@{i}) `{SemiDecidable@{i} A}
  : forall b c, iff@{Set i i} (meet (semi_decide A) b <= c) (A -> b <= c).
Proof.
intros. split.
- intros E Ea. rewrite (semidecidable_top Ea),meet_top_l in E. trivial.
- intros E. apply imply_le;intros E'.
  apply top_le_meet in E';destruct E' as [E1 E2].
  apply semi_decidable in E1. apply SierLe_imply with b;trivial.
  apply E;trivial.
Qed.

Global Instance semi_decide_conj@{i j k} (A:Type@{i}) `{SemiDecide A}
  (B:Type@{j}) `{SemiDecide B}
  : SemiDecide@{k} (A /\ B)
  := meet (semi_decide A) (semi_decide B).
Arguments semi_decide_conj _ {_} _ {_} /.

Global Instance semi_decidable_conj@{i j k} (A:Type@{i}) `{SemiDecidable@{i} A}
  (B:Type@{j}) `{SemiDecidable@{j} B}
  : SemiDecidable@{k} (A /\ B).
Proof.
split.
- intros E;apply top_le_meet in E;destruct E as [E1 E2];
  apply semi_decidable in E1;apply semi_decidable in E2;split;trivial.
- intros [E1 E2];apply top_le_meet;split;apply semi_decidable;trivial.
Qed.

Global Instance semi_decide_disj@{i j k} (A:Type@{i}) `{SemiDecide@{i} A}
  (B:Type@{j}) `{SemiDecide@{j} B}
  : SemiDecide@{k} (hor@{i j k} A B)
  := join (semi_decide A) (semi_decide B).
Arguments semi_decide_disj _ {_} _ {_} /.

Global Instance semi_decidable_disj@{i j k} (A:Type@{i}) `{SemiDecidable@{i} A}
  (B:Type@{j}) `{SemiDecidable@{j} B}
  : SemiDecidable@{k} (hor@{i j k} A B).
Proof.
split.
- intros E;apply top_le_join in E;revert E;apply (Trunc_ind _);intros [E|E];
  apply semi_decidable in E;apply tr;auto.
- apply (Trunc_ind _);intros [E|E];apply top_le_join,tr;[left|right];
  apply semi_decidable;trivial.
Qed.

Global Instance semi_decide_exists@{i j k} (A : Type@{i}) `{Enumerable@{i} A}
  (B : A -> Type@{j}) `{forall x, SemiDecide@{j} (B x)}
  : SemiDecide@{k} (merely@{k} (exists x, B x))
  := EnumerableSup A (fun x => semi_decide (B x)).
Arguments semi_decide_exists A {_} B {_} /.

Global Instance semi_decidable_exists@{i j k} (A : Type@{i}) `{Enumerable@{i} A}
  (B : A -> Type@{j}) `{!forall x, SemiDecide (B x)}
  `{!forall x, SemiDecidable@{j} (B x)}
  : SemiDecidable (merely@{k} (exists x, B x)).
Proof.
red;unfold semi_decide;simpl.
split.
- intros E;apply top_le_enumerable_sup in E.
  revert E;apply (Trunc_ind _);intros [x E];apply tr;exists x;
  apply semi_decidable,E.
- apply (Trunc_ind _);intros [x E];apply top_le_enumerable_sup,tr;exists x.
  apply (snd semi_decidable),E.
Qed.

Global Instance semi_decide_sier (a : Sier) : SemiDecide a
  := a.
Arguments semi_decide_sier _ /.

Global Instance semi_decidable_sier (a : Sier) : SemiDecidable a.
Proof.
red. split;trivial.
Qed.

Section interleave.

Definition disjoint (a b : Sier) := a -> b -> Empty.

Lemma disjoint_top_l : forall b, disjoint top b -> b = bottom.
Proof.
intros b E. apply bot_eq. apply imply_le.
intros Eb. apply Empty_ind,E;trivial. apply top_greatest.
Qed.

Lemma disjoint_sup_l : forall s b, disjoint (sup _ s) b ->
  forall n, disjoint (s n) b.
Proof.
intros s b E n E1 E2.
apply E;trivial. apply top_le_sup. apply tr;eauto.
Qed.

Lemma disjoint_le_l : forall a b, disjoint a b -> forall a', a' <= a ->
  disjoint a' b.
Proof.
intros a b E a' Ea E1 E2;apply E;trivial. red; transitivity a';trivial.
Qed.

Definition interleave_aux_seq (s : IncreasingSequence Sier)
  (Is : forall (n : nat) (b : Sier),
       disjoint (s n) b -> partial bool)
  (Isle : forall (n : nat) (b : Sier) (Ea : disjoint (s n) b)
         (Ea' : disjoint (s (S n)) b), (Is n b Ea) ≤ (Is (S n) b Ea'))
  (b : Sier)
  (E : disjoint (sup Unit s) b)
  : IncreasingSequence (partial bool).
Proof.
simple refine (Build_IncreasingSequence _ _).
- intros n. apply (Is n b).
  apply disjoint_sup_l;trivial.
- simpl. auto.
Defined.

Definition interleave_inductors : Inductors Unit
  (fun a => forall b, disjoint a b -> sigT (fun s : partial bool =>
    partial_map (const false) b <= s))
  (fun a a' f g E => forall b Ea Ea', (f b Ea).1 <= (g b Ea').1).
Proof.
simple refine (Build_Inductors _ _ _ _ _ _ _ _ _ _ _ _);simpl.
- intros [] b E. exists (eta _ true).
  rewrite (disjoint_top_l _ E). apply bot_least.
- intros b _. exists (partial_map (const false) b).
  reflexivity.
- intros s Is Isle b E.
  simple refine (existT _ _ _);simpl;
  [apply sup;apply (interleave_aux_seq s (fun n b E => (Is n b E).1) Isle b E)|].
  etransitivity;[|apply (sup_is_ub _ _ 0)].
  simpl. apply Is.
- intros a f b Ea Ea'.
  assert (Hrw : Ea = Ea') by apply path_ishprop.
  apply (ap (f b)) in Hrw. apply (ap pr1) in Hrw. rewrite Hrw;reflexivity.
- simpl. intros x f b _ E.
  apply f.
- simpl;intros s x Ex fs fs_increasing fb Eb n a Ea Ea'.
  pose proof (fun b Ea Ea' => sup_le_l _ _ _ (Eb b Ea Ea')) as E;
  simpl in E.
  etransitivity;[|simple refine (E _ _ _ n);eapply disjoint_le_l;eauto].
  set (Esup := disjoint_sup_l _ _ _ _).
  assert (Hrw : Ea = Esup) by apply path_ishprop.
  apply (ap (fs n a)),(ap pr1) in Hrw. rewrite <-Hrw;reflexivity.
- simpl. intros s x Ex fs fs_incr fx IHs b ??.
  apply sup_le_r. intros n;simpl.
  auto.
- simpl. intros x y fx fy Ex Ey.
  destruct (partial_antisymm Unit x y Ex Ey);simpl;clear Ex Ey.
  intros Efx Efy.
  apply path_forall;intros b;apply path_forall;intros Eb;
  apply Sigma.path_sigma_hprop.
  apply (antisymmetry le);trivial.
Defined.

Definition interleave : forall a b : Sier, disjoint a b -> partial bool
  := fun a b E => (partial_rect _ _ _ interleave_inductors a b E).1.

Definition interleave_top_l_rw : forall b E, interleave top b E = eta _ true
  := fun _ _ => idpath.

Definition interleave_le : forall a a', a <= a' -> forall b E E',
  interleave a b E <= interleave a' b E'
  := partialLe_rect _ _ _ interleave_inductors.

Definition interleave_sup_l : forall s b E, interleave (sup _ s) b E =
  sup _ (Build_IncreasingSequence
    (fun n => interleave (s n) b (disjoint_sup_l _ _ E _ ))
    (fun n => interleave_le _ _ (seq_increasing _ _) _ _ _))
  := fun _ _ _ => idpath.

Lemma interleave_top_r_rw : forall a E, interleave a top E = eta _ false.
Proof.
apply (partial_ind0 _ (fun a => forall E, _)).
- intros [] E. apply Empty_ind. apply E;apply reflexivity.
- intros E. reflexivity.
- intros s Es E.
  rewrite interleave_sup_l.
  apply (snd (eta_eq_sup_iff bool _ (Build_IncreasingSequence _ _))).
  apply tr;exists 0. simpl.
  apply Es.
Qed.

Lemma interleave_top_l : forall (a b : Sier) E, a ->
  interleave a b E = eta _ true.
Proof.
intros a b E Ea.
apply top_le_eq in Ea.
symmetry in Ea. destruct Ea. reflexivity.
Qed.

Lemma interleave_top_r : forall(a b : Sier) E, b ->
  interleave a b E = eta _ false.
Proof.
intros a b E Eb.
apply top_le_eq in Eb.
symmetry in Eb. destruct Eb. apply interleave_top_r_rw.
Qed.

Definition interleave_bot_rw : forall E, interleave bottom bottom E = bot _
  := fun _ => idpath.

Lemma interleave_bot : forall a b E, a <= bottom -> b <= bottom ->
  interleave a b E = bot _.
Proof.
intros a b E E1 E2.
apply bot_eq in E1;apply bot_eq in E2.
symmetry in E1;symmetry in E2. destruct E1,E2.
reflexivity.
Qed.

Lemma interleave_le_const_r : forall a b E,
  partial_map (const false) b <= interleave a b E.
Proof.
intros. apply ((partial_rect _ _ _ interleave_inductors a b E).2).
Qed.

Lemma interleave_pr : forall a b E v, interleave a b E = eta _ v ->
  match v with true => a | false => b end.
Proof.
apply (partial_ind0 _ (fun a => forall b E v, _ -> _)).
- intros [] b E v Ev.
  apply (injective (eta _)) in Ev.
  rewrite <-Ev;apply top_greatest.
- intros b E v Ev.
  change (partial_map (const false) b = eta _ v) in Ev.
  clear E;revert b v Ev. apply (partial_ind0 _ (fun b => forall v, _ -> _)).
  + intros [] v E. apply (injective (eta _)) in E.
    rewrite <-E;apply top_greatest.
  + intros v E. change (bot _ = eta _ v) in E.
    apply Empty_ind,(not_eta_le_bot bool v). rewrite E;reflexivity.
  + intros s IHs v E.
    unfold partial_map in E;rewrite partial_bind_sup_l in E.
    apply (eta_eq_sup_iff _) in E.
    revert E;apply (Trunc_ind _);intros [n E].
    simpl in E. apply IHs in E.
    destruct v;trivial.
    apply top_le_sup. apply tr;exists n;trivial.
- intros s IHs b E v Ev.
  rewrite interleave_sup_l in Ev.
  apply (eta_eq_sup_iff _) in Ev. simpl in Ev.
  revert Ev;apply (Trunc_ind _);intros [n Ev].
  apply IHs in Ev. destruct v;trivial.
  apply top_le_sup. apply tr;exists n;trivial.
Qed.

End interleave.

End contents.

Arguments semi_decide A {_}.
Arguments decidable_semi_decide _ {_} /.
Arguments semi_decide_conj {_} _ {_} _ {_} /.
Arguments semi_decide_disj {_} _ {_} _ {_} /.
Arguments semi_decide_sier _ /.
Arguments semi_decide_exists {_} A {_} B {_} /.


Require Import List Arith Ascii String.
Import ListNotations.
Open Scope string_scope.

Inductive prim := PtrIncr | PtrDecr | Incr | Decr | Get.

Inductive stmt :=
| SNil : stmt
| Prim : prim -> stmt -> stmt
| Put : stmt -> stmt
| Loop : stmt -> stmt -> stmt.

Fixpoint parse' (str : string) :=
  match str with
  | "" => (SNil, nil)
  | String x xs =>
    let (body, rest) := parse' xs in
    match x with
    | ">"%char => (Prim PtrIncr body, rest)
    | "<"%char => (Prim PtrDecr body, rest)
    | "+"%char => (Prim Incr body, rest)
    | "-"%char => (Prim Decr body, rest)
    | ","%char => (Prim Get body, rest)
    | "."%char => (Put body, rest)
    | "["%char =>
      match rest with
      | nil => (Loop body SNil, nil)
      | cons s rest' => (Loop body s, rest')
      end
    | "]"%char => (SNil, cons body rest)
    | _ => (SNil, nil)
    end
  end.

Definition parse str := fst (parse' str).

Definition run_prim (env : (nat -> nat) * nat * list nat) p :=
  let '(data, ptr, input) := env in
  match p with
  | PtrIncr => (data, S ptr, input)
  | PtrDecr => (data, pred ptr, input)
  | Incr => (fun i => if Nat.eq_dec i ptr then S (data ptr) else data i,
                      ptr, input)
  | Decr => (fun i => if Nat.eq_dec i ptr then pred (data ptr) else data i,
                      ptr, input)
  | Get =>
    match input with
    | [] => env
    | x::rest => (fun i => if Nat.eq_dec i ptr then x else data i,
                           ptr, rest)
    end
  end.

Fixpoint append (s1 s2 : stmt) :=
  match s1 with
  | SNil => s2
  | Prim p s => Prim p (append s s2)
  | Put s => Put (append s s2)
  | Loop b s => Loop b (append s s2)
  end.

Ltac run env c' :=
  let c := eval compute in c' in
  match env with
  | (?data, ?ptr, ?input) =>
    match c with
    | SNil => idtac
    | Prim ?p ?c' =>
      let env' := eval compute in (run_prim (data,ptr,input) p) in
      run env' c'
    | Put ?c' =>
      let x := eval compute in (data ptr) in
      idtac x;
      run env c'
    | Loop ?c1 ?c2 =>
      let x := eval compute in (Nat.eq_dec (data ptr) 0) in
      match x with
      | left _ => run env c2
      | right _ => run env (append c1 (Loop c1 c2))
      end
    end
  end.

Goal True.
  run ((fun _:nat=>0), 0, [4;3]) (parse ",>,<[-<+>]<.").
  run ((fun _:nat=>0), 0, [3;3]) (parse ",>,<[->[->>+<<]>>[-<+<+>>]<<<]>>.").
  run ((fun _:nat=>0), 0, @nil nat) (parse "+[>.+<]").
Abort.


Set Implicit Arguments.
Set Asymmetric Patterns.

Require Import CoqStock.comparable.

Require Import Reexamined.compare_regex.
Require Import Reexamined.nullable.
Require Import Reexamined.regex.

(* simplified is a property that a regex's ors are somewhat simplified *)
Fixpoint simplified {A: Type} {cmp: comparable A} (r: regex A) : Prop :=
  match r with
  | fail => True
  | empty => True
  | char _ => True
  | or s t =>
    simplified s
    /\ simplified t
    /\ compare_regex s t = Lt
    /\ match s with
       | or _ _ => False
       | _ => True
       end
    /\ match t with
       | or tl _ => compare_regex s tl = Lt
       | _ => True
       end
  | and s t => simplified s /\ simplified t
  | concat s t => simplified s /\ simplified t
  | not s => simplified s
  | star s => simplified s
  end.

(*
(or (char x1) (or (char x2) (or (char x3) (char x4))))
or
- x1
- or
  - x2
  - or
    - x3
    - x4
*)
Lemma test_simplified_or_all_left_in_order : forall {A: Type} {cmp: comparable A} (x1 x2 x3 x4: A)
  (p12: compare x1 x2 = Lt)
  (p23: compare x2 x3 = Lt)
  (p34: compare x3 x4 = Lt),
  simplified (or (char x1) (or (char x2) (or (char x3) (char x4)))) -> True.
Proof.
intros.
firstorder.
Qed.

(*
(or (char x1) (or (char x2) (or (char x2) (char x1))))
or
- x1
- or
  - x2
  - or
    - x2
    - x1
*)
Lemma test_simplified_or_all_left_out_of_order : forall
  {A: Type}
  {cmp: comparable A}
  (x1 x2 x3 x4: A)
  (p12: compare x1 x2 = Lt)
  (p23: compare x2 x3 = Lt)
  (p34: compare x3 x4 = Lt),
  simplified (or (char x1) (or (char x3) (or (char x2) (char x4)))) -> False.
Proof.
intros x cmp.
intros x1 x2 x3 x4.
intros p12 p23 p34.
simpl.
firstorder.
assert (p := proof_compare_lt_trans x2 x3 x2 p23 H7).
rewrite proof_compare_eq_reflex in p.
discriminate.
Qed.

(*
(or (or (char x1) (char x2)) (or (char x3) (char x4)))
or
  - or
    - x1
    - x2
  - or
    - x3
    - x4
*)
Lemma test_simplified_or_symmetric: forall {A: Type} {cmp: comparable A} (x1 x2 x3 x4: A)
  (p12: compare x1 x2 = Lt)
  (p23: compare x2 x3 = Lt)
  (p34: compare x3 x4 = Lt),
  simplified (or (or (char x1) (char x2)) (or (char x3) (char x4))) -> False.
Proof.
intros x cmp.
intros x1 x2 x3 x4 p12 p23 p34.
simpl.
firstorder.
Qed.


(** Copyright (c) 2015 Bill White **)
(** Distributed under the MIT/X11 software license **)
(** See http://www.opensource.org/licenses/mit-license.php **)

(** Assets: Representation of assets as 4-tuples:
    (hashval) id
    (birthday) block height at which asset was confirmed
    (obligation) obligations to be met in order to spend the asset [default of None means the holder signs for it]
    (preasset) the kind of asset
    The preassets include currency units, bounties (for proving a conjecture),
    owns (ownership of objs/props), rights (for using an obj/prop), intention (as
    part of a publication protocol ["commit and reveal"]) and publication (for formal documents).
    The usereq is (al,(m,n)) where al is a list of addresses that can sign to spend,
    m is the number of addresses that must sign, and n is the block height
    at which spending is first allowed.
 **)

Require Export MathData.

Inductive preasset : Type :=
| currency : nat -> preasset (*** currency u is u units of currency ***)
| bounty : nat -> preasset (*** Idea: If alpha holds this, then the bounty can be converted (back) to currency units sent to beta in a transaction in which beta publishes a 'soln' to alpha. This is an example where the required signer is not the holder. ***)
| owns : bool -> payaddr -> option nat -> preasset (*** Idea: If beta holds owns alpha n, then alpha controls who can obtain the rights to use the data that hashes to beta. People can create such rights by paying n units to alpha, unless n is None, in which case only the owner can use it. The initial bool is just to distinguish between owning objects (owns false) and owning propositions (owns true). ***)
| rights : bool -> nat -> termaddr -> preasset (*** Idea: If alpha has rights n beta, then alpha can use this to use the data that hashes to beta up to n times. Could have another version with an expiration block. ***)
| marker : preasset (*** Idea: A marker placed at an address can serve more than one purpose. At a termaddr it is there as a way to check that a certain term is known to have a certain type. If an intention at pubaddress alpha has enough confirmations, then a publication can be published if it hashes to alpha. The author's address is part of what is hashed. ***)
| theorypublication : payaddr -> nat -> theoryspec -> preasset (*** author, nonce and data ***)
| signapublication : payaddr -> nat -> option hashval -> signaspec -> preasset (*** author, nonce, theory and data ***)
| docpublication : payaddr -> nat -> option hashval -> doc -> preasset (*** author, nonce, theory and data ***)
.

(*** obligation (a,b) : a : address, b : nat
 means to spend the asset the block height must be at least b
 and a signature/script for address a is required.
 The obligation can also be met via endorsement to another address a' which then signs it.
 None means that the holder signs for it and the block height restriction is effectively 0.
 ***)
Definition obligation : Type := option (prod payaddr nat).

Definition preasset_value (u:preasset) : option nat :=
  match u with
    | currency v => Some v
    | bounty v => Some v
    | _ => None
  end.

Definition asset : Type := prod hashval (prod nat (prod obligation preasset)).

Definition assetid (a:asset) : hashval := fst a.
Definition assetbday (a:asset) : nat := fst (snd a).
Definition assetobl (a:asset) : obligation := fst (snd (snd a)).
Definition assetpre (a:asset) : preasset := snd (snd (snd a)).

Definition asset_value (a:asset) : option nat := preasset_value (assetpre a).

Definition hashpreasset (a:preasset) : hashval :=
match a with
| currency u => hashpair (hashnat 0) (hashnat u)
| bounty u => hashpair (hashnat 1) (hashnat u)
| owns false alpha (Some u) => hashpair (hashnat 2) (hashpair (hashaddr (payaddr_addr alpha)) (hashnat u))
| owns true alpha (Some u) => hashpair (hashnat 3) (hashpair (hashaddr (payaddr_addr alpha)) (hashnat u))
| owns false alpha None => hashpair (hashnat 4) (hashaddr (payaddr_addr alpha))
| owns true alpha None => hashpair (hashnat 5) (hashaddr (payaddr_addr alpha))
| rights false n alpha => hashpair (hashnat 6) (hashpair (hashnat n) (hashaddr (termaddr_addr alpha)))
| rights true n alpha => hashpair (hashnat 7) (hashpair (hashnat n) (hashaddr (termaddr_addr alpha)))
| marker => hashpair (hashnat 8) (hashnat 0)
| theorypublication alpha n d => hashpair (hashnat 9) (hashpair (hashaddr (payaddr_addr alpha)) (hashpair (hashnat n) (hashtheoryspec d)))
| signapublication alpha n th d => hashpair (hashnat 10) (hashpair (hashaddr (payaddr_addr alpha)) (hashpair (hashnat n) (hashopair2 th (hashsignaspec d))))
| docpublication alpha n th d => hashpair (hashnat 11) (hashpair (hashaddr (payaddr_addr alpha)) (hashpair (hashnat n) (hashopair2 th (hashdoc d))))
end.

Definition hashobligation (obl:obligation) : hashval :=
match obl with
| None => hashnat 0
| Some(a,b) => hashpair (hashaddr (payaddr_addr a)) (hashnat b)
end.

Definition hashasset (a:asset) : hashval :=
match a with
| (h,(bday,(obl,p))) =>
  hashpair h (hashpair (hashnat bday) (hashpair (hashobligation obl) (hashpreasset p)))
end.

Lemma hashpreassetinj a b :
hashpreasset a = hashpreasset b -> a = b.
destruct a as [u|u|[|] alpha [u|]|[|] k alpha| |alpha m d|alpha m th d|alpha m th d]; destruct b as [v|v|[|] beta [v|]|[|] k' beta| |beta n d'|beta n th' d'|beta n th' d'];
  try (simpl; intros H1; exfalso; apply hashpairinj in H1; destruct H1 as [H1 _]; apply hashnatinj in H1; omega).
- simpl. intros H1.
  apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashnatinj in H1.
  congruence.
- simpl. intros H1. apply hashpairinj in H1.
  destruct H1 as [_ H1].
  apply hashnatinj in H1.
  congruence.
- simpl. intros H1. apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashaddrinj in H2.
  apply payaddr_addr_inj in H2.
  apply hashnatinj in H3.
  congruence.
- simpl. intros H1. apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashaddrinj in H1.
  apply payaddr_addr_inj in H1.
  congruence.
- simpl. intros H1. apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashaddrinj in H2.
  apply payaddr_addr_inj in H2.
  apply hashnatinj in H3.
  congruence.
- simpl. intros H1. apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashaddrinj in H1.
  apply payaddr_addr_inj in H1.
  congruence.
- simpl. intros H1. apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashnatinj in H2.
  apply hashaddrinj in H3.
  apply termaddr_addr_inj in H3.
  congruence.
- simpl. intros H1. apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashnatinj in H2.
  apply hashaddrinj in H3.
  apply termaddr_addr_inj in H3.
  congruence.
- congruence.
- simpl. intros H1. apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashpairinj in H3. destruct H3 as [H4 H5].
  apply hashaddrinj in H2. apply payaddr_addr_inj in H2.
  apply hashnatinj in H4. subst alpha. subst m.
  f_equal.
  revert H5. apply hashtheoryspecinj.
- simpl. intros H1. apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashpairinj in H3. destruct H3 as [H4 H5].
  apply hashopair2inj in H5. destruct H5 as [H6 H7].
  apply hashaddrinj in H2. apply payaddr_addr_inj in H2.
  apply hashsignaspecinj in H7.
  apply hashnatinj in H4.
  congruence.
- simpl. intros H1. apply hashpairinj in H1. destruct H1 as [_ H1].
  apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashpairinj in H3. destruct H3 as [H4 H5].
  apply hashopair2inj in H5. destruct H5 as [H6 H7].
  apply hashaddrinj in H2. apply payaddr_addr_inj in H2.
  apply hashdocinj in H7.
  apply hashnatinj in H4.
  congruence.
Qed.

Lemma hashobligationinj (obl obl':obligation) :
  hashobligation obl = hashobligation obl' -> obl = obl'.
destruct obl as [[a b]|]; destruct obl' as [[a' b']|]; simpl; intros H1.
- apply hashpairinj in H1. destruct H1 as [H2 H3].
  apply hashaddrinj in H2. apply hashnatinj in H3.
  destruct a as [[|] a]; destruct a' as [[|] a']; try discriminate H2.
  + unfold payaddr_addr in H2. inversion H2. congruence.
  + unfold payaddr_addr in H2. inversion H2. congruence.
- symmetry in H1. apply hashnatpairdiscr in H1. tauto.
- apply hashnatpairdiscr in H1. tauto.
- reflexivity.
Qed.

Lemma hashassetinj a b :
hashasset a = hashasset b -> a = b.
destruct a as [h [bday [obl u]]]. destruct b as [k [bday' [obl' v]]].
simpl. intros H1.
apply hashpairinj in H1. destruct H1 as [H2 H3].
apply hashpairinj in H3. destruct H3 as [H4 H5].
apply hashpairinj in H5. destruct H5 as [H6 H7].
apply hashnatinj in H4.
apply hashobligationinj in H6.
apply hashpreassetinj in H7.
congruence.
Qed.

Definition addr_assetid : Type := prod addr hashval.
Definition addr_preasset : Type := prod addr (prod obligation preasset).
Definition addr_asset : Type := prod addr asset.

Definition hash_addr_assetid (aa : addr_assetid) : hashval :=
let (alpha,h) := aa in
hashpair (hashaddr alpha) h.

Definition hash_addr_preasset (au : addr_preasset) : hashval :=
match au with
| (alpha,(obl,u)) => hashlist ((hashaddr alpha)::(hashobligation obl)::(hashpreasset u)::nil)
end.

Lemma hash_addr_assetidinj alpha a beta b :
 hash_addr_assetid (alpha,a) = hash_addr_assetid (beta,b)
 -> alpha = beta /\ a = b.
unfold hash_addr_assetid. intros H1.
apply hashpairinj in H1. destruct H1 as [H2 H3].
apply hashaddrinj in H2. tauto.
Qed.

Lemma map_hash_addr_assetidinj inpl inpl' :
 map hash_addr_assetid inpl = map hash_addr_assetid inpl'
 -> inpl = inpl'.
revert inpl'. induction inpl as [|[alpha a] inpr IH].
- intros [|[beta b] inpr'].
  + reflexivity.
  + intros H1. discriminate H1.
- intros [|[beta b] inpr'].
  + intros H1. discriminate H1.
  + intros H1.
    change ((hash_addr_assetid (alpha, a) :: map hash_addr_assetid inpr) =
            (hash_addr_assetid (beta, b) :: map hash_addr_assetid inpr')) in H1.
    f_equal.
    * assert (L1: alpha = beta /\ a = b).
      { apply hash_addr_assetidinj. congruence. }
      destruct L1 as [L1a L1b]. congruence.
    * apply IH. congruence.
Qed.

Lemma hash_addr_preassetinj au bv :
  hash_addr_preasset au = hash_addr_preasset bv
  -> au = bv.
destruct au as [alpha [obl u]], bv as [beta [obl' v]].
intros H1. unfold hash_addr_preasset in H1.
apply hashlistinj in H1.
inversion H1. apply hashaddrinj in H0. subst beta.
apply hashobligationinj in H2.
apply hashpreassetinj in H3.
congruence.
Qed.

Lemma map_hash_addr_preassetinj outpl outpl' :
 map hash_addr_preasset outpl = map hash_addr_preasset outpl'
 -> outpl = outpl'.
revert outpl'. induction outpl as [|[alpha u] outpr IH].
- intros [|[beta v] outpr'].
  + reflexivity.
  + intros H1. discriminate H1.
- intros [|[beta v] outpr'].
  + intros H1. discriminate H1.
  + intros H1.
    change ((hash_addr_preasset (alpha, u) :: map hash_addr_preasset outpr) =
            (hash_addr_preasset (beta, v) :: map hash_addr_preasset outpr')) in H1.
    f_equal.
    * apply hash_addr_preassetinj. congruence.
    * apply IH. congruence.
Qed.

Fixpoint asset_value_out (outpl:list addr_preasset) : nat :=
match outpl with
| (alpha,(obl,currency u))::outpr => u + asset_value_out outpr
| (alpha,(obl,bounty u))::outpr => u + asset_value_out outpr
| (alpha,_)::outpr => asset_value_out outpr
| nil => 0
end.

Lemma asset_value_out_app (l r:list addr_preasset) :
  asset_value_out (l ++ r) = asset_value_out l + asset_value_out r.
induction l as [|[beta [obl u]] l IH].
- simpl. reflexivity.
- simpl. destruct u as [u|u|[|] alpha [u|]|[|] k alpha|alpha|m d|m th d|m th d]; simpl; omega.
Qed.

Definition preasset_eq_dec (a1 a2:preasset) : {a1 = a2} + {a1 <> a2}.
destruct a1 as [u|u|[|] alpha [u|]|[|] k alpha| |alpha m d|alpha m th d|alpha m th d]; destruct a2 as [v|v|[|] beta [v|]|[|] k' beta| |beta n d'|beta n th' d'|beta n th' d']; try (right; discriminate).
- destruct (eq_nat_dec u v) as [D1|D1].
  + left. congruence.
  + right. intros H1. inversion H1. tauto.
- destruct (eq_nat_dec u v) as [D1|D1].
  + left. congruence.
  + right. intros H1. inversion H1. tauto.
- destruct (eq_nat_dec u v) as [D1|D1].
  + destruct (payaddr_eq_dec alpha beta) as [D2|D2].
    * left. congruence.
    * right. intros H1. inversion H1. tauto.
  + right. intros H1. inversion H1. tauto.
- destruct (payaddr_eq_dec alpha beta) as [D1|D1].
  + left. congruence.
  + right. intros H1. inversion H1. tauto.
- destruct (eq_nat_dec u v) as [D1|D1].
  + destruct (payaddr_eq_dec alpha beta) as [D2|D2].
    * left. congruence.
    * right. intros H1. inversion H1. tauto.
  + right. intros H1. inversion H1. tauto.
- destruct (payaddr_eq_dec alpha beta) as [D1|D1].
  + left. congruence.
  + right. intros H1. inversion H1. tauto.
- destruct (eq_nat_dec k k') as [D1|D1].
  + destruct (termaddr_eq_dec alpha beta) as [D2|D2].
    * left. congruence.
    * right. intros H1. inversion H1. tauto.
  + right. intros H1. inversion H1. tauto.
- destruct (eq_nat_dec k k') as [D1|D1].
  + destruct (termaddr_eq_dec alpha beta) as [D2|D2].
    * left. congruence.
    * right. intros H1. inversion H1. tauto.
  + right. intros H1. inversion H1. tauto.
- left. congruence.
- destruct (payaddr_eq_dec alpha beta) as [D0|D0].
  + destruct (eq_nat_dec m n) as [D1|D1].
    * { destruct (theoryspec_eq_dec d d') as [D2|D2].
        - left. congruence.
        - right. intros H1. inversion H1. tauto.
      }
    * right. intros H1. inversion H1. tauto.
  + right. intros H1. inversion H1. tauto.
- destruct (payaddr_eq_dec alpha beta) as [D0|D0].
  + destruct (eq_nat_dec m n) as [D1|D1].
    * { destruct (signaspec_eq_dec d d') as [D2|D2].
        - destruct (ohashval_eq_dec th th') as [D3|D3].
          + left. congruence.
          + right. intros H1. inversion H1. tauto.
        - right. intros H1. inversion H1. tauto.
      }
    * right. intros H1. inversion H1. tauto.
  + right. intros H1. inversion H1. tauto.
- destruct (payaddr_eq_dec alpha beta) as [D0|D0].
  + destruct (eq_nat_dec m n) as [D1|D1].
    * { destruct (doc_eq_dec d d') as [D2|D2].
        - destruct (ohashval_eq_dec th th') as [D3|D3].
          + left. congruence.
          + right. intros H1. inversion H1. tauto.
        - right. intros H1. inversion H1. tauto.
      }
    * right. intros H1. inversion H1. tauto.
  + right. intros H1. inversion H1. tauto.
Defined.

Definition obligation_eq_dec (obl1 obl2 : obligation) : { obl1 = obl2 } + { obl1 <> obl2 }.
destruct obl1 as [[a1 b1]|]; destruct obl2 as [[a2 b2]|]; try (right; congruence).
- destruct (payaddr_eq_dec a1 a2) as [D1|D1]; try (right; congruence).
  destruct (eq_nat_dec b1 b2) as [D2|D2]; try (right; congruence).
  left; congruence.
- left; reflexivity.
Defined.

Definition asset_eq_dec (a1 a2:asset) : {a1 = a2} + {a1 <> a2}.
destruct a1 as [h1 [bday1 [obl1 u1]]], a2 as [h2 [bday2 [obl2 u2]]].
destruct (hashval_eq_dec h1 h2).
- destruct (eq_nat_dec bday1 bday2).
  + destruct (obligation_eq_dec obl1 obl2).
    * { destruct (preasset_eq_dec u1 u2).
        - left. congruence.
        - right. congruence.
      }
    * right. congruence.
  + right. congruence.
- right. congruence.
Defined.

Fixpoint new_assets (bday:nat) (alpha:addr) (aul:list addr_preasset) (txh:hashval) (i:nat) : list asset :=
match aul with
  | nil => nil
  | (beta,(obl,u))::aul' =>
    if addr_eq_dec alpha beta then
      (hashpair txh (hashnat i),(bday,(obl,u)))::(new_assets bday alpha aul' txh (S i))
    else
      new_assets bday alpha aul' txh (S i)
end.

Fixpoint remove_assets (al:list asset) (spent:list hashval) : list asset :=
match al with
| nil => nil
| a::al' =>
  if in_dec hashval_eq_dec (assetid a) spent then
    remove_assets al' spent
  else
    cons a (remove_assets al' spent)
end.

Fixpoint get_spent (alpha:addr) (inpl:list addr_assetid) : list hashval :=
match inpl with
| nil => nil
| cons (beta,a) inpl' =>
  if addr_eq_dec alpha beta then
    cons a (get_spent alpha inpl')
  else
    get_spent alpha inpl'
end.

Fixpoint add_vout (bday:nat) (txh:hashval) (outpl:list addr_preasset) (i:nat) : list (addr * asset)%type :=
match outpl with
| nil => nil
| cons (alpha,(obl,u)) outpl' => cons (alpha,(hashpair txh (hashnat i),(bday,(obl,u)))) (add_vout bday txh outpl' (S i))
end.

Lemma new_assets_iff bday a alpha aul txh i :
  In a (new_assets bday alpha aul txh i)
  <->
  (bday = assetbday a /\
   exists j, nth_error aul j = value (alpha,(assetobl a,assetpre a)) /\ assetid a = hashpair txh (hashnat (i+j))).
destruct a as [h [bday' [obl u]]]. revert i. induction aul as [|[beta [obl' v]] aur IH].
- intros i. split.
  + simpl. tauto.
  + intros [Hb [[|j] [H1 _]]] ; discriminate H1.
- simpl. intros i. destruct (addr_eq_dec alpha beta) as [H1|H1]; split.
  + intros [H2|H2].
    * { split.
        - inversion H2. reflexivity.
        - exists 0. simpl. split.
          + inversion H2. subst beta. reflexivity.
          + assert (L1: i + 0 = i) by omega.
            rewrite L1.
            congruence.
      }
    * { apply IH in H2. destruct H2 as [Hb [j [H3 H4]]]. split.
        - exact Hb.
        - exists (S j). split.
          + exact H3.
          + assert (L1: i + S j = S i + j) by omega.
            rewrite L1.
            exact H4.
      }
  + intros [Hb [[|j] [H2 H3]]]; simpl in *|-*.
    * { left. inversion H2. f_equal.
        - assert (L1: i + 0 = i) by omega.
          rewrite L1 in H3. now symmetry.
        - rewrite Hb. reflexivity.
       }
    * { right. apply IH. split.
        - exact Hb.
        - exists j. split.
          + assumption.
          + assert (L1: S i + j = i + S j) by omega.
            rewrite L1. assumption.
      }
  + intros H2. apply IH in H2. destruct H2 as [Hb [j [H3 H4]]]. split.
    * exact Hb.
    * { exists (S j). split.
        - exact H3.
        - assert (L1: i + S j = S i + j) by omega.
          rewrite L1. assumption.
      }
  + intros [Hb [[|j] [H2 H3]]].
    * exfalso. simpl in H2. inversion H2. congruence.
    * { apply IH. split.
        - exact Hb.
        - exists j. split.
          + exact H2.
          + assert (L1: S i + j = i + S j) by omega.
            rewrite L1. assumption.
      }
Qed.

Lemma remove_assets_iff a al spent :
  In a (remove_assets al spent)
  <->
  In a al /\ ~In (assetid a) spent.
destruct a as [h [obl u]]. induction al as [|[h' [obl' u']] ar IH].
- simpl. tauto.
- simpl. destruct (in_dec hashval_eq_dec h' spent) as [H1|H1]; split.
  + intros H2. apply IH in H2. tauto.
  + intros [[H2|H2] H3].
    * congruence.
    * apply IH. tauto.
  + intros [H2|H2].
    * { split.
        - tauto.
        - inversion H2. subst h'. assumption.
      }
    * tauto.
  + intros [[H2|H2] H3].
    * now left.
    * right. tauto.
Qed.

Lemma get_spent_iff h alpha inpl :
In h (get_spent alpha inpl)
<->
In (alpha,h) inpl.
induction inpl as [|[beta h'] inpr IH].
- simpl. tauto.
- simpl. destruct (addr_eq_dec alpha beta) as [H1|H1]; split.
  + intros [H2|H2].
    * left. congruence.
    * right. tauto.
  + intros [H2|H2].
    * left. inversion H2. reflexivity.
    * right. tauto.
  + tauto.
  + intros [H2|H2].
    * congruence.
    * tauto.
Qed.

Lemma no_dups_new_assets bday alpha aul txh i :
  no_dups (new_assets bday alpha aul txh i).
revert i. induction aul as [|[beta [obl v]] aur IH]; intros i.
- simpl. apply no_dups_nil.
- simpl. destruct (addr_eq_dec alpha beta) as [H1|H1].
  + apply no_dups_cons.
    * intros H2. apply new_assets_iff in H2. destruct H2 as [Hb [j [H3 H4]]].
      apply hashpairinj in H4. destruct H4 as [_ H4].
      apply hashnatinj in H4. omega.
    * apply IH.
  + apply IH.
Qed.

Lemma no_dups_remove_assets al spent :
no_dups al -> no_dups (remove_assets al spent).
intros H. induction H as [|[h [obl u]] al H1 H2 IH].
- simpl. apply no_dups_nil.
- simpl. destruct (in_dec hashval_eq_dec h spent) as [H3|H3].
  + assumption.
  + apply no_dups_cons.
    * intros H4. apply remove_assets_iff in H4. tauto.
    * assumption.
Qed.

Lemma remove_assets_noint_eq (al:list asset) (rem:list hashval) :
  (forall k, In k rem -> ~In_dom k al) ->
  remove_assets al rem = al.
induction al as [|[h [obl u]] ar IH].
- intros _. reflexivity.
- intros H1. simpl. destruct (in_dec hashval_eq_dec h rem) as [D1|D1].
  + exfalso. apply (H1 h D1). now left.
  + f_equal. apply IH. intros k H2 H3. apply (H1 k H2). now right.
Qed.

Lemma fnl_remove_assets (al:list asset) (rem:list hashval) :
  fnl al -> fnl (remove_assets al rem).
intros H. induction H as [|h u al H1 H2 IH].
- apply fnl_N.
- simpl. destruct (in_dec hashval_eq_dec h rem) as [H3|H3].
  + exact IH.
  + apply fnl_C.
    * intros H4. apply H1. apply In_In_dom_lem in H4.
      destruct H4 as [v H4].
      apply remove_assets_iff in H4. destruct H4 as [H5 H6].
      apply In_In_dom_lem. exists v. assumption.
    * exact IH.
Qed.

Definition hashassetlist (al:list asset) : option hashval := ohashlist (map hashasset al).

Lemma hashassetlistinj al bl : hashassetlist al = hashassetlist bl -> al = bl.
intros H1.
change (ohashlist (map hashasset al) = ohashlist (map hashasset bl)) in H1.
apply ohashlistinj in H1.
revert bl H1. induction al as [|a al IH]; intros [|b bl] H1.
- reflexivity.
- discriminate H1.
- discriminate H1.
- simpl in H1. inversion H1. apply hashassetinj in H0. subst b. f_equal.
  now apply IH.
Qed.

Definition asset_value_sum (al:list asset) : nat :=
fold_right plus 0 (map (fun a => match asset_value a with Some u => u | None => 0 end) al).

Lemma asset_value_sum_value_nil :
  asset_value_sum nil = 0.
reflexivity.
Qed.

Lemma asset_value_sum_value_cons a al u :
  asset_value a = Some u ->
  asset_value_sum (a::al) = u + asset_value_sum al.
intros H1. unfold asset_value_sum. simpl. rewrite H1.
reflexivity.
Qed.

Lemma asset_value_sum_novalue_cons a al :
  asset_value a = None ->
  asset_value_sum (a::al) = asset_value_sum al.
intros H1. unfold asset_value_sum. simpl. rewrite H1.
reflexivity.
Qed.

Lemma asset_value_sum_app (l r:list asset) :
asset_value_sum l
+
asset_value_sum r
=
asset_value_sum (l ++ r).
unfold asset_value_sum. induction l as [|[h u] l IH].
- simpl. reflexivity.
- simpl. rewrite <- plus_assoc. rewrite IH. reflexivity.
Qed.

Lemma app_perm_asset_value_sum (l r:list asset) :
  app_perm l r ->
  asset_value_sum l = asset_value_sum r.
intros H. induction H as [l r|l1 r1 l2 r2 H1 IH1 H2 IH2|l|l r H1 IH1|l r s H1 IH1 H2 IH2].
- rewrite <- asset_value_sum_app. rewrite <- asset_value_sum_app. omega.
- rewrite <- asset_value_sum_app. rewrite <- asset_value_sum_app. omega.
- omega.
- omega.
- omega.
Qed.

Lemma remove_assets_app (al bl:list asset) (rl:list hashval) :
  remove_assets (al ++ bl) rl = (remove_assets al rl) ++ (remove_assets bl) rl.
induction al as [|[h u] al IH].
- reflexivity.
- simpl. destruct (in_dec hashval_eq_dec h rl) as [H1|H1].
  + exact IH.
  + rewrite IH. reflexivity.
Qed.

Lemma remove_assets_nil (l:list asset) :
  remove_assets l nil = l.
induction l as [|[h u] l IH].
- reflexivity.
- simpl. rewrite IH. reflexivity.
Qed.

Lemma remove_assets_nIn_cons (l:list asset) (h:hashval) (rem:list hashval) :
  (~exists u, In (h,u) l) ->
  remove_assets l (h::rem) = remove_assets l rem.
induction l as [|[k v] l IH]; intros H1.
- reflexivity.
- simpl. destruct (hashval_eq_dec h k) as [D1|D1].
  + exfalso. apply H1. exists v. left. congruence.
  + destruct (in_dec hashval_eq_dec k rem) as [D2|D2].
    * apply IH. intros [u H2]. apply H1. exists u. now right.
    * f_equal. apply IH. intros [u H2]. apply H1. exists u. now right.
Qed.

Lemma remove_assets_app2 (l:list asset) (rem1 rem2:list hashval) :
  remove_assets l (rem1 ++ rem2) = remove_assets (remove_assets l rem1) rem2.
induction l as [ |[k v] l IH].
- reflexivity.
- simpl. destruct (in_dec hashval_eq_dec k (rem1 ++ rem2)) as [D1|D1].
  + destruct (in_dec hashval_eq_dec k rem1) as [D2|D2].
    * exact IH.
    * { simpl. destruct (in_dec hashval_eq_dec k rem2) as [D3|D3].
        - exact IH.
        - exfalso. apply in_app_or in D1. tauto.
      }
  + destruct (in_dec hashval_eq_dec k rem1) as [D2|D2].
    * exfalso. apply D1. apply in_or_app. tauto.
    * { simpl. destruct (in_dec hashval_eq_dec k rem2) as [D3|D3].
        - exfalso. apply D1. apply in_or_app. tauto.
        - f_equal. exact IH.
      }
Qed.

Lemma remove_assets_eq (l:list asset) (rl1 rl2:list hashval) :
  (forall h, In_dom h l -> (In h rl1 <-> In h rl2)) ->
  remove_assets l rl1 = remove_assets l rl2.
induction l as [|[h u] l IH].
- intros _. reflexivity.
- intros H1. simpl.
  destruct (in_dec hashval_eq_dec h rl1) as [H2|H2];
  destruct (in_dec hashval_eq_dec h rl2) as [H3|H3].
  + apply IH. intros k H4. apply H1. now right.
  + exfalso. apply H3. apply H1.
    * now left.
    * assumption.
  + exfalso. apply H2. apply H1.
    * now left.
    * assumption.
  + f_equal. apply IH. intros k H4. apply H1. now right.
Qed.

Lemma asset_value_sum_asset_shift (al:list asset) h a u rl :
  fnl al ->
  no_dups (h::rl) ->
  In (h,a) al ->
  asset_value (h,a) = Some u ->
  u + asset_value_sum (remove_assets al (h::rl)) = asset_value_sum (remove_assets al rl).
intros H H0. induction H as [|k v al H1 H2 IH].
- simpl. tauto.
- simpl. intros H3 E0. destruct (hashval_eq_dec h k) as [H4|H4].
  + destruct (in_dec hashval_eq_dec k rl) as [H5|H5].
    * exfalso. inversion H0. subst k. contradiction.
    * { destruct H3 as [H3|H3].
        - inversion H3.
          rewrite (asset_value_sum_value_cons _ _ _ E0).
          f_equal.
          subst k.
          apply app_perm_asset_value_sum.
          rewrite (remove_assets_eq al (h::rl) rl).
          + apply app_perm_ref.
          + intros k H8. split.
            * { intros [H9|H9].
                - exfalso. apply H1. subst k. assumption.
                - assumption.
              }
            * intros H9. now right.
        - exfalso. apply H1. apply In_In_dom_lem. exists a. subst k. assumption.
      }
  + destruct (in_dec hashval_eq_dec k rl) as [H5|H5].
    * { destruct H3 as [H3|H3].
        - inversion H3. exfalso. congruence.
        - now apply IH.
      }
    * { destruct H3 as [H3|H3].
        - inversion H3. exfalso. congruence.
        - destruct (asset_value (k,v)) as [w|] eqn: E1.
          + rewrite (asset_value_sum_value_cons _ _ _ E1).
            rewrite (asset_value_sum_value_cons _ _ _ E1).
            apply IH in H3.
            * omega.
            * exact E0.
          + rewrite (asset_value_sum_novalue_cons _ _ E1).
            rewrite (asset_value_sum_novalue_cons _ _ E1).
            exact (IH H3 E0).
      }
Qed.

Lemma asset_value_sum_asset_shift_non (al:list asset) h a rl :
  fnl al ->
  no_dups (h::rl) ->
  In (h,a) al ->
  asset_value (h,a) = None ->
  asset_value_sum (remove_assets al (h::rl)) = asset_value_sum (remove_assets al rl).
intros H H0. induction H as [|k v al H1 H2 IH].
- simpl. tauto.
- simpl. intros H3 H3'. destruct (hashval_eq_dec h k) as [H4|H4].
  + destruct (in_dec hashval_eq_dec k rl) as [H5|H5].
    * exfalso. inversion H0. subst k. contradiction.
    * { destruct H3 as [H3|H3].
        - inversion H3.
          rewrite (asset_value_sum_novalue_cons _ _ H3').
          change (asset_value_sum (remove_assets al (h :: rl)) = asset_value_sum (remove_assets al rl)).
          subst k.
          apply app_perm_asset_value_sum.
          rewrite (remove_assets_eq al (h::rl) rl).
          + apply app_perm_ref.
          + intros k H8. split.
            * { intros [H9|H9].
                - exfalso. apply H1. subst k. assumption.
                - assumption.
              }
            * intros H9. now right.
        - exfalso. apply H1. apply In_In_dom_lem. exists a. subst k. assumption.
      }
  + destruct (in_dec hashval_eq_dec k rl) as [H5|H5].
    * { destruct H3 as [H3|H3].
        - inversion H3. exfalso. congruence.
        - now apply IH.
      }
    * { destruct H3 as [H3|H3].
        - inversion H3. exfalso. congruence.
        - destruct (asset_value (k,v)) as [w|] eqn: E1.
          + rewrite (asset_value_sum_value_cons _ _ _ E1).
            rewrite (asset_value_sum_value_cons _ _ _ E1).
            apply IH in H3.
            * omega.
            * exact H3'.
          + rewrite (asset_value_sum_novalue_cons _ _ E1).
            rewrite (asset_value_sum_novalue_cons _ _ E1).
            exact (IH H3 H3').
      }
Qed.

Lemma add_vout_lem (bday bday':nat) (txh:hashval) (outpl:list addr_preasset) (i:nat) alpha h u :
In (alpha,(h,(bday,u))) (add_vout bday' txh outpl i)
<->
(bday = bday' /\
 exists j, nth_error outpl j = value (alpha,u)
           /\ h = hashpair txh (hashnat (i + j))).
revert i. induction outpl as [|[k [obl v]] outpr IH]; intros i.
- simpl. split.
  + tauto.
  + intros [Hb [[|j] [H1 _]]]; discriminate H1.
- simpl. split.
  + intros [H1|H1].
    * { inversion H1. split.
        - reflexivity.
        - exists 0. split.
          + reflexivity.
          + f_equal. f_equal. omega.
      }
    * { apply IH in H1. destruct H1 as [Hb [j [H2 H3]]]. split.
        - exact Hb.
        - exists (S j). split.
          + exact H2.
          + rewrite H3. f_equal. f_equal. omega.
      }
  + intros [Hb [[|j] [H1 H2]]].
    * { left. simpl in H1. inversion H1. rewrite H2.
        f_equal. f_equal.
        - f_equal. f_equal. omega.
        - congruence.
      }
    * { right. apply IH. split.
        - exact Hb.
        - exists j. split.
          + exact H1.
          + rewrite H2. f_equal. f_equal. omega.
      }
Qed.

Fixpoint output_uses (b:bool) (outpl:list addr_preasset) : list termaddr :=
  match outpl with
    | (_,(_,signapublication _ _ th d))::outpr =>
      if b then
        (map hashval_termaddr (signaspec_uses_props th d)) ++ output_uses b outpr
      else
        (map hashval_termaddr (signaspec_uses_objs d)) ++ output_uses b outpr
    | (_,(_,docpublication _ _ th d))::outpr =>
      if b then
        (map hashval_termaddr (doc_uses_props th d)) ++ output_uses b outpr
      else
        (map hashval_termaddr (doc_uses_objs d)) ++ output_uses b outpr
    | _::outpr => output_uses b outpr
    | nil => nil
  end.

Fixpoint output_creates (b:bool) (outpl:list addr_preasset) : list (prod hashval hashval) :=
  match outpl with
    | (_,(_,docpublication _ _ th d))::outpr =>
      if b then
        (doc_creates_props th d) ++ output_creates b outpr
      else
        (doc_creates_objs th d) ++ output_creates b outpr
    | _::outpr => output_creates b outpr
    | nil => nil
  end.

Fixpoint output_markers (outpl:list addr_preasset) : list hashval :=
  match outpl with
    | (_,(_,signapublication _ _ th d))::outpr =>
      signaspec_stp_markers d ++ signaspec_known_markers th d ++ output_markers outpr
    | (_,(_,docpublication _ _ th d))::outpr =>
      doc_stp_markers d ++ doc_known_markers th d ++ output_markers outpr
    | _::outpr => output_markers outpr
    | nil => nil
  end.

Lemma signaspec_stp_markers_output_markers h alpha obl gamma nonce th s outpl :
  In (alpha,(obl,signapublication gamma nonce th s)) outpl
  -> In h (signaspec_stp_markers s)
  -> In h (output_markers outpl).
induction outpl as [|[beta [obl' [u|u|[|] gamma' [u|]|[|] k gamma'| |gamma' m d|gamma' m th' d|gamma' m th' d]]] outpr IH].
- simpl. tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1. intros H. apply in_or_app. tauto.
  + intros H. apply in_or_app. right. apply in_or_app. tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + intros H. apply in_or_app. right. apply in_or_app. tauto.
Qed.

Lemma signaspec_known_markers_output_markers h alpha obl gamma nonce th s outpl :
  In (alpha,(obl,signapublication gamma nonce th s)) outpl
  -> In h (signaspec_known_markers th s)
  -> In h (output_markers outpl).
induction outpl as [|[beta [obl' [u|u|[|] gamma' [u|]|[|] k gamma'| |gamma' m d|gamma' m th' d|gamma' m th' d]]] outpr IH].
- simpl. tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1. intros H. apply in_or_app. right. apply in_or_app. tauto.
  + intros H. apply in_or_app. right. apply in_or_app. tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + intros H. apply in_or_app. right. apply in_or_app. tauto.
Qed.

Lemma doc_stp_markers_output_markers h alpha obl gamma nonce th s outpl :
  In (alpha,(obl,docpublication gamma nonce th s)) outpl
  -> In h (doc_stp_markers s)
  -> In h (output_markers outpl).
induction outpl as [|[beta [obl' [u|u|[|] gamma' [u|]|[|] k gamma'| |gamma' m d|gamma' m th' d|gamma' m th' d]]] outpr IH].
- simpl. tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + intros H. apply in_or_app. right. apply in_or_app. tauto.
- simpl. intros [H1|H1].
  + inversion H1. intros H. apply in_or_app. tauto.
  + intros H. apply in_or_app. right. apply in_or_app. tauto.
Qed.

Lemma doc_known_markers_output_markers h alpha obl gamma nonce th s outpl :
  In (alpha,(obl,docpublication gamma nonce th s)) outpl
  -> In h (doc_known_markers th s)
  -> In h (output_markers outpl).
induction outpl as [|[beta [obl' [u|u|[|] gamma' [u|]|[|] k gamma'| |gamma' m d|gamma' m th' d|gamma' m th' d]]] outpr IH].
- simpl. tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + tauto.
- simpl. intros [H1|H1].
  + inversion H1.
  + intros H. apply in_or_app. right. apply in_or_app. tauto.
- simpl. intros [H1|H1].
  + inversion H1. intros H. apply in_or_app. right. apply in_or_app. tauto.
  + intros H. apply in_or_app. right. apply in_or_app. tauto.
Qed.

Lemma output_uses_nil b : output_uses b nil = nil.
destruct b; reflexivity.
Qed.

Lemma output_uses_app b outpl1 outpl2 :
  output_uses b (outpl1 ++ outpl2) = output_uses b outpl1 ++ output_uses b outpl2.
induction outpl1 as [|[beta [obl [u|u|[|] gamma [u|]|[|] k gamma| |gamma m d|gamma m th d|gamma m th d]]] outpl1 IH]; try (simpl; tauto).
- simpl. destruct b; rewrite IH; apply app_assoc.
- simpl. destruct b; rewrite IH; apply app_assoc.
Qed.

Lemma output_uses_app_or alpha b l r :
  In alpha (output_uses b (l ++ r))
  <->
  (In alpha (output_uses b l) \/ In alpha (output_uses b r)).
rewrite output_uses_app. split.
- apply in_app_or.
- apply in_or_app.
Qed.

Lemma output_creates_nil b : output_creates b nil = nil.
destruct b; reflexivity.
Qed.

Lemma output_creates_app b outpl1 outpl2 :
  output_creates b (outpl1 ++ outpl2) = output_creates b outpl1 ++ output_creates b outpl2.
induction outpl1 as [|[beta [obl [u|u|[|] gamma [u|]|[|] k gamma| |gamma m d|gamma m th d|gamma m th d]]] outpl1 IH]; try (simpl; tauto).
- simpl. destruct b; rewrite IH; apply app_assoc.
Qed.

Lemma output_creates_app_or alpha b l r :
  In alpha (output_creates b (l ++ r))
  <->
  (In alpha (output_creates b l) \/ In alpha (output_creates b r)).
rewrite output_creates_app. split.
- apply in_app_or.
- apply in_or_app.
Qed.

Fixpoint rights_out_objs (outpl:list addr_preasset) (alpha:termaddr) : nat :=
  match outpl with
    | (_,(_,rights false n beta))::outpr =>
      if termaddr_eq_dec alpha beta then
        n + rights_out_objs outpr alpha
      else
        rights_out_objs outpr alpha
    | _::outpr => rights_out_objs outpr alpha
    | nil => 0
  end.

Fixpoint rights_out_props (outpl:list addr_preasset) (alpha:termaddr) : nat :=
  match outpl with
    | (_,(_,rights true n beta))::outpr =>
      if termaddr_eq_dec alpha beta then
        n + rights_out_props outpr alpha
      else
        rights_out_props outpr alpha
    | _::outpr => rights_out_props outpr alpha
    | nil => 0
  end.

Definition rights_out (b:bool) (outpl:list addr_preasset) (alpha:termaddr) : nat :=
if b then rights_out_props outpl alpha else rights_out_objs outpl alpha.

Lemma rights_out_nil b alpha :
  rights_out b nil alpha = 0.
destruct b; reflexivity.
Qed.

Lemma rights_out_app b outpl1 outpl2 alpha :
  rights_out b (outpl1 ++ outpl2) alpha = rights_out b outpl1 alpha + rights_out b outpl2 alpha.
induction outpl1 as [|[beta [obl [u|u|[|] gamma [u|]|[|] k gamma| |gamma m d|gamma m th d|gamma m th d]]] outpl1 IH]; try (simpl; tauto).
- destruct b; reflexivity.
- destruct b; simpl.
  + destruct (termaddr_eq_dec alpha gamma) as [D|D].
    * simpl in IH. rewrite IH. apply plus_assoc.
    * exact IH.
  + exact IH.
- destruct b; simpl.
  + exact IH.
  + destruct (termaddr_eq_dec alpha gamma) as [D|D].
    * simpl in IH. rewrite IH. apply plus_assoc.
    * exact IH.
Qed.

Fixpoint count_rights_used (bl:list termaddr) (alpha:termaddr) : nat :=
  match bl with
    | beta::br =>
      if termaddr_eq_dec beta alpha then
        S (count_rights_used br alpha)
      else
        count_rights_used br alpha
    | nil => 0
  end.

Lemma count_rights_used_none bl alpha :
  ~In alpha bl -> count_rights_used bl alpha = 0.
induction bl as [|beta bl1 IH].
- simpl. tauto.
- intros H1. simpl. destruct (termaddr_eq_dec beta alpha) as [D|D].
  + exfalso. apply H1. subst beta. now left.
  + apply IH. intros H2. apply H1. now right.
Qed.

Lemma count_rights_used_app bl1 bl2 alpha :
  count_rights_used (bl1 ++ bl2) alpha = count_rights_used bl1 alpha + count_rights_used bl2 alpha.
induction bl1 as [|beta bl1 IH].
- simpl. reflexivity.
- simpl. destruct (termaddr_eq_dec beta alpha) as [D|D].
  + rewrite IH. reflexivity.
  + exact IH.
Qed.

Definition rights_mentioned (alpha:termaddr) (b:bool) (outpl:list addr_preasset) : Prop :=
  In alpha (output_uses b outpl) \/ (exists beta obl n, In (beta,(obl,rights b n alpha)) outpl).

Definition rights_mentioned_dec alpha b outpl :
  { rights_mentioned alpha b outpl } + { ~ rights_mentioned alpha b outpl }.
induction outpl as [|[beta [obl u]] outpr IH].
- right. intros [H1|[beta [obl [n H1]]]].
  + contradiction H1.
  + contradiction H1.
- destruct IH as [H1|H1].
  + left. destruct H1 as [H1|[beta' [obl' [n' H1]]]].
    * left.
      change (In alpha (output_uses b (((beta,(obl,u))::nil) ++ outpr))).
      apply output_uses_app_or. now right.
    * right. exists beta'. exists obl'. exists n'. now right.
  + destruct u as [u|u|c gamma [u|]|c k gamma| |gamma m d|gamma m th d|gamma m th d].
    * { right. intros [H2|[beta' [obl' [n' [H2|H2]]]]].
        - apply H1. now left.
        - discriminate H2.
        - apply H1. right. exists beta'. exists obl'. exists n'. exact H2.
      }
    * { right. intros [H2|[beta' [obl' [n' [H2|H2]]]]].
        - apply H1. now left.
        - discriminate H2.
        - apply H1. right. exists beta'. exists obl'. exists n'. exact H2.
      }
    * { right. intros [H2|[beta' [obl' [n' [H2|H2]]]]].
        - apply H1. now left.
        - discriminate H2.
        - apply H1. right. exists beta'. exists obl'. exists n'. exact H2.
      }
    * { right. intros [H2|[beta' [obl' [n' [H2|H2]]]]].
        - apply H1. now left.
        - discriminate H2.
        - apply H1. right. exists beta'. exists obl'. exists n'. exact H2.
      }
    * { assert (L1 : { b = c /\ alpha = gamma } + { ~ (b = c /\ alpha = gamma) }).
        { destruct (termaddr_eq_dec alpha gamma) as [D1|D1].
          - destruct b; destruct c.
            + left. tauto.
            + right. intros [H2 _]. discriminate H2.
            + right. intros [H2 _]. discriminate H2.
            + left. tauto.
          - right. tauto.
        }
        destruct L1 as [[E1 E2]|D1].
        - left. subst c. subst gamma. right. exists beta. exists obl. exists k. now left.
        - right. intros [H2|[beta' [obl' [n' [H2|H2]]]]].
          + apply H1. now left.
          + inversion H2.  apply D1. split; congruence.
          + apply H1. right. exists beta'. exists obl'. exists n'. exact H2.
      }
    * { right. intros [H2|[beta' [obl' [n' [H2|H2]]]]].
        - apply H1. now left.
        - discriminate H2.
        - apply H1. right. exists beta'. exists obl'. exists n'. exact H2.
      }
    * { right. intros [H2|[beta' [obl' [n' [H2|H2]]]]].
        - apply H1. now left.
        - discriminate H2.
        - apply H1. right. exists beta'. exists obl'. exists n'. exact H2.
      }
    * { destruct b.
        - destruct (in_dec termaddr_eq_dec alpha (map hashval_termaddr (signaspec_uses_props th d))) as [D1|D1].
          + left. left. simpl. apply in_or_app. left. exact D1.
          + right. intros [H2|[beta' [obl' [n' [H2|H2]]]]].
            * { apply H1. simpl in H2. apply in_app_or in H2.
                destruct H2 as [H2|H2].
                - contradiction (D1 H2).
                - now left.
              }
            * discriminate H2.
            * apply H1. right. exists beta'. exists obl'. exists n'. exact H2.
        - destruct (in_dec termaddr_eq_dec alpha (map hashval_termaddr (signaspec_uses_objs d))) as [D1|D1].
          + left. left. simpl. apply in_or_app. left. exact D1.
          + right. intros [H2|[beta' [obl' [n' [H2|H2]]]]].
            * { apply H1. simpl in H2. apply in_app_or in H2.
                destruct H2 as [H2|H2].
                - contradiction (D1 H2).
                - now left.
              }
            * discriminate H2.
            * apply H1. right. exists beta'. exists obl'. exists n'. exact H2.
      }
    * { destruct b.
        - destruct (in_dec termaddr_eq_dec alpha (map hashval_termaddr (doc_uses_props th d))) as [D1|D1].
          + left. left. simpl. apply in_or_app. left. exact D1.
          + right. intros [H2|[beta' [obl' [n' [H2|H2]]]]].
            * { apply H1. simpl in H2. apply in_app_or in H2.
                destruct H2 as [H2|H2].
                - contradiction (D1 H2).
                - now left.
              }
            * discriminate H2.
            * apply H1. right. exists beta'. exists obl'. exists n'. exact H2.
        - destruct (in_dec termaddr_eq_dec alpha (map hashval_termaddr (doc_uses_objs d))) as [D1|D1].
          + left. left. simpl. apply in_or_app. left. exact D1.
          + right. intros [H2|[beta' [obl' [n' [H2|H2]]]]].
            * { apply H1. simpl in H2. apply in_app_or in H2.
                destruct H2 as [H2|H2].
                - contradiction (D1 H2).
                - now left.
              }
            * discriminate H2.
            * apply H1. right. exists beta'. exists obl'. exists n'. exact H2.
      }
Defined.

(***
Lemma count_rights_used_prop_pos_mentioned d alpha :
  count_rights_used (map hashval_addr (data_uses_props d)) alpha > 0 ->
***)

Lemma rights_mentioned_cons alpha b gamma oblu outpl :
  rights_mentioned alpha b outpl ->
  rights_mentioned alpha b ((gamma,oblu)::outpl).
intros [H1|[beta [obl [n H1]]]].
- left. change (In alpha (output_uses b (((gamma, oblu)::nil) ++ outpl))).
  apply output_uses_app_or. now right.
- right. exists beta. exists obl. exists n. now right.
Qed.

Lemma rights_unmentioned_no_rights_out alpha b outpl :
  ~rights_mentioned alpha b outpl ->
  rights_out b outpl alpha = 0.
induction outpl as [|[beta [obl u]] outpr IH].
- intros _. destruct b; reflexivity.
- intros H1. destruct b; destruct u as [u|u|c gamma [u|]|c k gamma|gamma|m d|m th d|m th d].
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. destruct c.
    * { destruct (termaddr_eq_dec alpha gamma) as [D|D].
        - exfalso. apply H1. right. exists beta. exists obl. exists k.
          subst gamma. now left.
        - apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
      }
    * apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. destruct c.
    * apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
    * { destruct (termaddr_eq_dec alpha gamma) as [D|D].
        - exfalso. apply H1. right. exists beta. exists obl. exists k.
          subst gamma. now left.
        - apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
      }
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
Qed.

Lemma rights_unmentioned_no_rights_used alpha b outpl :
  ~rights_mentioned alpha b outpl ->
  count_rights_used (output_uses b outpl) alpha = 0.
induction outpl as [|[beta [obl u]] outpr IH].
- intros _. destruct b; reflexivity.
- intros H1. destruct b; destruct u as [u|u|c gamma [u|]|c k gamma| |gamma m d|gamma m th d|gamma m th d].
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. rewrite count_rights_used_app.
    rewrite IH.
    * { destruct (in_dec termaddr_eq_dec alpha (map hashval_termaddr (signaspec_uses_props th d))) as [D1|D1].
        - exfalso. apply H1. left.
          change (In alpha (output_uses true (((beta, (obl, signapublication gamma m th d)) :: nil) ++ outpr))).
          apply output_uses_app_or.
          left. simpl. rewrite app_nil_r. exact D1.
        - apply count_rights_used_none in D1. rewrite D1. reflexivity.
      }
    * intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. rewrite count_rights_used_app.
    rewrite IH.
    * { destruct (in_dec termaddr_eq_dec alpha (map hashval_termaddr (doc_uses_props th d))) as [D1|D1].
        - exfalso. apply H1. left.
          change (In alpha (output_uses true (((beta, (obl, docpublication gamma m th d)) :: nil) ++ outpr))).
          apply output_uses_app_or.
          left. simpl. rewrite app_nil_r. exact D1.
        - apply count_rights_used_none in D1. rewrite D1. reflexivity.
      }
    * intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. apply IH. intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. rewrite count_rights_used_app.
    rewrite IH.
    * { destruct (in_dec termaddr_eq_dec alpha (map hashval_termaddr (signaspec_uses_objs d))) as [D1|D1].
        - exfalso. apply H1. left.
          change (In alpha (output_uses false (((beta, (obl, signapublication gamma m th d)) :: nil) ++ outpr))).
          apply output_uses_app_or.
          left. simpl. rewrite app_nil_r. exact D1.
        - apply count_rights_used_none in D1. rewrite D1. reflexivity.
      }
    * intros H2. apply H1. now apply rights_mentioned_cons.
  + simpl. rewrite count_rights_used_app.
    rewrite IH.
    * { destruct (in_dec termaddr_eq_dec alpha (map hashval_termaddr (doc_uses_objs d))) as [D1|D1].
        - exfalso. apply H1. left.
          change (In alpha (output_uses false (((beta, (obl, docpublication gamma m th d)) :: nil) ++ outpr))).
          apply output_uses_app_or.
          left. simpl. rewrite app_nil_r. exact D1.
        - apply count_rights_used_none in D1. rewrite D1. reflexivity.
      }
    * intros H2. apply H1. now apply rights_mentioned_cons.
Qed.

(*** only count the ones with no external obligation ***)
Fixpoint units_sent_to_addr (beta:addr) (outpl:list addr_preasset) : nat :=
match outpl with
| (alpha,(None,currency u))::outpr =>
  if addr_eq_dec alpha beta then
    u + units_sent_to_addr beta outpr
  else
    units_sent_to_addr beta outpr
| _::outpr => units_sent_to_addr beta outpr
| nil => 0
end.

Lemma units_sent_to_addr_app beta outpl1 outpl2 :
  units_sent_to_addr beta (outpl1 ++ outpl2) = units_sent_to_addr beta outpl1 + units_sent_to_addr beta outpl2.
induction outpl1 as [|[alpha [[[a [|n]]|] [u|u|[|] gamma [u|]|[|] k gamma| |gamma m' d|gamma m' th d|gamma m' th d]]] outpl1 IH]; try exact IH.
- reflexivity.
- simpl. destruct (addr_eq_dec alpha beta) as [D|D].
  + rewrite IH. apply plus_assoc.
  + exact IH.
Qed.

Fixpoint out_burncost (outpl:list addr_preasset) : nat :=
match outpl with
| (alpha,(obl,theorypublication _ _ s))::outpr => theoryspec_burncost s + out_burncost outpr
| (alpha,(obl,signapublication _ _ _ s))::outpr => signaspec_burncost s + out_burncost outpr
| (alpha,_)::outpr => out_burncost outpr
| nil => 0
end.

Lemma out_burncost_app (l r:list addr_preasset) :
  out_burncost (l ++ r) = out_burncost l + out_burncost r.
induction l as [|[beta [obl u]] l IH].
- simpl. reflexivity.
- simpl. destruct u as [u|u|[|] alpha [u|]|[|] k alpha|alpha|m d|m th d|m th d]; simpl; omega.
Qed.