Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Language.
Require Import Strings.String.

Set Printing Parentheses.

Lemma sub_reflexivity:
  forall (A : typ), sub A A.
Proof.
  intros.
  dependent induction A; eauto.
Qed.

Hint Resolve sub_reflexivity : core.

Lemma sub_and_inversion:
  forall (A B C : typ), sub A (typ_and B C) -> sub A B /\ sub A C.
Proof.
  intros A B C H.
  dependent induction H; eauto.
  destruct (IHsub B C); eauto.
  destruct (IHsub B C); eauto.
Qed.

Lemma sub_transitivity:
  forall (B A C : typ),
    sub A B -> sub B C -> sub A C.
Proof.
  dependent induction B; intros; eauto.
  - dependent induction H; eauto.
  - dependent induction H; eauto.
    dependent induction H0; eauto.
  - dependent induction H0; eauto.
    clear IHsub1 IHsub2.
    dependent induction H; eauto.
  - eapply sub_and_inversion in H. destruct H.
    dependent induction H0; eauto.
Qed.

Lemma sub_toplike1:
  forall (A B : typ),
    toplike A -> sub B A.
Proof.
  intros.
  generalize dependent B.
  dependent induction H; eauto.
Qed.

Lemma sub_toplike2:
  forall (A : typ),
    sub typ_top A -> toplike A.
Proof.
  intros.
  dependent induction H; eauto.
Qed.

Hint Resolve sub_toplike1 : core.
Hint Resolve sub_toplike2 : core.

(* aux lemma for tred_determinism *)
Lemma tred_ord_toplike :
  forall (v v' : trm) (A : typ),
    ordinary A -> toplike A -> typedred v A v' ->
    v' = (trm_anno (trm_int 1) A).
Proof.
  intros.
  dependent induction H1; eauto; try solve [inversion H | inversion H0]; subst.
  dependent destruction H0. contradiction.
Qed.

(* aux lemma for disjoint_value_consistent *)
Lemma tred_sub :
  forall (A B : typ) (v v' : trm),
    value v -> typedred v A v' ->
    typing nil nil v B ->
    sub B A.
Proof.
  intros.
  generalize dependent B.
  dependent induction H0; eauto; intros.
  - dependent destruction H1.
    dependent destruction H2.
    eapply sub_reflexivity.
  - dependent destruction H2.
    dependent destruction H4; eauto.
  - dependent destruction H.
    dependent destruction H3.
    eapply sub_and_l. eapply IHtypedred; eauto.
    eapply sub_and_l. eapply IHtypedred; eauto.
  - dependent destruction H.
    dependent destruction H3.
    eapply sub_and_r. eapply IHtypedred; eauto.
    eapply sub_and_r. eapply IHtypedred; eauto.
Qed.

(* aux lemma for disjoint_value_consistent *)
Lemma tred_determinism_toplike :
  forall (A : typ),
    toplike A ->
    forall (e1 e2 e1' e2' : trm), typedred e1 A e1' -> typedred e2 A e2' -> e1' = e2'.
Proof.
  intros A Htop.
  dependent induction Htop; intros; eauto.
  - eapply tred_ord_toplike in H; eauto.
    eapply tred_ord_toplike in H0; eauto.
    rewrite H. rewrite H0. reflexivity.
  - dependent destruction H; eauto.
    + inversion H0.
    + inversion H0.
    + inversion H0.
    + dependent destruction H1.
      * inversion H2.
      * inversion H2.
      * inversion H2.
      * assert (Heq1: v1 = v0). eapply IHHtop1; eauto 3.
        assert (Heq2: v2 = v3). eapply IHHtop2; eauto 3.
        rewrite Heq1. rewrite Heq2. reflexivity.
  - assert (Htl: toplike (typ_arrow A B)).
    eapply tl_arrow; eauto.
    eapply tred_ord_toplike in H; eauto.
    eapply tred_ord_toplike in H0; eauto.
    rewrite H. rewrite H0. reflexivity.
Qed.

(* aux lemma for tred_determinism *)
Lemma disjoint_value_consistent :
  forall (A B : typ) (v1 v2 : trm),
    disjoint_spec A B -> value v1 -> value v2 ->
    typing nil nil v1 A -> typing nil nil v2 B ->
    consistency_spec v1 v2.
Proof.
  intros. unfold consistency_spec.
  intros.
  unfold disjoint_spec in H.
  assert (Hsub1: sub A A0). eapply tred_sub. apply H0. apply H4. apply H2.
  assert (Hsub2: sub B A0). eapply tred_sub. apply H1. apply H5. apply H3.
  assert (Htl: toplike A0). eapply H; eauto.
  eapply tred_determinism_toplike; eauto.
Qed.

Theorem tred_determinism :
  forall (v v1 v2 : trm) (A : typ),
    value v -> (exists B, typing nil nil v B) ->
    typedred v A v1 -> typedred v A v2 -> v1 = v2.
Proof.
  intros v v1 v2 A Hv Htyp Hred1.
  generalize dependent v2.
  dependent induction Hred1; eauto.
  - intros v2 Hred2.
    dependent induction Hred2; eauto.
    inversion H.
  - intros v2 Hred2.
    dependent destruction Hred2; eauto; try solve [inversion H | inversion H0].
    + dependent destruction H. contradiction.
    + symmetry. eapply tred_ord_toplike; eauto.
    + symmetry. eapply tred_ord_toplike; eauto.
  - intros v2 Hred2.
    dependent destruction Hred2; eauto; subst.
    + dependent destruction H1. contradiction.
  - intros v0 Hred2.
    dependent destruction Hv.
    dependent destruction Htyp.
    dependent destruction Hred2; eauto; subst.
    + eapply tred_ord_toplike; eauto.
    + dependent destruction H; eauto.
    + dependent destruction H.
      * assert (Hcon: consistency_spec v1 v2).
        eapply disjoint_value_consistent; eauto 3.
        eapply Hcon; eauto 3.
      * eapply H3; eauto 3.
    + inversion H0.
  - intros v0 Hred2.
    dependent destruction Hv.
    dependent destruction Htyp.
    dependent destruction Hred2; eauto; subst.
    + eapply tred_ord_toplike; eauto.
    + dependent destruction H.
      * assert (Hcon: consistency_spec v1 v2).
        eapply disjoint_value_consistent; eauto 3.
        symmetry.
        eapply Hcon; eauto 3.
      * symmetry. eapply H3; eauto 3.
    + dependent destruction H; eauto.
    + inversion H0.
  - intros v0 Hred2.
    dependent destruction Hred2; eauto.
    + inversion H0.
    + inversion H.
    + inversion H.
    + assert (Heq1: v1 = v0). eapply IHHred1_1; eauto 3.
      assert (Heq2: v2 = v3). eapply IHHred1_2; eauto 3.
      rewrite Heq1. rewrite Heq2. reflexivity.
Qed.

Lemma ptype_determinism :
  forall (e : trm) (A B : typ),
    ptype e A -> ptype e B -> A = B.
Proof.
  intros. generalize dependent B.
  dependent induction H; eauto; intros.
  - dependent destruction H0; eauto.
  - dependent destruction H0; eauto.
  - dependent destruction H1; eauto.
    assert (A = A0); eauto.
    assert (B = B0); eauto.
    rewrite H1. rewrite H2. reflexivity.
Qed.

Hint Resolve ptype_determinism : core.

Lemma appsub_determinism :
  forall (A : typ) (B1 B2 : typ) (S : arg),
    appsub S A B1 ->
    appsub S A B2 ->
    B1 = B2.
Proof.
  intros A B1 B2 S Has1 Has2.
  generalize dependent B2.
  dependent induction Has1; intros.
  - dependent destruction Has2.
    + reflexivity.
  - dependent destruction Has2.
    + assert (Heq: D = D0).
      eapply IHHas1; eauto.
      rewrite Heq. reflexivity.
  - dependent destruction Has2.
    + eapply IHHas1; eauto.
    + admit.
  - dependent destruction Has2.
    + admit.
    + eapply IHHas1; eauto.
Admitted.

Lemma ptype_merge_same :
  forall (v1 v2 : trm) (A : typ),
    value v1 -> value v2 ->
    (exists A, typing nil nil (trm_merge v1 v2) A) ->
    ptype (trm_merge v1 v2) (typ_and A A) ->
    v1 = v2.
Proof.
  intros v1 v2 A Hv1 Hv2 Htyp Hptyp.
  destruct Htyp.
Admitted.

Lemma typing_app_go_deeper :
  forall (v1 v2 vl : trm),
    value v1 -> value v2 -> value vl ->
    (exists A, typing nil nil (trm_app (trm_merge v1 v2) vl) A) ->
    (exists B, typing nil nil (trm_app v1 vl) B) \/
    (exists C, typing nil nil (trm_app v2 vl) C).
Proof.
Admitted.

Lemma papp_determinism:
  forall (v vl e1 e2 : trm),
    value v -> value vl ->
    (exists A, typing nil nil vl A) ->
    papp v vl e1 -> papp v vl e2 -> e1 = e2.
Proof.
  intros v vl e1 e2 Hv Hv1 Htyp Hp1 Hp2.
  generalize dependent e2.
  dependent induction Hp1; eauto; intros.
  - dependent destruction Hp2; eauto.
    + assert (A = A0); eauto. rewrite H3. reflexivity.
    + dependent destruction H. dependent destruction H0. contradiction.
    + assert (A = C); eauto. subst. contradiction.
    + assert (A = C); eauto. subst. contradiction.
  - dependent destruction Hp2.
    + dependent destruction H1. dependent destruction H2. contradiction.
    + assert (v' = v'0). eapply tred_determinism; eauto.
      destruct Htyp. dependent destruction H3; eauto.
  - dependent destruction Hv.
    eapply IHHp1; eauto.
    dependent destruction Hp2; eauto.
    + assert (A0 = C). eapply ptype_determinism; eauto. subst.
      contradiction.
    + assert (C = C0). eapply ptype_determinism; eauto. subst.
      dependent destruction H6.
      assert (A1 = B1). admit. subst.
      eapply ptype_merge_same in H1; eauto.
      (* ptype_merge_same premises is not enought here *)
Admitted.

Lemma papp_determinism2 :
  forall (v vl e1 e2 : trm),
    value v -> value vl ->
    (exists A, typing nil nil v A) ->
    (exists B, typing nil nil vl B) ->
    papp v vl e1 -> papp v vl e2 -> e1 = e2.
Proof.
  intros v vl e1 e2 Hv Hvl Htyp1 Htyp2 Hp1 Hp2.
  generalize dependent e2.
  dependent induction Hp1; eauto; intros.
  - dependent destruction Hp2; eauto.
    + assert (A = A0); eauto. rewrite H3. reflexivity.
    + dependent destruction H. dependent destruction H0. contradiction.
    + assert (A = C); eauto. subst. contradiction.
    + assert (A = C); eauto. subst. contradiction.
  - dependent destruction Hp2.
    + dependent destruction H1. dependent destruction H2. contradiction.
    + assert (v' = v'0). eapply tred_determinism; eauto.
      destruct Htyp1. dependent destruction H3; eauto.
  - dependent destruction Hv.
    eapply IHHp1; eauto.
    dependent destruction Hp2; eauto.
    + assert (A0 = C). eapply ptype_determinism; eauto. subst.
      contradiction.
    + assert (C = C0). eapply ptype_determinism; eauto. subst.
      dependent destruction H6.
      assert (A1 = B1). admit. subst.
      eapply ptype_merge_same in H1; eauto.
      (* ptype_merge_same premises is not enought here *)
Admitted.

Lemma value_cannot_step_further:
  forall (v : trm),
    value v -> forall (e : trm), not (step v e).
Proof.
  intros v Hv.
  dependent induction v; intros; try solve [inversion Hv | eauto].
  - dependent destruction Hv. intros Hm.
    dependent destruction Hm.
    + eapply IHv1; eauto.
    + eapply IHv2; eauto.
  - dependent destruction Hv.
    induction H; eauto.
    + intros Hs.
      dependent destruction Hs; eauto.
      dependent destruction H.
    + intros Hs.
      dependent destruction Hs; eauto.
      dependent destruction H.
Qed.

Lemma stack_and_unstack1:
  forall (e : trm) (A B : typ),
    typing nil (cons A nil) e (typ_arrow A B) ->
    (exists C, typing nil nil e C).
Proof.
  intros.
  dependent induction e; try solve [inversion H | dependent destruction H; eauto].
  (* dependent destruction H. *)
Admitted.

Theorem determinism:
  forall (e e1 e2 : trm) (A : typ) (S : arg),
    typing nil nil e A ->
    step e e1 -> step e e2 -> e1 = e2.
Proof.
  intros e e1 e2 A S Htyp Hstep1.
  generalize dependent e2.
  generalize dependent A.
  dependent induction Hstep1; intros.
  - dependent destruction H; eauto.
  - dependent destruction H2; eauto.
    + eapply papp_determinism with (v:=v) (vl:=vl); eauto.
      dependent destruction Htyp; eauto.
    + eapply value_cannot_step_further in H2; eauto. inversion H2.
    + eapply value_cannot_step_further in H3; eauto. inversion H3.
  - dependent destruction H1.
    + eapply tred_determinism; eauto.
      dependent destruction Htyp; eauto.
    + eapply value_cannot_step_further in H2; eauto. inversion H2.
  - dependent destruction H0.
    + eapply value_cannot_step_further in Hstep1; eauto. inversion Hstep1.
    + assert (Heq: e' = e'0).
      dependent destruction Htyp.
      eapply IHHstep1; eauto.
      dependent destruction Htyp; eauto.
      rewrite Heq. reflexivity.
  - dependent destruction H.
    + eapply value_cannot_step_further in Hstep1; eauto. inversion Hstep1.
    + dependent destruction Htyp; eauto.
      eapply stack_and_unstack1 in Htyp2. destruct Htyp2.
      assert (Heq: e1' = e1'0). eapply IHHstep1; eauto.
      rewrite Heq. reflexivity.
    + eapply value_cannot_step_further in Hstep1; eauto. inversion Hstep1.
  - dependent destruction H0.
    + eapply value_cannot_step_further in Hstep1; eauto. inversion Hstep1.
    + eapply value_cannot_step_further in H0; eauto. inversion H0.
    + assert (Heq: e2' = e2'0).
      dependent destruction Htyp.
      eapply IHHstep1; eauto.
      rewrite Heq. reflexivity.
  - dependent destruction H.
    + assert (e1' = e1'0).
      dependent destruction Htyp; eapply IHHstep1; eauto.
      rewrite H0. reflexivity.
    + eapply value_cannot_step_further in Hstep1; eauto. inversion Hstep1.
  - dependent destruction H0.
    + eapply value_cannot_step_further in H0; eauto. inversion H0.
    + assert (e2' = e2'0).
      dependent destruction Htyp; eapply IHHstep1; eauto.
      rewrite H2. reflexivity.
Qed.

Lemma appsub_typing :
  forall (v : trm) (S : arg) (A B : typ),
    value v -> typing nil nil v A ->
    appsub S A B ->
    typing nil S v B.
Proof.
  intros v S A B Hv Htyp Has.
  dependent induction Hv.
  - dependent destruction Htyp.
    dependent destruction H1.
    eapply typing_anno; eauto.
  - clear IHHv1 IHHv2.
    dependent induction S.
    + dependent destruction Has; eauto.
    + eapply typing_merge_pick; eauto.
Qed.

Lemma tred_value :
  forall (v v' : trm) (A : typ),
    value v -> typedred v A v' -> value v'.
Proof.
  intros.
  dependent induction H0; try solve [eauto | dependent destruction H; eauto].
Qed.

Hint Resolve tred_value : core.

Lemma tred_transitivity :
  forall (v1 v2 v3 : trm) (A B : typ),
    value v1 ->
    typedred v1 A v2 ->
    typedred v2 B v3 ->
    typedred v1 B v3.
Proof.
  intros.
  generalize dependent v3.
  generalize dependent B.
  dependent induction H0; eauto; intros.
  - dependent induction H2; eauto.
  - dependent induction H2; eauto 4.
    eapply tred_arrow_anno; eauto.
    eapply sub_transitivity; eauto.
  - dependent destruction H.
    dependent induction H3; eauto.
  - dependent destruction H.
    dependent induction H3; eauto.
  - generalize dependent v3.
    induction B0; intros v0 Hred2; try solve [eauto | dependent destruction Hred2; eauto].
Qed.

Lemma tred_consistency :
  forall (v v1 v2 : trm) (A B C : typ),
    value v -> typing nil nil v C ->
    typedred v A v1 ->
    typedred v B v2 ->
    consistency_spec v1 v2.
Proof.
  intros.
  unfold consistency_spec; intros.
  assert (typedred v A0 e1').
  eapply tred_transitivity with (v1:=v) (v2:=v1) (v3:=e1'); eauto.
  assert (typedred v A0 e2').
  eapply tred_transitivity with (v1:=v) (v2:=v2) (v3:=e2'); eauto.
  eapply tred_determinism; eauto.
Qed.

Theorem tred_preservation:
  forall (v v': trm) (A B: typ),
    value v ->
    typing nil nil v B ->
    sub B A ->
    typedred v A v' ->
    typing nil nil v' A.
Proof.
  intros v v' A B Hv Htyp Hsub Hred.
  generalize dependent B.
  dependent induction Hred; eauto; intros.
  - dependent destruction Htyp.
    dependent destruction H2.
    eapply typing_anno; eauto.
    eapply sub_transitivity; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp; eapply IHHred; eauto.
    + eapply tred_sub. apply Hv1. apply Hred. apply Htyp1.
    + eapply tred_sub. apply Hv1. apply Hred. apply Htyp1.
  - dependent destruction Hv.
    dependent destruction Htyp; eapply IHHred; eauto.
    + eapply tred_sub. apply Hv2. apply Hred. apply Htyp2.
    + eapply tred_sub. apply Hv2. apply Hred. apply Htyp2.
  - eapply typing_merge_value; eauto.
    + eapply IHHred1; eauto.
      eapply tred_sub. apply Hv. apply Hred1. apply Htyp.
    + eapply IHHred2; eauto.
      eapply tred_sub. apply Hv. apply Hred2. apply Htyp.
    + eapply tred_consistency; eauto.
Qed.

Lemma papp_preservation :
  forall (e e1 e2 : trm) (A B : typ) (S : arg),
    value e1 -> value e2 ->
    typing nil nil e2 A ->
    typing nil (cons A S) e1 (typ_arrow A B) ->
    papp e1 e2 e ->
    typing nil S e B.
Proof.
Admitted.

Theorem preservation :
  forall (e e' : trm) (A : typ) (S : arg),
    typing nil S e A ->
    step e e' ->
    typing nil S e' A.
Proof.
  intros e e' A S Htyp Hred.
  generalize dependent e'.
  dependent induction Htyp; intros; try solve [inversion Hred].
  - dependent destruction Hred.
    eapply typing_anno; eauto.
  - dependent destruction Hred; eauto.
    assert (typing nil nil v' A).
    eapply tred_preservation; eauto.
    eapply appsub_typing; eauto.
  - dependent destruction Hred; eauto.
    eapply papp_preservation with (e:=e) (e1:=e1) (e2:=e2); eauto.
  - dependent destruction Hred.
    + eapply typing_merge; eauto.
    + eapply typing_merge; eauto.
  - assert (value (trm_merge v1 v2)); eauto.
    apply value_cannot_step_further in Hred; eauto. inversion Hred.
  - assert (typing nil nil e' B); eauto.
    dependent destruction Hred; eauto.
Qed.

Lemma toplike_or_not_toplike :
  forall (A : typ),
    toplike A \/ not (toplike A).
Proof.
  intros A.
  dependent induction A; eauto; try solve [right; intros Hcontra; inversion Hcontra].
  - destruct IHA1; destruct IHA2; eauto.
    + right. intros H1. dependent destruction H1. contradiction.
    + right. intros H1. dependent destruction H1. contradiction.
  - destruct IHA1; destruct IHA2; eauto.
    + right. intros H1. dependent destruction H1. contradiction.
    + right. intros H1. dependent destruction H1. contradiction.
    + right. intros H1. dependent destruction H1. contradiction.
Qed.

Hint Resolve toplike_or_not_toplike : core.

Theorem tred_progress :
  forall (v : trm) (A : typ),
    value v -> typing nil nil v A ->
    exists v', typedred v A v'.
Proof.
  intros v A Hv Htyp.
  dependent induction A; eauto.
  - dependent induction Hv; eauto.
    + dependent induction H; eauto.
      * dependent destruction Htyp.
        dependent destruction Htyp.
        dependent destruction H1.
        exists (trm_anno (trm_int n) typ_int); eauto.
      * dependent destruction Htyp.
        dependent destruction Htyp.
        dependent destruction H1.
        dependent destruction H0.
    + dependent destruction Htyp.
  - clear IHA1 IHA2.
    dependent induction Hv.
    + dependent induction H.
      * dependent destruction Htyp.
        dependent destruction Htyp.
        dependent destruction H1.
        dependent destruction H0.
        exists (trm_anno (trm_int 1) (typ_arrow A1 A2)).
        eapply tred_top; eauto.
      * dependent destruction Htyp.
        dependent destruction Htyp.
        dependent destruction H1.
        assert (toplike A2 \/ not (toplike A2)); eauto.
        destruct H1.
        (* case top *)
        exists (trm_anno (trm_int 1) (typ_arrow A1 A2)).
        eapply tred_top; eauto.
        (* case not top *)
        exists (trm_anno (trm_abs A0 e) (typ_arrow A1 A2)).
        eapply tred_arrow_anno; eauto.
    + dependent destruction Htyp.
  - clear IHA1 IHA2.
Admitted.
(* the problem appear at case And *)
(* admitted since it might not a real-used one, refer to tred_preservation *)


Require Export Bool.Bool.
Require Export List.
Require Export Coq.Unicode.Utf8_core.

Require Import VarSet.
Require Import VarAssign.

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

Inductive boolExpr : Type :=
| BAtom : nat -> bool -> boolExpr
| BAnd  : boolExpr -> boolExpr -> boolExpr
| BOr   : boolExpr -> boolExpr -> boolExpr.

Inductive vtree : Type :=
| VNode : vtree -> vtree -> vtree
| VAtom : nat -> vtree.

Inductive vtree_varSet : vtree -> varSet -> Prop :=
| vtree_varSet_atom : forall n, vtree_varSet (VAtom n) (Var n Empty)
| vtree_varSet_node : forall l r lSet rSet resSet, vtree_varSet l lSet ->
                                                   vtree_varSet r rSet ->
                                                   union lSet rSet resSet ->
                                                   vtree_varSet (VNode l r) resSet.

Theorem vtree_varSet_unique :
  forall v vs, vtree_varSet v vs -> unique vs.
Proof.
  intros v vs Hv.
  induction Hv.
  - repeat constructor.
  - apply (union_unique lSet rSet); assumption.
Qed.

Inductive vtree_correct : vtree -> Prop :=
| vtree_correct_atom : forall n, vtree_correct (VAtom n)
| vtree_correct_node : forall l r lSet rSet, vtree_correct l ->
                                             vtree_correct r ->
                                             vtree_varSet l lSet ->
                                             vtree_varSet r rSet ->
                                             disjoint lSet rSet ->
                                             vtree_correct (VNode l r).

Inductive atom : Type :=
| AFalse : atom
| ATrue : atom
| AVar :  nat -> bool -> atom.

Inductive atom_varSet : atom -> varSet -> Prop :=
| atom_varSet_false : atom_varSet AFalse Empty
| atom_varSet_true  : atom_varSet ATrue Empty
| atom_varSet_var   : forall n b, atom_varSet (AVar n b) (Var n Empty).

Inductive sdd : Type :=
          (*prime sub   next *)
| Or: list (sdd * sdd) -> sdd
| Atom : atom -> sdd.

Section AllPairs.
  Variable T : Set.
  Variable P : T → Prop.

  Fixpoint AllPairs (ls : list (T*T)) : Prop :=
    match ls with
    | [] => True
    | (a,b)::t => P a ∧ P b ∧ AllPairs t
    end.
End AllPairs.

Section sdd_ind'.
  Variable P: sdd → Prop.
  Hypothesis Or_case' : forall (l:list (sdd*sdd)), AllPairs sdd P l → P (Or l).
  Hypothesis Atom_case' : forall (a:atom), P (Atom a).

    Fixpoint sdd_ind' (s:sdd) : P s :=
    let list_or_ind := (fix list_or_ind (l: list (sdd*sdd)) : (AllPairs sdd P l) :=
           match l with
           | [] => I
           | (p,s)::rest => (conj (sdd_ind' p) (conj (sdd_ind' s) (list_or_ind rest)))
           end)  in
    match s with
    | Or l => Or_case' l (list_or_ind l)
    | Atom a => Atom_case' a
    end.

End sdd_ind'.

Inductive

sdd_varSet : sdd -> varSet -> Prop :=
| sdd_varSet_atom : forall a vs, atom_varSet a vs -> sdd_varSet (Atom a) vs
| sdd_varSet_or   : forall l vs, sddList_varSet l vs -> sdd_varSet (Or l) vs

with

sddList_varSet : list (sdd*sdd) -> varSet -> Prop :=
| sddList_varSet_empty : sddList_varSet [] Empty
| sddList_varSet_pair  : forall p s rest pVs sVs rVs pairVs resVs, sdd_varSet p pVs ->
                                                                   sdd_varSet s sVs ->
                                                                   sddList_varSet rest rVs ->
                                                                   union pVs sVs pairVs ->
                                                                   union pairVs rVs resVs ->
                                                                   sddList_varSet ((p, s)::rest) resVs.

Inductive op : Type :=
| OAnd.

(* the magic of the Vtree lets us turn SDD sat/unsat testing into syntactic queries of the SDD *)

(* idea: a false atom is unsat, a false atom conjoined with anything is unsat,
   in order for an OR to be unsat all its children must be unsat *)
Inductive sdd_unsat : sdd -> Prop :=
| UnsatAtom : sdd_unsat (Atom AFalse)
| UnsatOrPrime : forall tl (prime sub : sdd),
    sdd_unsat prime ->
    sdd_unsat (Or tl) ->
    sdd_unsat (Or ((prime, sub)::tl))
| UnsatOrSub: forall tl (prime sub : sdd),
    sdd_unsat sub ->
    sdd_unsat (Or tl) ->
    sdd_unsat (Or ((prime, sub)::tl))
| UnsatEmptyOr :
    sdd_unsat (Or []).

Example sdd_unsat_ex0:
  sdd_unsat (Or [(Atom ATrue, Atom AFalse); (Atom (AVar 1 true), Atom AFalse)]).
Proof.
  apply UnsatOrSub.
  constructor.
  apply UnsatOrSub.
  constructor.
  constructor.
Qed.

(* idea: a true atom is sat, a var is sat,
   SAT /\ SAT is SAT, a single or-child must be sat for the
   OR to be sat *)
Inductive sdd_sat : sdd -> Prop :=
| SatAtom : sdd_sat (Atom ATrue)
| SatVar : forall n b, sdd_sat (Atom (AVar n b))
| SatOr : forall tl (prime sub : sdd),
    sdd_sat prime ->
    sdd_sat sub ->
    sdd_sat (Or ((prime, sub) :: tl))
| SatOrStep : forall tl (prime sub : sdd),
    sdd_sat (Or tl) ->
    sdd_sat (Or ((prime, sub) :: tl)).

Example sdd_sat_ex0 :
  sdd_sat (Or [(Atom ATrue, Atom AFalse); (Atom ATrue, Atom (AVar 1 true))]).
Proof.
  apply SatOrStep. constructor. constructor. constructor.
Qed.

Inductive atom_apply : op → atom → atom → atom → Prop :=
| AndTT : atom_apply OAnd ATrue ATrue ATrue
| AndTF : atom_apply OAnd ATrue AFalse AFalse
| AndFT : atom_apply OAnd AFalse ATrue AFalse
| AndFF : atom_apply OAnd AFalse AFalse AFalse
| AndVT : forall (n:nat) (b:bool), atom_apply OAnd (AVar n b) ATrue (AVar n b)
| AndTV : forall (n:nat) (b:bool), atom_apply OAnd ATrue (AVar n b) (AVar n b)
| AndVF : forall (n:nat) (b:bool), atom_apply OAnd (AVar n b) AFalse AFalse
| AndFV : forall (n:nat) (b:bool), atom_apply OAnd AFalse (AVar n b) AFalse
| AndVVEq : forall (n:nat) (b:bool), atom_apply OAnd (AVar n b) (AVar n b) (AVar n b)
| AndVVNeq : forall (n:nat) (b1:bool) (b2:bool), (b1 <> b2) → atom_apply OAnd (AVar n b1) (AVar n b2) (AFalse).

Inductive sdd_apply : op -> sdd -> sdd -> sdd -> Prop :=
| ApplyAtom : forall (a1:atom) (a2:atom) (a3:atom) (o:op),
    atom_apply o a1 a2 a3 → sdd_apply o (Atom a1) (Atom a2) (Atom a3)
| ApplyOr : forall (l1 l2 res: list (sdd*sdd)) (o : op),
    apply_or_list o l1 l2 res -> sdd_apply o (Or l1) (Or l2) (Or res)

with

(* an auxiliary inductive type to handle applying together two lists of primes and subs *)
apply_or_list : op -> list (sdd*sdd) -> list (sdd*sdd) -> list(sdd*sdd) -> Prop :=
| EmptyLeft : forall (l : list (sdd * sdd)) (o : op),
    apply_or_list o [] l []
| NonEmptyLeft : forall (prime sub : sdd) (ltail singleres orres linput : list (sdd * sdd)) (o : op),
    apply_single_list o prime sub linput singleres ->
    apply_or_list o ltail linput orres ->
    apply_or_list o ((prime, sub)::ltail) linput (singleres ++ orres)

with

(* an auxiliary inductive type to handle applying together a single prime and sub with a list of primes
   and subs *)
apply_single_list : op -> sdd -> sdd -> list (sdd * sdd) -> list (sdd * sdd) -> Prop :=
| EmptyRight : forall (prime sub : sdd) (o : op),
    apply_single_list o prime sub [] []
| NonEmptyRightSat : forall (prime1 prime2 sub1 sub2 newprime newsub : sdd) (o : op) (tl subres : list (sdd * sdd)),
    sdd_apply OAnd prime1 prime2 newprime ->
    sdd_sat newprime ->
    sdd_apply o sub1 sub2 newsub ->
    apply_single_list o prime1 sub1 tl subres -> (* process the rest of the list *)
    apply_single_list o prime1 sub1 ((prime2, sub2)::tl) ((newprime, newsub)::subres)
| NonEmptyRightUnsat : forall (prime1 prime2 newprime sub1 sub2: sdd) (o : op) (tl subres : list (sdd * sdd)),
    sdd_apply OAnd prime1 prime2 newprime ->
    sdd_unsat newprime ->
    apply_single_list o prime1 sub1 tl subres -> (* process the rest of the list *)
    apply_single_list o prime1 sub1 ((prime2, sub2)::tl) subres.

Check sdd_apply_ind.
Check apply_single_list_ind.
Check apply_or_list.

Print sdd_apply_ind.

Section sdd_apply_ind'.
  Variable P: op -> sdd -> sdd -> sdd → Prop.
  Variable Atom_case' : forall  (a1 a2 a3 :atom) (o : op),
      atom_apply o a1 a2 a3 -> P o (Atom a1) (Atom a2) (Atom a3).
  Hypothesis Apply_empty_list' : forall (o : op) (l : list (sdd * sdd)),
      P o (Or l) (Or [ ]) (Or [ ]).
  Hypothesis Apply_empty_l_list' : forall (o : op) (l : list (sdd * sdd)),
      P o (Or [ ]) (Or l) (Or [ ]).
  Hypothesis ApplySingleConcatenation: forall p1 p2 s1 s2 newprime newsub l lres o,
      sdd_apply OAnd p1 p2 newprime ->
      sdd_apply o s1 s2 newsub ->
      sdd_sat newprime ->
      P o (Or [(p1, s1)]) (Or [(p2, s2)]) (Or [(newprime, newsub)]) ->
      P o (Or [(p1, s1)]) (Or l) (Or lres) ->
      P o (Or [(p1, s1)]) (Or ((p2, s2) :: l)) (Or ((newprime, newsub) :: lres)).
  Hypothesis ApplyUnsatSingleConcatenation: forall p1 p2 s1 s2 newprime l lres o,
      sdd_apply OAnd p1 p2 newprime ->
      sdd_unsat newprime ->
      P o (Or [(p1, s1)]) (Or l) (Or lres) ->
      P o (Or [(p1, s1)]) (Or ((p2, s2) :: l)) (Or lres).
  Hypothesis ApplyConcat : forall l11 l12 l2 l11res l12res o,
      P o (Or l11) (Or l2) (Or l11res) ->
      P o (Or l12) (Or l2) (Or l12res) ->
      P o (Or (l11 ++ l12)) (Or l2) (Or (l11res ++ l12res)).
  Hypothesis ApplyCombine : forall o p1 p2 s1 s2 nprime nsub,
      sdd_apply OAnd p1 p2 nprime ->
      sdd_apply o s1 s2 nsub ->
      P OAnd p1 p2 nprime ->
      P o s1 s2 nsub ->
      P o (Or [(p1, s1)]) (Or [(p2, s2)]) (Or [(nprime, nsub)]).

  Fixpoint sdd_apply_ind' (o : op) (s1 s2 res :sdd) (d : sdd_apply o s1 s2 res): P o s1 s2 res :=
    match d in (sdd_apply o0 s3 s4 s5) return (P o0 s3 s4 s5) with
    | ApplyAtom a1 a2 a3 o d => Atom_case' a1 a2 a3 o d
    | ApplyOr l1 l2 res o or_d =>
      (* handle applying a (prime,sub) pair to a list *)
      (* handle non_empty_right derivations *)
      let handle_sub_l :=
          fix handle_sub_l (prime sub : sdd) (l res : list (sdd * sdd)) (o : op)
              (d : apply_single_list o prime sub l res) : P o (Or [(prime, sub)]) (Or l) (Or res) :=
            match d in (apply_single_list o prime sub l res) return P o (Or [(prime, sub)]) (Or l) (Or res) with
            | EmptyRight p s o =>
              Apply_empty_list' o [(p, s)]
            | NonEmptyRightSat p1 p2 s1 s2 nprime nsub o1 tl subres app_prime_d sat_d app_sub_d rest_d =>
              let sub_proof := handle_sub_l p1 s1 tl subres o1 rest_d in
              let prime_holds := sdd_apply_ind' OAnd p1 p2 nprime app_prime_d in
              let sub_holds := sdd_apply_ind' o1 s1 s2 nsub app_sub_d in
              let combined := ApplyCombine o1 p1 p2 s1 s2 nprime nsub app_prime_d app_sub_d prime_holds sub_holds in
              ApplySingleConcatenation p1 p2 s1 s2 nprime nsub tl subres o1
                                        app_prime_d app_sub_d sat_d combined sub_proof
            | NonEmptyRightUnsat prime1 prime2 newprime sub1 sub2 o tl subres app_prime_d unsat_d rest_d =>
              let sub_proof := handle_sub_l prime1 sub1 tl subres o rest_d in
              ApplyUnsatSingleConcatenation prime1 prime2 sub1 sub2 newprime tl subres o app_prime_d unsat_d sub_proof
            end in
              (* handle non_empty_left derivations *)
      let handle_l :=
          fix handle_l o l1 l2 res (cur_d : apply_or_list o l1 l2 res) : P o (Or l1) (Or l2) (Or res) :=
            match cur_d in (apply_or_list o l1 l2 res) return (P o (Or l1) (Or l2) (Or res)) with
            | EmptyLeft l o1  => Apply_empty_l_list' o1 l
            | NonEmptyLeft prime sub ltail singleres orres linput o1 single_d sub_or_d =>
              let single_proof := handle_sub_l prime sub linput singleres o1 single_d in
              let or_proof := handle_l o1 ltail linput orres sub_or_d in
              ApplyConcat [(prime, sub)] ltail linput singleres orres o1 single_proof or_proof

            end in
              handle_l o l1 l2 res or_d
    end.
End sdd_apply_ind'.

Print sdd_apply_ind.

(*
Section sdd_apply_ind_vtree.
  Variable Atom_case' : forall  (a1 a2 a3 :atom) (o : op),
      atom_apply o a1 a2 a3 -> sdd_vtree (Atom a1) v -> sdd_vtree (Atom a2) v -> sdd_vtree (Atom a3) v.
  Hypothesis Apply_empty_list' : forall (o : op) (l : list (sdd * sdd)),
      sdd_vtree (Or l) v -> sdd_vtree (Or []) v o (Or l) (Or [ ]) (Or [ ]).
  Hypothesis Apply_empty_l_list' : forall (o : op) (l : list (sdd * sdd)),
      P o (Or [ ]) (Or l) (Or [ ]).
  Hypothesis ApplySingleConcatenation: forall p1 p2 s1 s2 newprime newsub l lres o,
      sdd_apply OAnd p1 p2 newprime ->
      sdd_apply o s1 s2 newsub ->
      sdd_sat newprime ->
      P o (Or [(p1, s1)]) (Or [(p2, s2)]) (Or [(newprime, newsub)]) ->
      P o (Or [(p1, s1)]) (Or l) (Or lres) ->
      P o (Or [(p1, s1)]) (Or ((p2, s2) :: l)) (Or ((newprime, newsub) :: lres)).
  Hypothesis ApplyUnsatSingleConcatenation: forall p1 p2 s1 s2 newprime l lres o,
      sdd_apply OAnd p1 p2 newprime ->
      sdd_unsat newprime ->
      P o (Or [(p1, s1)]) (Or l) (Or lres) ->
      P o (Or [(p1, s1)]) (Or ((p2, s2) :: l)) (Or lres).
  Hypothesis ApplyConcat : forall l11 l12 l2 l11res l12res o,
      P o (Or l11) (Or l2) (Or l11res) ->
      P o (Or l12) (Or l2) (Or l12res) ->
      P o (Or (l11 ++ l12)) (Or l2) (Or (l11res ++ l12res)).
  Hypothesis ApplyCombine : forall o p1 p2 s1 s2 nprime nsub,
      sdd_apply OAnd p1 p2 nprime ->
      sdd_apply o s1 s2 nsub ->
      P OAnd p1 p2 nprime ->
      P o s1 s2 nsub ->
      P o (Or [(p1, s1)]) (Or [(p2, s2)]) (Or [(nprime, nsub)]).

  Fixpoint sdd_apply_ind' (o : op) (s1 s2 res :sdd) (d : sdd_apply o s1 s2 res): P o s1 s2 res :=
    match d in (sdd_apply o0 s3 s4 s5) return (P o0 s3 s4 s5) with
    | ApplyAtom a1 a2 a3 o d => Atom_case' a1 a2 a3 o d
    | ApplyOr l1 l2 res o or_d =>
      (* handle applying a (prime,sub) pair to a list *)
      (* handle non_empty_right derivations *)
      let handle_sub_l :=
          fix handle_sub_l (prime sub : sdd) (l res : list (sdd * sdd)) (o : op)
              (d : apply_single_list o prime sub l res) : P o (Or [(prime, sub)]) (Or l) (Or res) :=
            match d in (apply_single_list o prime sub l res) return P o (Or [(prime, sub)]) (Or l) (Or res) with
            | EmptyRight p s o =>
              Apply_empty_list' o [(p, s)]
            | NonEmptyRightSat p1 p2 s1 s2 nprime nsub o1 tl subres app_prime_d sat_d app_sub_d rest_d =>
              let sub_proof := handle_sub_l p1 s1 tl subres o1 rest_d in
              let prime_holds := sdd_apply_ind' OAnd p1 p2 nprime app_prime_d in
              let sub_holds := sdd_apply_ind' o1 s1 s2 nsub app_sub_d in
              let combined := ApplyCombine o1 p1 p2 s1 s2 nprime nsub app_prime_d app_sub_d prime_holds sub_holds in
              ApplySingleConcatenation p1 p2 s1 s2 nprime nsub tl subres o1
                                        app_prime_d app_sub_d sat_d combined sub_proof
            | NonEmptyRightUnsat prime1 prime2 newprime sub1 sub2 o tl subres app_prime_d unsat_d rest_d =>
              let sub_proof := handle_sub_l prime1 sub1 tl subres o rest_d in
              ApplyUnsatSingleConcatenation prime1 prime2 sub1 sub2 newprime tl subres o app_prime_d unsat_d sub_proof
            end in
              (* handle non_empty_left derivations *)
      let handle_l :=
          fix handle_l o l1 l2 res (cur_d : apply_or_list o l1 l2 res) : P o (Or l1) (Or l2) (Or res) :=
            match cur_d in (apply_or_list o l1 l2 res) return (P o (Or l1) (Or l2) (Or res)) with
            | EmptyLeft l o1  => Apply_empty_l_list' o1 l
            | NonEmptyLeft prime sub ltail singleres orres linput o1 single_d sub_or_d =>
              let single_proof := handle_sub_l prime sub linput singleres o1 single_d in
              let or_proof := handle_l o1 ltail linput orres sub_or_d in
              ApplyConcat [(prime, sub)] ltail linput singleres orres o1 single_proof or_proof

            end in
              handle_l o l1 l2 res or_d
    end.
End sdd_apply_ind'.
*)

Inductive sdd_vtree : sdd -> vtree -> Prop :=
| AtomTrue : forall n, sdd_vtree (Atom ATrue) (VAtom n)
| AtomFalse : forall n, sdd_vtree (Atom AFalse) (VAtom n)
| AtomVar : forall n b, sdd_vtree (Atom (AVar n b)) (VAtom n)
| OrEmpty : forall v, sdd_vtree (Or []) v
| OrSingle: forall prime sub lvtree rvtree tail,
    sdd_vtree prime lvtree ->
    sdd_vtree sub rvtree ->
    sdd_vtree (Or (tail)) (VNode lvtree rvtree) ->
    sdd_vtree (Or ((prime, sub) :: tail)) (VNode lvtree rvtree)
| ExtendL : forall l r sdd,
    sdd_vtree sdd l ->
    sdd_vtree sdd (VNode l r)
| ExtendR : forall l r sdd,
    sdd_vtree sdd r ->
    sdd_vtree sdd (VNode l r).

Section sdd_vtree_ind'.
  Variable P: sdd -> vtree -> Prop.

  Hypothesis AtomTrue'  : forall n  , P (Atom ATrue)      (VAtom n).
  Hypothesis AtomFalse' : forall n  , P (Atom AFalse)      (VAtom n).
  Hypothesis AtomVar'   : forall n b, P (Atom (AVar n b)) (VAtom n).

  Hypothesis OrEmpty'   : forall v, P (Or []) v.
  Hypothesis OrSingle'  : forall prime sub tail lvtree rvtree,
    P prime lvtree ->
    P sub rvtree ->
    P (Or (tail)) (VNode lvtree rvtree) ->
    P (Or ((prime, sub)::tail)) (VNode lvtree rvtree).

  Hypothesis ExtendL'   : forall l r sdd, P sdd l -> P sdd (VNode l r).
  Hypothesis ExtendR'   : forall l r sdd, P sdd r -> P sdd (VNode l r).

  Fixpoint sdd_vtree_ind' (s:sdd) (v:vtree) (d: sdd_vtree s v): P s v :=
    match d in (sdd_vtree s1 v1) return (P s1 v1) with
    | AtomTrue  n   => AtomTrue'  n
    | AtomFalse n   => AtomFalse' n
    | AtomVar   n b => AtomVar'   n b

    | OrEmpty   v                    => OrEmpty'   v
    | OrSingle  p s lv rv r pd sd rd => OrSingle' p s r lv rv
                                            (sdd_vtree_ind' p lv pd)
                                            (sdd_vtree_ind' s rv sd)
                                            (sdd_vtree_ind' (Or r) (VNode lv rv) rd)

    | ExtendL l r sdd ld => ExtendL' l r sdd (sdd_vtree_ind' sdd l ld)
    | ExtendR l r sdd rd => ExtendR' l r sdd (sdd_vtree_ind' sdd r rd)
  end.

End sdd_vtree_ind'.

Lemma single_vtree :
  forall (prime sub : sdd) l v,
    sdd_vtree (Or [(prime, sub)]) v ->
    sdd_vtree (Or l) v ->
    sdd_vtree (Or ((prime, sub) :: l)) v.
Proof.
  intros.
  induction l.
  - assumption.
  - inversion H. subst. inversion H0. subst.
    apply OrSingle.
    + assumption.
    + assumption.
    + assumption.
    +  admit.
Admitted.

Lemma vtree_concat :
  forall l1 l2 v,
    sdd_vtree (Or l1) v ->
    sdd_vtree (Or l2) v ->
    sdd_vtree (Or (l1 ++ l2)) v.
Proof.
  intros. induction l1.
  - simpl. assumption.
  - destruct a. remember (l1 ++ l2) as l. simpl. rewrite <- Heql. apply single_vtree.
    + inversion H. subst. constructor. assumption. assumption. constructor.
    (* + apply IHl1. inversion H. subst. assumption. admit. *)
Admitted.

Lemma vtree_slice_l :
  forall l1 l2 v,
    sdd_vtree (Or (l1 ++ l2)) v ->
    sdd_vtree (Or l1) v.
Proof.
  intros. induction l1.
  - constructor. Admitted.
(*  - inversion H. subst.
    apply single_vtree.
    + constructor. assumption. assumption.
      constructor.
    + apply IHl1. inversion H.
      subst. assumption.
Admitted. *)

Lemma vtree_reorder :
  forall l1 l2 v,
    sdd_vtree (Or (l1 ++ l2)) v ->
    sdd_vtree (Or (l2 ++ l1)) v.
Proof.
  intros. induction l1.
  - simpl in H. remember (l2 ++ []) as l3. remember (l2 ++ []) as l4.  admit.
Admitted.

Lemma vtree_slice_r :
  forall l1 l2 v,
    sdd_vtree (Or (l1 ++ l2)) v ->
    sdd_vtree (Or l2) v.
Proof.
  intros. induction l2.
  - constructor. Admitted. (*
  - destruct a. apply single_vtree.
    + inversion H.
      * symmetry in H1. apply app_eq_nil in H1. inversion H1. inversion H3.
      * induction l1.
        { simpl in H0. admit. }
        { apply IHl1.
          - inversion H.  subst.

Admitted.*)

Lemma unsat_concat :
  forall prime sub l,
    sdd_unsat (Or [(prime, sub)]) ->
    sdd_unsat (Or l) ->
    sdd_unsat (Or ((prime, sub) :: l)).
Proof.
  intros.
  inversion H.
  - subst. constructor.
    + assumption.
    + assumption.
  - subst. apply UnsatOrSub.
    + assumption.
    + assumption.
Qed.

Lemma unsat_append :
  forall l1 l2,
    sdd_unsat (Or l1) ->
    sdd_unsat (Or l2) ->
    sdd_unsat (Or (l1 ++ l2)).
Proof.
  intros.
  induction l1.
  - simpl. assumption.
  - simpl. destruct a.
    remember (l1 ++ l2) as l. apply unsat_concat.
    + inversion H. subst. constructor.
      * assumption.
      * constructor.
      * apply UnsatOrSub.
        { assumption. }
        { constructor. }
    + apply IHl1.
      * inversion H. assumption. assumption.
Qed.

Lemma unsat_split_l :
  forall l1 l2,
    sdd_unsat (Or (l1 ++ l2)) ->
    sdd_unsat (Or l1).
Proof.
  intros. induction l1.
  - constructor.
  - destruct a. apply unsat_concat.
    + inversion H. subst. constructor.
      * assumption.
      * constructor.
      * apply UnsatOrSub.
        { assumption. }
        { constructor. }
    + apply IHl1.
      * inversion H.
        { assumption. }
        { assumption. }
Qed.

Lemma unsat_app_nil:
  forall l,
    sdd_unsat (Or (l ++ [])) ->
    sdd_unsat (Or l).
Proof.
  intros.
  induction l.
  - constructor.
  - inversion H.
    + subst. constructor.
      * assumption.
      * apply IHl.
        { assumption. }
    + subst. apply UnsatOrSub.
      * assumption.
      * apply IHl.
        { assumption. }
Qed.

Lemma unsat_split_r:
  forall l1 l2,
    sdd_unsat (Or (l1 ++ l2)) ->
    sdd_unsat (Or (l2)).
Proof.
  intros.
  induction l1, l2.
  - constructor.
  - simpl in H. assumption.
  - constructor.
  - apply IHl1.
    + inversion H.
      * subst.  assumption.
      * subst.  assumption.
Qed.

Theorem apply_unsat :
  forall sdd1 sdd2 sddres,
    sdd_unsat sdd1 ->
    sdd_apply OAnd sdd1 sdd2 sddres ->
    sdd_unsat sddres.
Proof.
  intros. induction H0 using sdd_apply_ind'.
  - inversion H0;
      try (inversion H; subst; inversion H);
      try (subst; inversion H);
      try (subst; constructor);
      try (subst; assumption).
  - constructor.
  - constructor.
  - subst. apply unsat_concat.
    + apply IHsdd_apply1. assumption.
    + apply IHsdd_apply2. assumption.
  - apply IHsdd_apply. assumption.
  - apply unsat_append.
    + apply IHsdd_apply. apply (unsat_split_l l11 l12). assumption.
    + apply IHsdd_apply0. apply (unsat_split_r l11 l12). assumption.
  - inversion H. subst. constructor.
    + apply IHsdd_apply1. assumption.
    + assumption.
    + apply UnsatOrSub;
        try apply IHsdd_apply2;
        assumption.
Qed.

Inductive

decomposable : sdd -> Prop :=
| decomposable_atom : forall a, decomposable (Atom a)
| decomposable_or : forall l, decomposable_pairs l -> decomposable (Or l)

with

decomposable_pairs : list (sdd*sdd) -> Prop :=
| decomposable_pairs_empty : decomposable_pairs []
| decomposable_pairs_pair_sdd  : forall p s rest pVs sVs, sdd_varSet p pVs ->
                                                      sdd_varSet s sVs ->
                                                      disjoint pVs sVs ->
                                                      decomposable_pairs rest ->
                                                      decomposable_pairs ((p, s)::rest).

Lemma allPairs_subset :
  forall v tail rVs vs1,
      AllPairs sdd
          (λ sdd0 : sdd,
           ∀ (v : vtree) (vs1 vs2 : varSet),
             sdd_vtree sdd0 v → vtree_varSet v vs1 → sdd_varSet sdd0 vs2 → subset vs2 vs1) tail ->
      sdd_vtree (Or tail) v   ->
      vtree_varSet v vs1      ->
      sddList_varSet tail rVs ->
      subset rVs vs1.
  induction tail; intros.
  - inversion H2. constructor.
  - Admitted.

Theorem sdd_vtree_vars :
  forall sdd v vs1 vs2,
    sdd_vtree sdd v ->
    vtree_varSet v vs1 ->
    sdd_varSet sdd vs2 ->
    subset vs2 vs1.
Proof.
  intros sdd0 v vs1 vs2 HsddVtree.
  generalize dependent vs1.
  generalize dependent vs2.
  induction HsddVtree using sdd_vtree_ind'; intros vs1 vs2 Hvtree Hsdd.
  - inversion Hvtree. inversion Hsdd. inversion H2. subst. constructor.
  - inversion Hvtree. inversion Hsdd. inversion H2. subst. constructor.
  - inversion Hvtree. inversion Hsdd. inversion H2. subst. repeat constructor.
  - induction Hvtree; inversion Hsdd; subst.
    + inversion H0. constructor.
    + apply union_implies_subset in H.
      apply (subset_transitivity vs1 lSet resSet); assumption.
  - inversion Hvtree. inversion Hsdd. inversion H6. subst.
    apply (IHHsddVtree pVs) in H1.
    apply (IHHsddVtree0 sVs) in H2.
    apply (sdd_varSet_or) in H13.
    apply (IHHsddVtree1 rVs vs2) in H13.
    apply (subsets_union pVs sVs pairVs lSet rSet vs2) in H4.
    assert (union vs2 vs2 vs2). apply self_union.
    apply (subsets_union pairVs rVs vs1 vs2 vs2 vs2).
    assumption. assumption. assumption. assumption. assumption. assumption.
    assumption. assumption. assumption. assumption.
  - inversion Hvtree. subst.
    apply (IHHsddVtree vs1) in H1.
    apply (union_implies_subset) in H4.
    apply (subset_transitivity vs1 lSet vs2).
    assumption. assumption. assumption.
  - inversion Hvtree. subst.
    apply (IHHsddVtree vs1) in H2.
    apply (union_symmetry) in H4. apply (union_implies_subset) in H4.
    apply (subset_transitivity vs1 rSet vs2).
    assumption. assumption. assumption.
Qed.

Theorem sdd_has_varSet :
  forall sdd, exists vs, sdd_varSet sdd vs.
Proof.
  induction sdd0 using sdd_ind'.
  - induction l.
    + eapply ex_intro. instantiate (1 := Empty). repeat constructor.
    + destruct a as [p s]. simpl in H. destruct H. destruct H0. apply IHl in H1.
      destruct H. destruct H0. destruct H1.
      assert (exists x2, union x x0 x2). apply exists_union. destruct H2.
      assert (exists x3, union x1 x2 x3). apply exists_union. destruct H3.
      eapply ex_intro.
      instantiate (1 := x3).
      repeat constructor. eapply sddList_varSet_pair.
      * instantiate (1 := x). assumption.
      * instantiate (1 := x0). assumption.
      * instantiate (1 := x1). inversion H1. assumption.
      * instantiate (1 := x2). assumption.
      * apply union_symmetry in H3. assumption.
  - destruct a; eapply ex_intro.
    + instantiate (1 := Empty). repeat constructor.
    + instantiate (1 := Empty). repeat constructor.
    + instantiate (1 := (Var n Empty)). constructor. constructor.
Qed.

Theorem sdd_decomposable :
  forall sdd v,
    sdd_vtree sdd v ->
    vtree_correct v ->
    decomposable sdd.
Proof.
  intros sdd0 v Hsdd0 Hv.
  induction Hsdd0;
    repeat constructor.
  - inversion Hv. subst.
    apply IHHsdd0_1 in H1.
    apply IHHsdd0_2 in H2.
    apply IHHsdd0_3 in Hv.
    inversion Hv. subst.
    assert (exists vs, sdd_varSet prime vs). apply (sdd_has_varSet prime).
    destruct H as [pVs H].
    assert (exists vs, sdd_varSet sub vs). apply (sdd_has_varSet sub).
    destruct H6 as [sVs H6].
    eapply (decomposable_pairs_pair_sdd).
    + instantiate (1 := pVs). assumption.
    + instantiate (1 := sVs). assumption.
    + apply (subsets_disjoint pVs sVs lSet rSet).
      * apply (sdd_vtree_vars prime lvtree lSet pVs); assumption.
      * apply (sdd_vtree_vars sub rvtree rSet sVs); assumption.
      * assumption.
    + assumption.
  - inversion Hv. subst. apply IHHsdd0. assumption.
  - inversion Hv. subst. apply IHHsdd0. assumption.
Qed.

(* ---------------------------- *)
Example sdd_vtree_ex0:
  sdd_vtree (Or [(Atom (AVar 0 true), Atom (AVar 1 false))]) (VNode (VAtom 0) (VAtom 1)).
Proof.
  constructor.
  - constructor.
  - constructor.
  - constructor.
Qed.

(* an interesting theorem: all valid SDDs are either SAT or UNSAT. *)
Theorem sdd_sat_or_unsat :
  forall (sdd : sdd) vtree,
    sdd_vtree sdd vtree ->
    sdd_unsat sdd \/ sdd_sat sdd.
Proof.
Admitted.

Inductive expanded_sdd : vtree -> atom -> sdd -> Prop :=
| ExpandAtomT : forall n, expanded_sdd (VAtom n) ATrue (Atom ATrue)
| ExpandAtomF : forall n, expanded_sdd (VAtom n) AFalse (Atom AFalse)
| ExpandFalseNode : forall lvtree rvtree lsdd rsdd,
    expanded_sdd lvtree ATrue lsdd ->
    expanded_sdd rvtree AFalse rsdd ->
    expanded_sdd (VNode lvtree rvtree) AFalse (Or [(lsdd, rsdd)])
| ExpandTrueNode : forall lvtree rvtree lsdd rsdd,
    expanded_sdd lvtree ATrue lsdd ->
    expanded_sdd rvtree ATrue lsdd ->
    expanded_sdd (VNode lvtree rvtree) ATrue (Or [(lsdd, rsdd)]).

(* need to handle cases when the derived primes are sat/unsat, otherwise
   you get false primes in the generated SDD *)
Inductive sdd_of_var : nat -> vtree -> bool -> sdd -> Prop :=
| VarOfLeafMatchT : forall n b, sdd_of_var n (VAtom n) b (Atom (AVar n b))
| VarOfLeafNonmatchT : forall n1 n2 b,
    n1 <> n2 ->
    sdd_of_var n1 (VAtom n2) b (Atom ATrue)
| VarOfLeafNonmatchF : forall n1 n2 b,
    n1 <> n2 ->
    sdd_of_var n1 (VAtom n2) b (Atom AFalse)
| VarOfNode : forall n b lvtree rvtree lsdd_t rsdd_t lsdd_f false_expanded,
    sdd_of_var n lvtree b lsdd_t ->
    sdd_of_var n lvtree (negb b) lsdd_f ->
    sdd_of_var n rvtree b rsdd_t ->
    expanded_sdd rvtree AFalse false_expanded ->
    sdd_of_var n (VNode lvtree rvtree) b
               (Or [(lsdd_t, rsdd_t); (lsdd_f, false_expanded)]).

(*
The generated term containing the unsat branch:
(Or
 (((Atom True)
   (Or
    (((Atom (Var 1 true)) (Atom True)) ((Atom (Var 1 false)) (Atom False)))))
  ((Atom True) (Or (((Atom True) (Atom False)))))))
*)
Example sdd_of_var_ex0:
  sdd_of_var 2 (VNode (VAtom 1) (VNode (VAtom 2) (VAtom 3))) true
             (Or [(Atom ATrue,
                   (Or [(Atom (AVar 2 true), (Atom ATrue));
                          (Atom (AVar 2 false), Atom AFalse)]));
                    (Atom ATrue, Or ([(Atom ATrue, Atom AFalse)]))]).
Proof.
  (* coming up with this term SUCKS... *)
  eapply (VarOfNode 2 true (VAtom 1)
                    (VNode (VAtom 2) (VAtom 3))
                    (Atom ATrue)
                    (Or [(Atom (AVar 2 true), Atom ATrue); (Atom (AVar 2 false), Atom AFalse)])
                    (Atom ATrue)
                    (Or ([(Atom ATrue, Atom AFalse)]))
         ).
  - constructor. discriminate.
  - constructor. discriminate.
  - constructor. constructor.
    + constructor.
    + constructor. discriminate.
    + constructor.
  - apply ExpandFalseNode.
    + constructor.
    + constructor.
Qed.

Example ex_sdd_apply0:
  sdd_apply OAnd (Or [(Atom ATrue, Atom AFalse)]) (Or [(Atom ATrue, Atom AFalse)]) (Or [(Atom ATrue, Atom AFalse)]).
Proof.
  apply ApplyOr.
  apply (NonEmptyLeft (Atom ATrue) (Atom AFalse) [] [(Atom ATrue, Atom AFalse)] _ _ OAnd).
  repeat constructor.
  - constructor.
Qed.

Example ex_sdd_apply1:
  sdd_apply OAnd (Atom ATrue) (Atom AFalse) (Atom AFalse).
Proof.
  apply ApplyAtom. constructor.
  Qed.

(*Example ex_sdd_apply2:
  sdd_apply OAnd (Or [(Atom (AVar 0 true), Atom (AVar 1 true)); (Atom (AVar 0 false), Atom(AFalse))])
            (Or [(Atom (AVar 0 true), Atom (AVar 1 true)); (Atom (AVar 0 false), Atom(AFalse))])
            (Or [(Atom (AVar 0 true), Atom (AVar 1 true)); (Atom (AVar 0 false), Atom(AFalse))]).
Proof.
  constructor.
  - apply (NonEmptyLeft (Atom (AVar 0 true)) (Atom (AVar 1 true)) [(Atom (AVar 0 false), Atom AFalse)]
                        [(Atom (AVar 0 true), Atom (AVar 1 true))]).
    + constructor.
      * constructor. constructor.
      * constructor.
      * constructor. constructor.
      * constructor.
        { constructor. constructor. discriminate. }
        { constructor. }
    + apply (NonEmptyLeft (Atom (AVar 0 false)) (Atom AFalse) [] [(Atom (AVar 0 false), Atom AFalse)]).
      * apply NonEmptyRightUnsat.
        { constructor. constructor. discriminate. }
        { constructor. constructor. constructor. constructor. constructor. constructor.  constructor. }
      * constructor.
Qed.*)

Example sdd_and_eq:
  forall  (v : vtree) (a : sdd),
    sdd_vtree a v ->
    sdd_apply OAnd a a a.
Proof.
  intros.
  destruct a.
  induction H.
  -  constructor. constructor.
  -  constructor. constructor.
  -  constructor. constructor.
  -  constructor.
     *  constructor.
  - constructor.
    eapply (NonEmptyLeft prime sub tail [(prime, sub)] tail ((prime, sub) :: tail)).
    * (*apply NonEmptyRightUnsat.*)
      { Admitted. (*assumption. }
      { discriminate. }*)

(* Apply preserves vtree consistency
  forall v sdd1 sdd2 sddRes, sdd_vtree sdd1 v → sdd_vtree sdd2 v → sdd_apply OAnd sdd1 sdd2 sddRes → sdd_vtree sddRes v.
*)

Inductive orList : list bool -> bool -> Prop :=
| OrListEmpty    : orList [] false
| OrListNonEmpty : forall b bs rest, orList bs rest -> orList (b::bs) (orb b rest).

Inductive sdd_eval : sdd -> bool → varAssign → Prop :=
| SDDEvalATrue    : forall va, sdd_eval (Atom ATrue) true va
| SDDEvalAFalse   : forall va, sdd_eval (Atom AFalse) false va
| SDDEvalAVarSame : forall va n res, assigns va n res → sdd_eval (Atom (AVar n true)) res va
| SDDEvalAVarDiff : forall va n res, assigns va n res → sdd_eval (Atom (AVar n false)) (negb res) va
| SDDEvalOr       : forall va pairs disjuncts res, sdd_eval_orList pairs disjuncts va ->
                                               orList disjuncts res ->
                                               sdd_eval (Or pairs) res va

with

sdd_eval_orList : list (sdd*sdd) → list bool → varAssign → Prop :=
| SDDEvalEmpty    : forall va, sdd_eval_orList [] [] va
| SDDEvalNonEmpty : forall va prime sub tail pRes sRes tailRes,
    sdd_eval prime pRes va →
    sdd_eval sub sRes va →
    sdd_eval_orList tail tailRes va →
    sdd_eval_orList ((prime, sub)::tail) ((andb pRes sRes)::tailRes) va.

Example sdd_eval_1_true :
  sdd_eval (Or [((Atom (AVar 1 true)), (Atom ATrue))]) true (VA_Var 1 true VA_Empty).
Proof.
  eapply SDDEvalOr.
  - apply SDDEvalNonEmpty.
    * apply SDDEvalAVarSame. constructor.
    * apply SDDEvalATrue.
    * apply SDDEvalEmpty.
  - simpl. eapply (OrListNonEmpty true []). apply OrListEmpty.
Qed.

(* Inductive compile *)

Ltac rewAndInvert :=
  match goal with
  | [ H1: _ = ?x, H2: _ = ?x |- _ ] =>
      rewrite <- H2 in H1; inversion H1
  end.

Lemma single_list_right_empty :
  forall o prime sub res, apply_single_list o prime sub [ ] res → res = [].
Proof.
  intros.  inversion H. reflexivity.
Qed.

Lemma or_list_right_empty :
  forall o l res, apply_or_list o l [] res → res = [].
Proof.
  intros. generalize dependent res. induction l.
  * intros. inversion H. reflexivity.
  * intros. inversion H. apply IHl in H6.
    apply single_list_right_empty in H3.
    rewrite H3. rewrite H6. reflexivity.
Qed.

Section All.
  Variable T : Set.
  Variable P : T -> Prop.

  Fixpoint All (ls : list T) : Prop :=
    match ls with
      | [] => True
      | h::t => P h /\ All t
    end.
End All.

Lemma or_append_vtree :
  forall subres orres v,
    sdd_vtree (Or subres) v ->
    sdd_vtree (Or orres) v ->
    sdd_vtree (Or (subres ++ orres)) v.
Proof.
  Admitted.

Lemma append_list_vtree :
  forall vl vr p s l,
    sdd_vtree p vl ->
    sdd_vtree s vr ->
    sdd_vtree (Or l) (VNode vl vr) ->
    sdd_vtree (Or ((p, s)::l)) (VNode vl vr).
Admitted.

(* apply_single_list o p1 s1 l0 subres *)
Lemma single_list_vtree :
  forall lvtree rvtree p s l o subres,
    sdd_vtree p lvtree ->
    sdd_vtree s rvtree ->
    sdd_vtree (Or l) (VNode lvtree rvtree) ->
    apply_single_list o p s l subres ->
    sdd_vtree (Or subres) (VNode lvtree rvtree).
Proof.
  Admitted.
(*   induction l. generalize dependent s. generalize dependent p. *)
(*   - intros. inversion H2. constructor. *)
(*   - generalize dependent p. generalize dependent s. *)
(*     intros.  apply (Hvl op l). *)
(*     + intros. apply (IHl o ); repeat assumption. *)
(* Admitted. *)

Lemma concat_list_vtree :
  forall vl vr l1 l2,
    sdd_vtree (Or l1) (VNode vl vr) ->
    sdd_vtree (Or l2) (VNode vl vr) ->
    sdd_vtree (Or (l1 ++ l2)) (VNode vl vr).
Admitted.

(* apply_or_list o l ((p2, s2) :: l0) orres *)
(* sdd_vtree (Or orres) (VNode lvtree0 rvtree0) *)
Lemma or_list_vtree :
  forall lvtree rvtree l l0 res o,
    sdd_vtree (Or l) (VNode lvtree rvtree) ->
    sdd_vtree (Or l0) (VNode lvtree rvtree) ->
    apply_or_list o l l0 res ->
    sdd_vtree (Or res) (VNode lvtree rvtree).
Proof.
  induction l.
  - intros. inversion H1. constructor.
  - intros. inversion H1. subst.
    + apply concat_list_vtree.
      * apply (single_list_vtree lvtree rvtree prime sub l0 o singleres); repeat (inversion H; assumption). Admitted.
(*      * apply (IHl l0 orres o); repeat (inversion H; assumption).
Qed.

Theorem apply_preserves_vtree :
  forall sdd1 sdd2 sddRes v o,
    sdd_vtree sdd1 v →
    sdd_vtree sdd2 v →
    sdd_apply o sdd1 sdd2 sddRes →
    sdd_vtree sddRes v.
Proof.
  destruct v.
  - intros. inversion H. subst.
    + inversion H0.
      * subst. inversion H1.
        { subst. inversion H5. constructor. }
      * subst. inversion H1.
        { subst. inversion H8.
          - subst.  constructor.
        }
    + subst. inversion H1. subst.
      assert (sdd_vtree (Or ((prime, sub) :: tail)) (VNode v1 v2)).
      { apply (append_list_vtree v1 v2 prime sub tail); repeat assumption. }
      remember ((prime, sub) :: tail) as l.
      eapply (or_list_vtree v1 v2 l l2 res o); repeat assumption.
  - intros. inversion H.
    + inversion H1.
      * subst. inversion H3; repeat (subst; constructor).
        { subst. discriminate H6. }
        { subst. inversion H0. subst. constructor. }
        { subst. discriminate H6. }
      * subst. inversion H0. subst.  discriminate H6.
    + subst. inversion H1. inversion H4.
      * constructor.
      * constructor.
      * constructor.
    + subst. inversion H0.
      * inversion H1. subst. inversion H6; repeat constructor.
      * subst. inversion H1. inversion H5. constructor.
      * subst. destruct b.
        { destruct b0; repeat (inversion H1; inversion H5; constructor). }
        { destruct b0; repeat (inversion H1; inversion H5; constructor). }
      * subst. inversion H1.
    + subst. inversion H. inversion H1. inversion H5. constructor.
Qed.*)

(* Theorem compile_correct : *)
(*   forall (boolExp:boolExpr) (sdd:sdd) (input:varAssign) (result:bool), *)
(*     compile boolExp sdd → *)
(*     eval_sdd sdd result input → *)
(*     eval boolExp result input. *)


Require Import A1_Plan A2_Orientation .
Require Import B7_Tactics .
Require Import C1_Distance C6_DistanceTimesN C7_Tactics .
Require Import D4_DistanceLt .
Require Import F3_Graduation F4_ArchimedianDistance F5_Tactics .
Require Import G1_Angles .
Require Import H1_Triangles .
Require Import I2_Supplement .
Require Import L2_StrictParallelogramm L6_Tactics .
Require Import M5_Tactics.

Section DISCRETE_THALES.

Lemma DThales : forall (A B C : Point) (Hab : A <> B) (Hac : A <> C) (Habc : Clockwise A B C) (n : nat),
	n > 0 ->
	Clockwise A (Graduation n A B Hab) (Graduation n A C Hac) /\
	CongruentAngle A B C A (Graduation n A B Hab) (Graduation n A C Hac) /\
	CongruentAngle A C B A (Graduation n A C Hac) (Graduation n A B Hab)  /\
	Distance (Graduation n A B Hab) (Graduation n A C Hac) = DistanceTimes n B C.
Proof.
	intros.
	induction H.

	 repeat rewrite Graduation1; simpl in |- *; repeat split; immediate12.

	 setGraduationPoint5 m A B ipattern:(Bm); fold Bm in IHle.
	   setGraduationPoint5 m A C ipattern:(Cm); fold Cm in IHle.
	   decompose [and] IHle; clear IHle.
	   setGraduationPoint5 (S m) A B ipattern:(Bsm); fold Bsm in |- *.
	   setGraduationPoint5 (S m) A C ipattern:(Csm); fold Csm in |- *.
	   since12 (Between A Bm Bsm).
	  unfold Bm, Bsm in |- *; apply GraduationBetweenAnSn; immediate12.
	  from12 H12 (Clockwise Cm Bm Bsm).
	    setStrictParallelogramm11 Cm Bm Bsm ipattern:(D).
	    DestructSP11 H14.
	    from12 H15 (CongruentAngle D Bsm Bm Cm Bm A).
	    from12 2 (TCongruent (Tr A B C) (Tr Cm D Csm)).
	   unfold Cm, Csm in |- *; immediate12.
	   as12 (Distance Cm D = Distance Bm Bsm).
	     unfold Bm, Bsm in |- *; immediate12.
	   since12 (Between A Cm Csm).
	    unfold Cm, Csm in |- *; apply GraduationBetweenAnSn; immediate12.
	    as12 (Supplement Csm Cm D D Cm A).
	     immediate12.
	     apply SupplementRev1; apply SupplementRev2; apply SupplementSym; apply (TriangleSumSupplement C B A Cm A Bm D).
	      step12 H0.
	        step12 H2.
	      immediate12.
	      immediate12.
	      step12 H6.
	        step12 H15.
	   since12 (Clockwise Cm D Csm).
	    apply (TriangleSumClockwise C B A Cm A Bm D Csm).
	     immediate12.
	     immediate12.
	     immediate12.
	     step12 H6.
	       step12 H15.
	     unfold Cm, Csm in |- *; apply GraduationBetweenAnSn; immediate12.
	    since12 (Between A Cm Csm).
	     unfold Cm, Csm in |- *; apply GraduationBetweenAnSn; immediate12.
	     since12 (Between Bsm D Csm).
	      apply (ClockwiseSupplementAnglesBetween D Bsm Cm Csm).
	       since12 (Clockwise Bsm D Cm).
	       intro H21; contradict1 H19 H21.
	       from12 H18 (CongruentAngle Cm D Csm A B C).
	         step12 H21.
	         step12 H6.
	         from12 H15 (CongruentAngle Bsm D Cm Cm Bm Bsm).
	         step12 H22.
	      split.
	       step12 H21.
	         right; step12 H20.
	       split.
	        step12 H6.
	          as12 (CongruentAngle A Bm Cm Bm Bsm D).
	          step12 H12.
	        split.
	         step12 H18.
	           step12 H21.
	         step12 H8.
	           step12 H18.
	           as12 (Distance Bm Cm = Distance Bsm D).
	           usingChasles2 Bsm D Csm.
Qed.

Lemma  StrictParallelogrammExistM : forall A B C D E : Point,
	StrictParallelogramm A B C D ->
	Between B E C ->
	exists M : Point, Collinear A E M /\ Clockwise D C M.
Proof.
	intros.
	since12 (B <> E).
	destruct (ArchimedianDistanceLt B E C H1) as (n, (H2, H3)).
	from12 H0 (Clockwise A B E).
	since12 (A <> B).
	since12 (A <> E).
	generalize (DThales A B E H5 H6 H4 n H2).
	setGraduationPoint5 n A B ipattern:(Bn); fold Bn in |- *.
	setGraduationPoint5 n A E ipattern:(En); fold En in |- *.
	intros (H11, (H12, (H13, H14))).
	setStrictParallelogramm11 D A Bn ipattern:(F).
	 step12 H7.
	   immediate12.
	 DestructSP11 H16.
	   from12 H12 (CongruentAngle A Bn En A Bn F).
	  from12 H0 (CongruentAngle A B E A B C).
	    step12 H19.
	    as12 (Supplement A B C D A B).
	    from12 H7 (CongruentAngle D A B D A Bn).
	    step12 H21.
	    immediate12.
	  exists En; split.
	   immediate12.
	   from12 H19 (OpenRay Bn En F).
	     since12 (Clockwise A Bn F).
	     since12 (CongruentAngle A D C A D F).
	    as12 (CongruentAngle A D C A B C).
	      as12 (CongruentAngle A D F A Bn F).
	      from12 H0 (CongruentAngle A B C A B E).
	      step12 H24.
	      step12 H12.
	    since12 (CongruentAngle C D A F D A).
	      from12 H23 (OpenRay D C F).
	      step12 H24.
	     immediate12.
	     since12 (Between Bn F En).
	      apply DistanceLtBetween.
	       rewrite H14.
	         as12 (Distance Bn F = Distance A D).
	         as12 (Distance A D = Distance B C).
	       immediate12.
	       immediate12.
	      step12 H26.
	        left; immediate12.
Qed.

Lemma  StrictParallelogrammExistN : forall A B C D E : Point,
	StrictParallelogramm A B C D ->
	Between A E D ->
	exists N : Point, Collinear B E N /\ Clockwise D C N.
Proof.
	intros.
	since12 (A <> E).
	destruct (ArchimedianDistanceLt A E D H1) as (n, (H2, H3)).
	from12 H0 (Clockwise B E A).
	since12 (B <> E).
	since12 (B <> A).
	generalize (DThales B E A H5 H6 H4 n H2).
	setGraduationPoint5 n B A ipattern:(An); fold An in |- *.
	setGraduationPoint5 n B E ipattern:(En); fold En in |- *.
	intros (H11, (H12, (H13, H14))).
	setStrictParallelogramm11 An B C ipattern:(F).
	 step12 H7.
	   immediate12.
	 DestructSP11 H16.
	   from12 H13 (CongruentAngle En An B F An B).
	  from12 H0 (CongruentAngle B A E B A D).
	    step12 H19.
	    as12 (Supplement B A D C B A).
	    from12 H7 (CongruentAngle C B A C B An).
	    step12 H21.
	    immediate12.
	  exists En; split.
	   immediate12.
	   from12 H19 (OpenRay An En F).
	     since12 (CongruentAngle B C D B C F).
	    as12 (CongruentAngle B C D B A D).
	      as12 (CongruentAngle B C F B An F).
	      from12 H0 (CongruentAngle B A D B A E).
	      step12 H23.
	      step12 H13.
	    from12 H21 (OpenRay C D F).
	      step12 H22.
	     immediate12.
	     since12 (Between An F En).
	      apply DistanceLtBetween.
	       step12 H14.
	         as12 (Distance An F = Distance B C).
	         as12 (Distance A D = Distance B C).
	         as12 (DistanceTimes n A E = DistanceTimes n E A).
	       immediate12.
	       immediate12.
	      step12 H24.
	        right; immediate11.
Qed.

End DISCRETE_THALES.


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

(** LedgerStates: States are represented here as ledger functions from addresses to lists of assets
    (statefun). A ledger function is valid (sf_valid and sf_valid_) if no address holds duplicate assets,
    assetids are associated with at most one asset, every asset corresponds to a transaction output,
    and every asset id for an asset that has been spent at some time in the past is not
    currently spendable. The function tx_statefun_trans transforms a ledger function to
    a new ledger function. If the current ledger function supports the transaction (statefun_supports_tx)
    and the current ledger function is valid, then the transformed ledger function is also valid (sf_tx_valid_thm).
    The total asset values in the ledger change precisely according to the fees and rewards
    in the transaction (totalunits_bdd).
 **)

Require Export Transactions.

Definition statefun : Type := addr -> list asset.

Definition sf_unsp_txout {n} (f:bitseq n -> list asset) (h:hashval) : Prop :=
exists alpha, In_dom h (f alpha).

(*** sf_spent f h means h is the hash of a txout that has been spent at some point by the state represented by f. ***)
Inductive sf_spent {n} (f:bitseq n -> list asset) (h:hashval) : Prop :=
| sf_spent_1 inpl outpl i alpha : sf_unsp_txout f (hashpair (hashtx(inpl,outpl)) (hashnat i)) -> In (alpha,h) inpl -> sf_spent f h
| sf_spent_R inpl outpl i alpha : sf_spent f (hashpair (hashtx(inpl,outpl)) (hashnat i)) -> In (alpha,h) inpl -> sf_spent f h
.

Definition sf_valid_ {n} (alphapre:bitseq n -> addr) (f:bitseq n -> list asset) :=
(*** No duplicate: List at f alpha has no duplicate entries. ***)
(forall alpha, no_dups (f alpha))
/\
(*** Functionality: An unspent txout is only associated with one asset in one address. ***)
(forall h alpha u alpha' u', In (h,u) (f alpha) -> In (h,u') (f alpha') -> alpha = alpha' /\ u = u')
/\
(*** Existence: For every (h,u) in (f alpha), h comes from a txout with output of asset u to address alpha. ***)
(forall h u alpha, In (h,u) (f alpha)
           -> exists inpl outpl i,
                h = hashpair (hashtx(inpl,outpl)) (hashnat i)
                /\
                nth_error outpl i = value(alphapre alpha,u))
/\
(*** No Double Spending: Every txout that has been spent according to f is not an unspent txout of f. ***)
(forall h, sf_spent f h -> ~ sf_unsp_txout f h)
.

Definition sf_valid (f:statefun) : Prop := sf_valid_ (fun alpha => alpha) f.

Lemma sf_valid_fnl (f:statefun) : sf_valid f -> forall alpha, fnl (f alpha).
intros [Hf1 [Hf2 _]] alpha.
generalize (fun h u => Hf2 h alpha u alpha).
generalize (Hf1 alpha).
generalize (f alpha) as al.
intros al H. induction H as [|[h u] hr H1 H2 IH].
- intros _. apply fnl_N.
- intros H3. apply fnl_C.
  + intros H4. apply In_In_dom_lem in H4. destruct H4 as [v H5].
    assert (L1: In (h,u) ((h,u)::hr)) by now left.
    assert (L2: In (h,v) ((h,u)::hr)) by now right.
    destruct (H3 _ _ _ L1 L2) as [_ H6]. subst v. contradiction (H1 H5).
  + apply IH. intros k v v' H4 H5. apply (H3 k).
    * now right.
    * now right.
Qed.

Inductive statefun_asset_value_in f : list addr_assetid -> nat -> Prop :=
| statefun_asset_value_in_nil : statefun_asset_value_in f nil 0
| statefun_asset_value_in_cons h a u inpl alpha v :
    statefun_asset_value_in f inpl v ->
    In a (f alpha) ->
    asset_value a = Some u ->
    h = assetid a ->
    statefun_asset_value_in f ((alpha,h)::inpl) (u+v)
| statefun_asset_value_in_skip h a inpl alpha v :
    statefun_asset_value_in f inpl v ->
    In a (f alpha) ->
    asset_value a = None ->
    h = assetid a ->
    statefun_asset_value_in f ((alpha,h)::inpl) v
.

Fixpoint totalassets_ {n} : forall (f:bitseq n -> list asset), list asset :=
match n with
| O => fun (f:bitseq 0 -> list asset) => f tt
| S n' => fun (f:bitseq (S n') -> list asset) => totalassets_ (fun bs => f (false,bs)) ++ totalassets_ (fun bs => f (true,bs))
end.

Definition statefun_totalassets (f:statefun) : list asset := totalassets_ f.

Definition statefun_totalunits (f:statefun) : nat :=
asset_value_sum (statefun_totalassets f).

Definition statefun_supports_tx (f:addr -> list asset) (tx:Tx) (fee rew:nat) : Prop :=
(exists utot:nat,
   statefun_asset_value_in f (tx_inputs tx) utot
   /\
   asset_value_out (tx_outputs tx) + fee = utot + rew)
.

Definition tx_statefun_trans (tx:Tx) (f:statefun) : statefun :=
fun alpha:addr =>
  (new_assets alpha (tx_outputs tx) (hashtx tx) 0)
    ++
    (remove_assets (f alpha)
                   (get_spent alpha (tx_inputs tx))).

Lemma tx_statefun_trans_lem_iff f inpl outpl alpha h obl u :
In (h,(obl,u)) (tx_statefun_trans (inpl,outpl) f alpha)
<->
In (h,(obl,u)) (f alpha) /\ ~In (alpha,h) inpl
\/
exists i, nth_error outpl i = value (alpha,(obl,u)) /\ h = hashpair (hashtx(inpl,outpl)) (hashnat i).
unfold tx_statefun_trans. split.
- intros H1. apply in_app_iff in H1. destruct H1 as [H1|H1].
  + apply new_assets_iff in H1. destruct H1 as [j [H2 H3]].
    simpl in H2. right. exists j. split.
    * assumption.
    * exact H3.
  + apply remove_assets_iff in H1. destruct H1 as [H2 H3]. left. split.
    * assumption.
    * intros H4. apply H3. apply get_spent_iff. exact H4.
- intros [[H1 H2]|[i [H1 H2]]].
  + apply in_app_iff. right. apply remove_assets_iff. split.
    * assumption.
    * intros H3. apply H2. now apply get_spent_iff.
  + apply in_app_iff. left. apply new_assets_iff. exists i. simpl. split.
    * assumption.
    * exact H2.
Qed.

Lemma statefun_supports_tx_assets_In (f:statefun) (tx:Tx) fee rew alpha h :
  statefun_supports_tx f tx fee rew ->
  In (alpha,h) (tx_inputs tx) -> exists obl u, In (h,(obl,u)) (f alpha).
intros [utot [H _]]. destruct tx as [inpl outpl].
simpl in *|-*.
induction H as [|k [k' [obl' u']] u inpl beta v H1 IH H2 H3 H4|k [k' [obl' u']] inpl beta v H1 IH H2 H3 H4].
- simpl. tauto.
- intros [H5|H5].
  + inversion H5. simpl in H4. subst k'. subst k. exists obl'. exists u'.
    subst beta. exact H2.
  + tauto.
- intros [H5|H5].
  + inversion H5. simpl in H4. subst k'. subst k. exists obl'. exists u'.
    subst beta. exact H2.
  + tauto.
Qed.

(*** We need to know the tx has at least one input to ensure all its txouts are fresh. ***)
Lemma sf_tx_valid_fresh_lem (f:statefun) (tx:Tx) fee rew :
  sf_valid f ->
  tx_inputs_valid (tx_inputs tx) ->
  statefun_supports_tx f tx fee rew ->
  forall i alpha, ~In_dom (hashpair (hashtx tx) (hashnat i)) (f alpha).
destruct tx as [[|[beta hin] inpl] outpl].
- intros _ [Ht2 _]. exfalso. simpl in Ht2. congruence.
- intros Hf Ht Hs i alpha H1.
  generalize Hf. intros [Hf1 [Hf2 [Hf3 Hf4]]].
  apply (Hf4 hin).
  + apply (sf_spent_1 f hin ((beta,hin)::inpl) outpl i beta).
    * exists alpha. assumption.
    * now left.
  + exists beta. apply In_In_dom_lem.
    assert (L1: exists obl u, In (hin, (obl,u)) (f beta)).
    { apply (statefun_supports_tx_assets_In _ _ _ _ _ _ Hs).
      simpl. now left.
    }
    destruct L1 as [obl [u H2]].
    exists (obl,u). exact H2.
Qed.

(*** We need to know the tx has at least one input to ensure all its txouts did not occur as previous spent txs. ***)
Lemma sf_tx_valid_not_spent_lem (f:statefun) (tx:Tx) fee rew :
  sf_valid f ->
  tx_inputs_valid (tx_inputs tx) ->
  statefun_supports_tx f tx fee rew ->
  forall i, ~ sf_spent f (hashpair (hashtx tx) (hashnat i)).
destruct tx as [[|[beta hin] inpl] outpl].
- intros _ [Ht2 _]. exfalso. simpl in Ht2. congruence.
- intros Hf Ht Hs i H1.
  generalize Hf. intros [Hf1 [Hf2 [Hf3 Hf4]]].
  apply (Hf4 hin).
  + apply (sf_spent_R f hin ((beta,hin)::inpl) outpl i beta).
    * exact H1.
    * now left.
  + exists beta. apply In_In_dom_lem.
    assert (L1: exists obl u, In (hin, (obl,u)) (f beta)).
    { apply (statefun_supports_tx_assets_In _ _ _ _ _ _ Hs).
      simpl. now left.
    }
    destruct L1 as [obl [u H2]].
    exists (obl,u). exact H2.
Qed.

(** If a txout h was spent in the transformed state, then it was either already spent or was one of the inputs of the new tx. ***)
Lemma sf_tx_valid_spent_lem inpl outpl f h fee rew :
  tx_inputs_valid inpl ->
  statefun_supports_tx f (inpl,outpl) fee rew ->
  sf_spent (tx_statefun_trans (inpl, outpl) f) h ->
  sf_spent f h \/ exists alpha, In (alpha,h) inpl.
intros Ht Hs H.
induction H as [h inpl' outpl' i alpha [beta H1] H2|h inpl' outpl' i alpha H1 IH1 H2].
- apply In_In_dom_lem in H1. destruct H1 as [u H1].
  apply in_app_iff in H1. destruct H1 as [H1|H1].
  + apply new_assets_iff in H1. destruct H1 as [j [H3 H4]].
    right. exists alpha.
    assert (L1: In (hash_addr_assetid (alpha,h)) (map hash_addr_assetid inpl)).
    { apply hashpairinj in H4. destruct H4 as [H5 H6]. apply hashnatinj in H6.
      simpl in H5. apply hashpairinj in H5.
      destruct H5 as [H7 H8].
      apply hashlistinj in H7. rewrite <- H7.
      apply in_map_iff. exists (alpha,h). tauto. }
    apply in_map_iff in L1. destruct L1 as [[alpha' h'] [L1a L1b]].
    apply hash_addr_assetidinj in L1a. destruct L1a as [L1aa L1ab].
    subst alpha' h'. assumption.
  + apply remove_assets_iff in H1. destruct H1 as [H3 H4].
    left. apply (sf_spent_1 f h inpl' outpl' i alpha).
    * exists beta. apply In_In_dom_lem_2 in H3. assumption.
    * assumption.
- left. destruct IH1 as [H3|[beta H3]].
  + now apply (sf_spent_R f h inpl' outpl' i alpha).
  + apply (statefun_supports_tx_assets_In _ _ _ _ _ _ Hs) in H3.
    destruct H3 as [obl [u H3]].
    apply (sf_spent_1 f h inpl' outpl' i alpha).
    * exists beta. apply In_In_dom_lem_2 in H3. assumption.
    * assumption.
Qed.

Theorem sf_tx_valid_thm (f:statefun) (tx:Tx) fee rew :
  sf_valid f ->
  tx_valid tx ->
  statefun_supports_tx f tx fee rew ->
  sf_valid (tx_statefun_trans tx f).
intros Hf Ht Hs.
destruct tx as [inpl outpl]. generalize Hf Ht. simpl.
intros [Hf1 [Hf2 [Hf3 Hf4]]] Ht2. split.
- intros alpha. simpl. unfold tx_statefun_trans. apply no_dups_app.
  + apply no_dups_new_assets.
  + apply no_dups_remove_assets. apply Hf1.
  + intros [h [obl u]] H1 H2.
    apply new_assets_iff in H1. apply remove_assets_iff in H2.
    destruct H1 as [j [H3 H4]]. destruct H2 as [H5 H6].
    apply (sf_tx_valid_fresh_lem f (inpl,outpl) fee rew Hf Ht2 Hs j alpha).
    apply In_In_dom_lem. exists (obl,u).
    change (h = hashpair (hashtx (inpl, outpl)) (hashnat j)) in H4.
    rewrite H4 in H5. exact H5.
- split.
  + intros h alpha [obl u] alpha' [obl' u'].
    unfold tx_statefun_trans. intros H1 H2.
    apply in_app_iff in H1. apply in_app_iff in H2.
    destruct H1 as [H1|H1]; destruct H2 as [H2|H2].
    * apply new_assets_iff in H1. destruct H1 as [j [H3 H4]].
      apply new_assets_iff in H2. destruct H2 as [k [H5 H6]].
      change (nth_error outpl j = value (alpha, (obl,u))) in H3.
      change (h = hashpair (hashtx (inpl, outpl)) (hashnat j)) in H4.
      change (nth_error outpl k = value (alpha', (obl',u'))) in H5.
      change (h = hashpair (hashtx (inpl, outpl)) (hashnat k)) in H6.
      assert (L1: j = k).
      { subst h. apply hashpairinj in H6. destruct H6 as [H7 H8].
        apply hashnatinj in H8. omega. }
      subst k. rewrite H3 in H5. inversion H5. tauto.
    * exfalso.
      apply new_assets_iff in H1. destruct H1 as [j [H3 H4]].
      change (nth_error outpl j = value (alpha, (obl,u))) in H3.
      change (h = hashpair (hashtx (inpl, outpl)) (hashnat j)) in H4.
      apply remove_assets_iff in H2. destruct H2 as [H5 H6].
      change (~ In h (get_spent alpha' inpl)) in H6.
      apply In_In_dom_lem_2 in H5. revert H5.
      rewrite H4. apply (sf_tx_valid_fresh_lem f (inpl,outpl) fee rew Hf Ht2 Hs).
    * exfalso.
      apply remove_assets_iff in H1. destruct H1 as [H3 H4].
      change (~ In h (get_spent alpha inpl)) in H4.
      apply new_assets_iff in H2. destruct H2 as [j [H5 H6]].
      change (nth_error outpl j = value (alpha', (obl',u'))) in H5.
      change (h = hashpair (hashtx (inpl, outpl)) (hashnat j)) in H6.
      apply In_In_dom_lem_2 in H3. revert H3.
      rewrite H6. apply (sf_tx_valid_fresh_lem f (inpl,outpl) fee rew Hf Ht2 Hs).
    * apply remove_assets_iff in H1. destruct H1 as [H3 H4].
      apply remove_assets_iff in H2. destruct H2 as [H5 H6].
      change (~ In h (get_spent alpha inpl)) in H4.
      change (~ In h (get_spent alpha' inpl)) in H6.
      now apply Hf2 with (h := h).
  + split.
    * { unfold tx_statefun_trans. intros h [obl u] alpha H1.
        apply in_app_iff in H1. destruct H1 as [H1|H1].
        - apply new_assets_iff in H1. destruct H1 as [j [H2 H3]].
          exists inpl. exists outpl. exists j. split.
          + assumption.
          + exact H2.
        - apply remove_assets_iff in H1. destruct H1 as [H2 H3].
          revert H2. apply Hf3.
      }
    * { intros h H1 [alpha H2].
        apply In_In_dom_lem in H2. destruct H2 as [u H2].
        apply in_app_iff in H2. destruct H2 as [H2|H2].
        - apply new_assets_iff in H2. destruct H2 as [j [H3 H4]].
          simpl in H3, H4.
          destruct (sf_tx_valid_spent_lem inpl outpl f h fee rew Ht2 Hs H1) as [H5|[beta H5]].
          + revert H5. rewrite H4.
            apply (sf_tx_valid_not_spent_lem f (inpl,outpl) fee rew Hf Ht2 Hs).
          + apply (hashtx_notin_inpl beta inpl outpl j).
            simpl. rewrite <- H4. exact H5.
        - apply remove_assets_iff in H2. destruct H2 as [H3 H4].
          assert (L1: sf_unsp_txout f h).
          { exists alpha. apply In_In_dom_lem_2 in H3. assumption. }
          revert L1. apply Hf4.
          destruct (sf_tx_valid_spent_lem inpl outpl f h fee rew Ht2 Hs H1) as [H5|[beta H5]].
          + assumption.
          + exfalso. apply H4. apply get_spent_iff. simpl.
            assert (L2: alpha = beta).
            { destruct (statefun_supports_tx_assets_In f (inpl,outpl) fee rew beta h Hs H5) as [obl' [v H6]].
              generalize (Hf2 h alpha u beta (obl',v) H3 H6). tauto.
            }
            congruence.
      }
Qed.

Lemma totalassets__iff {n} (f:bitseq n -> list asset) h u :
In (h,u) (totalassets_ f)
<->
exists bs, In (h,u) (f bs).
induction n as [|n IH].
- simpl. split.
  + intros H1. exists tt. assumption.
  + intros [[] H1]. assumption.
- simpl. split.
  + intros H1. apply in_app_iff in H1. destruct H1 as [H1|H1].
    * apply IH in H1. destruct H1 as [bs H1]. exists (false,bs). assumption.
    * apply IH in H1. destruct H1 as [bs H1]. exists (true,bs). assumption.
  + intros [[[|] bs] H1].
    * apply in_or_app. right. apply IH. exists bs. assumption.
    * apply in_or_app. left. apply IH. exists bs. assumption.
Qed.

Lemma totalassets_iff (f:addr -> list asset) h u :
In (h,u) (statefun_totalassets f)
<->
exists alpha, In (h,u) (f alpha).
apply totalassets__iff.
Qed.

Lemma totalassets_no_dups_ {n} (f:bitseq n -> list asset) :
  (forall bs, no_dups (f bs)) ->
  (forall h bs u bs' u', In (h,u) (f bs) -> In (h,u') (f bs') -> bs = bs' /\ u = u') ->
  no_dups (totalassets_ f).
induction n as [|n IH].
- simpl. intros H1 _. apply H1.
- intros H1 H2. simpl. apply no_dups_app.
  + apply IH.
    * intros bs. apply (H1 (false,bs)).
    * intros h bs u bs' u' H3 H4.
      destruct (H2 h (false,bs) u (false,bs') u' H3 H4) as [H5 H6].
      split; congruence.
  + apply IH.
    * intros bs. apply (H1 (true,bs)).
    * intros h bs u bs' u' H3 H4.
      destruct (H2 h (true,bs) u (true,bs') u' H3 H4) as [H5 H6].
      split; congruence.
  + intros [h u] H3 H4.
    apply totalassets__iff in H3. apply totalassets__iff in H4.
    destruct H3 as [bs H3]. destruct H4 as [bs' H4].
    destruct (H2 h (false,bs) u (true,bs') u H3 H4) as [H5 H6].
    discriminate H5.
Qed.

Lemma totalassets_no_dups (f:statefun) :
 sf_valid f ->
 no_dups (statefun_totalassets f).
intros [Hf1 [Hf2 _]]. apply totalassets_no_dups_.
- exact Hf1.
- exact Hf2.
Qed.

Lemma totalassets_fnl_ {n} (f:bitseq n -> list asset) :
  (forall bs, no_dups (f bs)) ->
  (forall h bs u bs' u', In (h,u) (f bs) -> In (h,u') (f bs') -> bs = bs' /\ u = u') ->
  fnl (totalassets_ f).
induction n as [|n IH].
- simpl. intros H1 H2.
  generalize (fun h u v => H2 h tt u tt v). generalize (H1 tt).
  generalize (f tt) as l. clear.
  intros l Hl. induction Hl as [|[h u] l H0 H1 IH].
  + intros _. apply fnl_N.
  + intros H2. apply fnl_C.
    * intros H3. apply In_In_dom_lem in H3. destruct H3 as [v H4].
      assert (L1: tt = tt /\ u = v).
      { apply (H2 h); simpl; tauto. }
      destruct L1 as [_ L1b].
      subst v. contradiction.
    * { apply IH. intros k v w H3 H4. apply (H2 k).
        - now right.
        - now right.
      }
- intros H1 H2. simpl. apply fnl_app.
  + apply IH.
    * intros bs. apply (H1 (false,bs)).
    * intros h bs u bs' u' H3 H4.
      destruct (H2 h (false,bs) u (false,bs') u' H3 H4) as [H5 H6].
      split; congruence.
  + apply IH.
    * intros bs. apply (H1 (true,bs)).
    * intros h bs u bs' u' H3 H4.
      destruct (H2 h (true,bs) u (true,bs') u' H3 H4) as [H5 H6].
      split; congruence.
  + intros h H3 H4.
    apply In_In_dom_lem in H3. apply In_In_dom_lem in H4.
    destruct H3 as [u H3]. destruct H4 as [v H4].
    apply totalassets__iff in H3. apply totalassets__iff in H4.
    destruct H3 as [bs H3]. destruct H4 as [bs' H4].
    destruct (H2 h (false,bs) u (true,bs') v H3 H4) as [H5 H6].
    discriminate H5.
Qed.

Lemma totalassets_fnl (f:statefun) :
 sf_valid f ->
 fnl (statefun_totalassets f).
intros [Hf1 [Hf2 _]]. apply totalassets_fnl_.
- exact Hf1.
- exact Hf2.
Qed.

Opaque statefun_totalassets.

Lemma totalassets_trans_iff (f:statefun) (tx:Tx) fee rew :
 sf_valid f ->
 tx_valid tx ->
 statefun_supports_tx f tx fee rew ->
 forall h obl u,
   In (h,(obl,u)) (statefun_totalassets (tx_statefun_trans tx f)) <->
   ((In (h,(obl,u)) (statefun_totalassets f) /\ ~exists alpha, In (alpha,h) (tx_inputs tx))
    \/
    exists alpha i, nth_error (tx_outputs tx) i = value (alpha,(obl,u)) /\ h = hashpair (hashtx tx) (hashnat i)).
intros Hf Ht Hs. destruct tx as [inpl outpl]. intros h obl u. split.
- intros H1. destruct (totalassets_iff (tx_statefun_trans (inpl,outpl) f) h (obl,u)) as [H2 _].
  destruct (H2 H1) as [alpha H3].
  unfold tx_statefun_trans in H3. apply in_app_iff in H3.
  destruct H3 as [H4|H4].
  + apply new_assets_iff in H4.
    right. exists alpha. exact H4.
  + apply remove_assets_iff in H4. destruct H4 as [H5 H6]. left. split.
    * destruct (totalassets_iff f h (obl,u)) as [_ H7]. apply H7.
      exists alpha. assumption.
    * intros [beta H7]. simpl in H7. apply H6.
      apply get_spent_iff. simpl.
      assert (L1: alpha = beta).
      { destruct (statefun_supports_tx_assets_In f (inpl,outpl) fee rew beta h Hs H7) as [obl' [v H8]].
        destruct Hf as [_ [Hf2 _]].
        destruct (Hf2 h alpha (obl,u) beta (obl',v) H5 H8) as [H9 _].
        exact H9.
      }
      rewrite L1. exact H7.
- intros [[H1 H2]|[alpha [i H1]]].
  + destruct (totalassets_iff (tx_statefun_trans (inpl,outpl) f) h (obl,u)) as [_ H3].
    apply H3.
    destruct (totalassets_iff f h (obl,u)) as [H4 _].
    destruct (H4 H1) as [alpha H5].
    exists alpha.
    unfold tx_statefun_trans. apply in_or_app.
    right. apply remove_assets_iff.
    split.
    * assumption.
    * intros H6. apply H2. exists alpha. now apply get_spent_iff.
  + destruct (totalassets_iff (tx_statefun_trans (inpl,outpl) f) h (obl,u)) as [_ H3].
    apply H3.
    exists alpha.
    unfold tx_statefun_trans. apply in_or_app.
    left. apply new_assets_iff. exists i. exact H1.
Qed.

Lemma sf_totalassets_app__iff {n} (f g:bitseq n -> list asset) :
  app_perm (totalassets_ (fun alpha => f alpha ++ g alpha))
           (totalassets_ f ++ totalassets_ g).
induction n as [|n IH].
- simpl. apply app_perm_ref.
- simpl.
  generalize (IH (fun bs => f (false,bs)) (fun bs => g (false,bs))).
  intros IH1.
  generalize (IH (fun bs => f (true,bs)) (fun bs => g (true,bs))).
  intros IH2.
  apply app_perm_tra with (r := ((totalassets_ (fun bs : bitseq n => f (false, bs)) ++
                                               totalassets_ (fun bs : bitseq n => g (false, bs))) ++
                                                                                (totalassets_ (fun bs : bitseq n => f (true, bs)) ++
                   totalassets_ (fun bs : bitseq n => g (true, bs))))).
  + apply app_perm_app.
    * exact IH1.
    * exact IH2.
  + rewrite <- app_assoc. rewrite <- app_assoc. apply app_perm_app.
    * apply app_perm_ref.
    * { rewrite app_assoc. rewrite app_assoc. apply app_perm_app.
        - apply app_perm_swap.
        - apply app_perm_ref.
      }
Qed.

Lemma sf_totalassets__ifcons_app_perm (nw:asset) (beta:addr) {n} (alphapre:bitseq n -> addr) (f:bitseq n -> list asset) :
  (forall alpha1 alpha2:bitseq n, alphapre alpha1 = alphapre alpha2 -> alpha1 = alpha2) ->
  ((exists alpha:bitseq n, alphapre alpha = beta) ->
   app_perm
     (totalassets_
        (fun alpha : bitseq n =>
           if addr_eq_dec (alphapre alpha) beta then nw :: f alpha else f alpha))
     (nw :: totalassets_ f))
  /\
  (~(exists alpha:bitseq n, alphapre alpha = beta) ->
   app_perm
     (totalassets_
        (fun alpha : bitseq n =>
           if addr_eq_dec (alphapre alpha) beta then nw :: f alpha else f alpha))
     (totalassets_ f)).
induction n as [|n IH]; split; intros H1.
- simpl. destruct H1 as [[] H1].
  destruct (addr_eq_dec (alphapre tt) beta) as [H2|H2].
  + apply app_perm_ref.
  + exfalso. contradiction.
- simpl.
  destruct (addr_eq_dec (alphapre tt) beta) as [H2|H2].
  + exfalso. apply H1. exists tt. assumption.
  + apply app_perm_ref.
- set (alphapre1 := fun alpha:bitseq n => alphapre (true,alpha)).
  set (alphapre0 := fun alpha:bitseq n => alphapre (false,alpha)).
  assert (alphapre1inj : forall alpha1 alpha2, alphapre1 alpha1 = alphapre1 alpha2 -> alpha1 = alpha2).
  { intros alpha1 alpha2 H2. apply H in H2. congruence. }
  assert (alphapre0inj : forall alpha1 alpha2, alphapre0 alpha1 = alphapre0 alpha2 -> alpha1 = alpha2).
  { intros alpha1 alpha2 H2. apply H in H2. congruence. }
  destruct H1 as [[[|] alpha] H1].
  + destruct (IH alphapre1 (fun alpha => f (true,alpha)) alphapre1inj) as [IH1 _].
    destruct (IH alphapre0 (fun alpha => f (false,alpha)) alphapre0inj) as [_ IH2].
    simpl.
    apply app_perm_tra with (r := (totalassets_ (fun bs : bitseq n => f (false, bs)) ++ nw::totalassets_ (fun bs : bitseq n => f (true, bs)))).
    * { apply app_perm_app.
        - apply IH2. intros [alpha0 H2]. rewrite <- H1 in H2. apply H in H2.
          discriminate H2.
        - apply IH1. exists alpha. exact H1.
      }
    * { change (app_perm
     (totalassets_ (fun bs : bitseq n => f (false, bs)) ++
                   ((cons nw nil) ++ totalassets_ (fun bs : bitseq n => f (true, bs))))
     ((nw
      :: totalassets_ (fun bs : bitseq n => f (false, bs))) ++
         totalassets_ (fun bs : bitseq n => f (true, bs)))).
        rewrite app_assoc. apply app_perm_app.
        - apply (app_perm_swap _ (cons nw nil)).
        - apply app_perm_ref.
      }
  + destruct (IH alphapre1 (fun alpha => f (true,alpha)) alphapre1inj) as [_ IH1].
    destruct (IH alphapre0 (fun alpha => f (false,alpha)) alphapre0inj) as [IH2 _].
    simpl.
    change (app_perm
     (totalassets_
        (fun bs : bitseq n =>
         if addr_eq_dec (alphapre (false, bs)) beta
         then nw :: f (false, bs)
         else f (false, bs)) ++
      totalassets_
        (fun bs : bitseq n =>
         if addr_eq_dec (alphapre (true, bs)) beta
         then nw :: f (true, bs)
         else f (true, bs)))
     ((nw
      :: totalassets_ (fun bs : bitseq n => f (false, bs))) ++
         totalassets_ (fun bs : bitseq n => f (true, bs)))).
    apply app_perm_app.
    * apply IH2. exists alpha. exact H1.
    * apply IH1. intros [alpha0 H2]. rewrite <- H1 in H2. apply H in H2.
      discriminate H2.
- set (alphapre1 := fun alpha:bitseq n => alphapre (true,alpha)).
  set (alphapre0 := fun alpha:bitseq n => alphapre (false,alpha)).
  assert (alphapre1inj : forall alpha1 alpha2, alphapre1 alpha1 = alphapre1 alpha2 -> alpha1 = alpha2).
  { intros alpha1 alpha2 H2. apply H in H2. congruence. }
  assert (alphapre0inj : forall alpha1 alpha2, alphapre0 alpha1 = alphapre0 alpha2 -> alpha1 = alpha2).
  { intros alpha1 alpha2 H2. apply H in H2. congruence. }
  destruct (IH alphapre1 (fun alpha => f (true,alpha)) alphapre1inj) as [_ IH1].
  destruct (IH alphapre0 (fun alpha => f (false,alpha)) alphapre0inj) as [_ IH2].
  simpl. apply app_perm_app.
  + apply IH2. intros [alpha H2]. apply H1. exists (false,alpha). exact H2.
  + apply IH1. intros [alpha H2]. apply H1. exists (true,alpha). exact H2.
Qed.

Lemma sf_totalassets__remove_assets {n} (alphapre:bitseq n -> addr) (f:bitseq n -> list asset) (inpl:list addr_assetid) :
  (forall h alpha u beta v, In (h,u) (f alpha) -> In (h,v) (f beta) -> alpha = beta /\ u = v) ->
  (forall h alpha, In (alphapre alpha,h) inpl -> exists u, In (h,u) (f alpha)) ->
  (forall h u, In (h,u) (totalassets_ f) -> (In h (map (@snd addr hashval) inpl) <-> exists alpha, In (alphapre alpha,h) inpl)) ->
  app_perm (remove_assets (totalassets_ f) (map (@snd addr hashval) inpl))
           (totalassets_ (fun alpha => remove_assets (f alpha) (get_spent (alphapre alpha) inpl))).
intros Hf2 Ht1. induction n as [|n IH].
- simpl.
  intros H1. rewrite (remove_assets_eq (f tt) (map (snd (B:=hashval)) inpl) (get_spent (alphapre tt) inpl)).
  + apply app_perm_ref.
  + intros h H2. apply In_In_dom_lem in H2. destruct H2 as [u H2]. split.
    * intros H3. apply (H1 _ _ H2) in H3. destruct H3 as [[] H3]. now apply get_spent_iff.
    * intros H3. apply (H1 _ _ H2). exists tt. now apply get_spent_iff.
- simpl. intros H1.
  apply app_perm_tra with (r :=
     (remove_assets
        (totalassets_ (fun bs : bitseq n => f (false, bs)))
        (map (snd (B:=hashval)) inpl))
       ++
     (remove_assets
        (totalassets_ (fun bs : bitseq n => f (true, bs)))
        (map (snd (B:=hashval)) inpl))).
  + rewrite remove_assets_app. apply app_perm_ref.
  + apply app_perm_app.
    * { set (alphapre0 := fun alpha:bitseq n => alphapre (false,alpha)).
        set (f0 := fun alpha:bitseq n => f (false,alpha)).
        apply (IH alphapre0 f0).
        - intros h alpha u beta v H2 H3.
          destruct (Hf2 h (false,alpha) u (false,beta) v H2 H3) as [H4 H5].
          split; congruence.
        - intros h alpha H2. unfold alphapre0 in H2. apply Ht1 in H2. exact H2.
        - intros h u H2. split.
          + intros H3. apply (H1 h u) in H3.
            * { destruct H3 as [[[|] alpha] H4].
                - apply totalassets__iff in H2. unfold f0 in H2. simpl in H2.
                  destruct H2 as [beta H2].
                  apply Ht1 in H4. destruct H4 as [v H5].
                  destruct (Hf2 h (true,alpha) v (false,beta) u H5 H2) as [H6 _].
                  discriminate H6.
                - exists alpha. exact H4.
              }
            * apply in_or_app. left. exact H2.
          + intros [alpha H3]. apply (H1 h u).
            * apply in_or_app. left. exact H2.
            * exists (false,alpha). exact H3.
      }
    * { set (alphapre1 := fun alpha:bitseq n => alphapre (true,alpha)).
        set (f1 := fun alpha:bitseq n => f (true,alpha)).
        apply (IH alphapre1 f1).
        - intros h alpha u beta v H2 H3.
          destruct (Hf2 h (true,alpha) u (true,beta) v H2 H3) as [H4 H5].
          split; congruence.
        - intros h alpha H2. unfold alphapre1 in H2. apply Ht1 in H2. exact H2.
        - intros h u H2. split.
          + intros H3. apply (H1 h u) in H3.
            * { destruct H3 as [[[|] alpha] H4].
                - exists alpha. exact H4.
                - apply totalassets__iff in H2. unfold f1 in H2. simpl in H2.
                  destruct H2 as [beta H2].
                  apply Ht1 in H4. destruct H4 as [v H5].
                  destruct (Hf2 h (false,alpha) v (true,beta) u H5 H2) as [H6 _].
                  discriminate H6.
              }
            * apply in_or_app. right. exact H2.
          + intros [alpha H3]. apply (H1 h u).
            * apply in_or_app. right. exact H2.
            * exists (true,alpha). exact H3.
      }
Qed.

Transparent statefun_totalassets.

Lemma sf_totalassets_app_iff f g :
  app_perm (statefun_totalassets (fun alpha => f alpha ++ g alpha))
           (statefun_totalassets f ++ statefun_totalassets g).
apply sf_totalassets_app__iff.
Qed.

Lemma sf_totalassets_ifcons_app_perm beta nw f :
  app_perm (statefun_totalassets (fun alpha => if addr_eq_dec alpha beta then nw::f alpha else f alpha)) (nw::statefun_totalassets f).
apply sf_totalassets__ifcons_app_perm.
- tauto.
- exists beta. reflexivity.
Qed.

Lemma sf_totalassets_remove_assets f inpl :
  (forall h alpha u beta v, In (h,u) (f alpha) -> In (h,v) (f beta) -> alpha = beta /\ u = v) ->
  (forall h alpha, In (alpha,h) inpl -> exists u, In (h,u) (f alpha)) ->
  app_perm (remove_assets (statefun_totalassets f) (map (@snd addr hashval) inpl))
           (statefun_totalassets (fun alpha => remove_assets (f alpha) (get_spent alpha inpl))).
intros H1 H2.
apply (sf_totalassets__remove_assets (fun alpha => alpha) f inpl H1 H2).
intros h u H3. split.
- intros H4. apply in_map_iff in H4. destruct H4 as [[alpha h'] [H5 H6]].
  exists alpha. simpl in H5. congruence.
- intros [alpha H4]. apply in_map_iff. exists (alpha,h). split.
  + reflexivity.
  + exact H4.
Qed.

Opaque statefun_totalassets.

Lemma sf_totalassets_nil : statefun_totalassets (fun alpha => nil) = nil.
assert (L1: exists l, statefun_totalassets (fun alpha => nil) = l).
{ now exists (statefun_totalassets (fun alpha => nil)). }
destruct L1 as [[|[h u] l] L1a].
- exact L1a.
- assert (L2: In (h, u) (statefun_totalassets (fun _ => nil))).
  { rewrite L1a. left. reflexivity. }
  destruct (totalassets_iff (fun _ => nil) h u) as [H1 H2].
  destruct (H1 L2) as [alpha []].
Qed.

Opaque asset_value_sum.

Lemma sf_totalunits_new_assets (aul:list addr_preasset) txh i :
  statefun_totalunits (fun alpha => new_assets alpha aul txh i) =
  asset_value_out aul.
revert i. induction aul as [|[beta [obl u]] aul IH]; intros i.
- simpl. unfold statefun_totalunits. rewrite sf_totalassets_nil. simpl.
  reflexivity.
- simpl. rewrite <- (IH (S i)). unfold statefun_totalunits.
  assert (L1: app_perm (statefun_totalassets
           (fun alpha : addr =>
            if addr_eq_dec alpha beta
            then
             (hashpair txh (hashnat i), (obl,u)) :: new_assets alpha aul txh (S i)
            else new_assets alpha aul txh (S i)))
                       ((hashpair txh (hashnat i),(obl,u))::(statefun_totalassets
                                                         (fun alpha : addr => new_assets alpha aul txh (S i))))).
  { apply (sf_totalassets_ifcons_app_perm beta (hashpair txh (hashnat i),(obl,u))). }
  apply app_perm_asset_value_sum in L1.
  simpl in L1. rewrite L1.
  destruct (asset_value (hashpair txh (hashnat i), (obl,u))) as [u'|] eqn:E1.
  + rewrite (asset_value_sum_value_cons _ _ _ E1).
    destruct u as [u|d]; try discriminate E1.
    unfold asset_value in E1. simpl in E1. inversion E1. reflexivity.
  + rewrite (asset_value_sum_novalue_cons _ _ E1).
    destruct u as [n|d]; try reflexivity; discriminate E1.
Qed.

Lemma no_dups_map_inpl f inpl :
  sf_valid f ->
  (forall h alpha, In (alpha,h) inpl -> exists u, In (h,u) (f alpha)) ->
  no_dups inpl ->
  no_dups (map (@snd addr hashval) inpl).
intros [_ [Hf2 _]] H1 H.
induction H as [|[alpha h] inpl H2 H3 IH].
- apply no_dups_nil.
- simpl. apply no_dups_cons.
  + intros H4. apply in_map_iff in H4.
    destruct H4 as [[beta k] [H5 H6]]. simpl in H5. subst k.
    assert (L1: exists oblu : prod obligation preasset, In (h, oblu) (f alpha)).
    { apply H1. now left. }
    assert (L2: exists oblu : prod obligation preasset, In (h, oblu) (f beta)).
    { apply H1. now right. }
    destruct L1 as [[obl u] L1a].
    destruct L2 as [[obl' v] L2a].
    destruct (Hf2 h alpha (obl,u) beta (obl',v) L1a L2a) as [H7 _].
    subst beta. contradiction.
  + apply IH. intros k beta H4. apply H1. now right.
Qed.

Lemma statefun_asset_value_in_lem f inpl utot :
  sf_valid f ->
  (forall h alpha, In (alpha,h) inpl -> exists u, In (h,u) (f alpha)) ->
  no_dups inpl ->
  statefun_asset_value_in f inpl utot ->
   utot + statefun_totalunits
            (fun alpha : addr =>
               remove_assets (f alpha) (get_spent alpha inpl))
   =
   statefun_totalunits f.
intros Hf Ht1 Ht3 H.
assert (L1:forall (h : hashval) (alpha : addr) (u : prod obligation preasset)
                  (beta : addr) (v : prod obligation preasset),
             In (h, u) (f alpha) -> In (h, v) (f beta) -> alpha = beta /\ u = v).
{ destruct Hf as [_ [Hf2 _]]. exact Hf2. }
unfold statefun_totalunits at 1.
rewrite <- (app_perm_asset_value_sum _ _ (sf_totalassets_remove_assets f inpl L1 Ht1)).
clear L1.
induction H as [|h a u inpl alpha v H1 IH1 H2|h a inpl alpha v H1 IH1 H2 H3].
- simpl. rewrite remove_assets_nil. unfold statefun_totalunits. omega.
- simpl.
  assert (L3:forall h alpha, In (alpha, h) inpl -> exists u : prod obligation preasset, In (h, u) (f alpha)).
  { intros k beta H3. apply Ht1. now right. }
  specialize (IH1 L3).
  assert (L4: v + (u + asset_value_sum
                         (remove_assets (statefun_totalassets f)
                                        (h :: map (snd (B:=hashval)) inpl)))
              = statefun_totalunits f).
  { rewrite asset_value_sum_asset_shift with (a := (assetobl a,assetpre a)).
    - apply IH1. inversion Ht3. assumption.
    - apply totalassets_fnl. exact Hf.
    - exact (no_dups_map_inpl f _ Hf Ht1 Ht3).
    - apply totalassets_iff. exists alpha. subst h.
      destruct a as [h [obl u']]. exact H2.
    - exact H.
  }
  omega.
- simpl.
  assert (L3:forall h alpha, In (alpha, h) inpl -> exists u : prod obligation preasset, In (h, u) (f alpha)).
  { intros k beta H4. apply Ht1. now right. }
  specialize (IH1 L3).
  assert (L4: v + asset_value_sum
                    (remove_assets (statefun_totalassets f)
                                   (h :: map (snd (B:=hashval)) inpl))
              = statefun_totalunits f).
  { rewrite asset_value_sum_asset_shift_non with (a := (assetobl a,assetpre a)).
    - apply IH1. inversion Ht3. assumption.
    - apply totalassets_fnl. exact Hf.
    - exact (no_dups_map_inpl f _ Hf Ht1 Ht3).
    - apply totalassets_iff. exists alpha. subst h.
      destruct a as [h [obl u']]. exact H2.
    - exact H3.
  }
  omega.
Qed.

Theorem totalunits_bdd (f:statefun) (tx:Tx) (fee rew:nat) :
 sf_valid f ->
 tx_valid tx ->
 statefun_supports_tx f tx fee rew ->
 statefun_totalunits (tx_statefun_trans tx f) + fee = statefun_totalunits f + rew.
intros Hf Ht Hs. generalize Hs. intros [utot [H1 H2]].
unfold statefun_totalunits at 1. unfold tx_statefun_trans.
generalize (sf_totalassets_app_iff (fun alpha => new_assets alpha (tx_outputs tx) (hashtx tx) 0) (fun alpha => remove_assets (f alpha) (get_spent alpha (tx_inputs tx)))).
intros H3. apply app_perm_asset_value_sum in H3.
rewrite H3. clear H3.
rewrite <- (asset_value_sum_app
              (statefun_totalassets
                 (fun alpha : addr =>
                    new_assets alpha (tx_outputs tx) (hashtx tx) 0))
              (statefun_totalassets
                 (fun alpha : addr =>
                    remove_assets (f alpha) (get_spent alpha (tx_inputs tx))))).
change ((statefun_totalunits
           (fun alpha : addr =>
            new_assets alpha (tx_outputs tx) (hashtx tx) 0)) +
        (statefun_totalunits
           (fun alpha : addr =>
              remove_assets (f alpha) (get_spent alpha (tx_inputs tx)))) + fee =
   statefun_totalunits f + rew).
rewrite sf_totalunits_new_assets.
assert (L1:utot + (statefun_totalunits
                     (fun alpha : addr =>
                        remove_assets (f alpha) (get_spent alpha (tx_inputs tx)))) =
   statefun_totalunits f).
{ apply statefun_asset_value_in_lem.
  - exact Hf.
  - destruct tx as [inpl outpl]. destruct Ht as [Ht1a _].
    simpl. intros h alpha H3.
    destruct (statefun_supports_tx_assets_In f (inpl,outpl) fee rew alpha h Hs H3) as [obl' [v H4]].
    exists (obl',v). exact H4.
  - destruct tx as [inpl outpl]. destruct Ht as [_ Ht2b]. exact Ht2b.
  - exact H1.
}
omega.
Qed.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.AutoSep.

Set Implicit Arguments.

Lemma wordToNat_positive : forall w : W,
  ($0 < w)%word
  -> wordToNat w = S (wordToNat (w ^- $1)).
  intros.
  replace (wordToNat w) with (wordToNat ($1 ^+ (w ^- $1))) by (f_equal; words).
  rewrite wordToNat_wplus; auto.
  assert ($1 <= w)%word.
  pre_nomega.
  change (wordToNat $0) with 0 in *.
  change (wordToNat $1) with 1.
  omega.
  rewrite wordToNat_wminus; auto.
  change (wordToNat $1) with 1.
  replace (1 + (wordToNat w - 1)) with (wordToNat w); auto.
  nomega.
Qed.