Require Export ILogic ILTac ILInsts.
Require Export ImpDep.
Require Import MapNotations MapInterface.
Require Import BILogic SepAlgMap.

Module ILImp.

(* HEAP *)
Definition Heap := Map [ nat, nat ].

Fixpoint alloc (addr cells : nat) (heap : Heap) : Heap :=
  match cells with
  | 0 => heap
  | S c => add addr 0 (alloc (addr+1) c heap)
  end.

Definition dealloc (addr : nat) (heap : Heap) : Heap :=
  remove addr heap.

Definition read (addr : nat) (heap : Heap) : nat :=
  match find addr heap with
  | Some n => n
  | None => 0
  end.

Definition write (addr value : nat) (heap : Heap) : Heap :=
  match find addr heap with
  | Some _ => add addr value (remove addr heap)
  | None   => add addr value heap
  end.

(* com *)
Inductive com : Type :=
  | CSkip    : com
  | CAss     : id -> aexp -> com
  | CSeq     : com -> com -> com
  | CIf      : bexp -> com -> com -> com
  | CWhile   : bexp -> com -> com
  | CAlloc   : id -> nat -> com
  | CDealloc : aexp -> com
  | CRead    : id -> aexp -> com
  | CWrite   : aexp -> aexp -> com.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";"
  | Case_aux c "IFB" | Case_aux c "WHILE"
  | Case_aux c "ALLOC" | Case_aux c "DEALLOC" | Case_aux c "READ"
  | Case_aux c "WRITE" ].

Notation "'SKIP'" :=
  CSkip.
Notation "X '::=' a" :=
  (CAss X a) (at level 60).
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "X &= 'ALLOC' a" :=
  (CAlloc X a) (at level 80).
Notation "'DEALLOC' a" :=
  (CDealloc a) (at level 80).
Notation "X '<~' '[' a ']'" :=
  (CRead X a) (at level 80).
Notation "'[' a1 ']' '<~' a2" :=
  (CWrite a1 a2) (at level 80).

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Definition cstate := (state * Heap)%type.

Definition get opcstate : cstate :=
  match opcstate with
  | Some cs => cs
  | None    => (empty_state, empty nat)
  end.

Definition cstack (cs : cstate) : state :=
  match cs with
  | (st, _) => st
  end.

Definition cheap (cs : cstate) : Heap :=
  match cs with
  | (_, h) => h
  end.

Inductive ceval : com -> cstate -> option cstate -> Prop :=
  | E_Skip : forall st,
      SKIP / st || Some st
  | E_Ass  : forall st a1 n X,
      aeval (cstack st) a1 = n ->
      (X ::= a1) / st || Some ((update (cstack st) X n), cheap st)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || Some st' ->
      c2 / st' || Some st'' ->
      (c1 ; c2) / st || Some st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval (cstack st) b1 = true ->
      c1 / st || Some st' ->
      (IFB b1 THEN c1 ELSE c2 FI) / st || Some st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval (cstack st) b1 = false ->
      c2 / st || Some st' ->
      (IFB b1 THEN c1 ELSE c2 FI) / st || Some st'
  | E_WhileEnd : forall b1 st c1,
      beval (cstack st) b1 = false ->
      (WHILE b1 DO c1 END) / st || Some st
  | E_WhileLoop : forall st st' st'' b1 c1,
      beval (cstack st) b1 = true ->
      c1 / st || Some st' ->
      (WHILE b1 DO c1 END) / st' || Some st'' ->
      (WHILE b1 DO c1 END) / st || Some st''
  | E_Alloc : forall st X addr cells,
  	  ~ In addr (cheap st) ->
  	  (forall n, (n >= addr /\ n <= addr+cells) -> ~ In n (cheap st)) ->
  	  (X &= ALLOC cells) / st || Some (update (cstack st) X addr, alloc addr cells (cheap st))
  | E_Dealloc : forall st a1 addr,
  	  aeval (cstack st) a1 = addr ->
  	  In addr (cheap st) ->
      (DEALLOC a1) / st || Some (cstack st, dealloc addr (cheap st))
  | E_DeallocError : forall st a1 addr,
  	  aeval (cstack st) a1 = addr ->
  	  ~ In addr (cheap st) ->
      (DEALLOC a1) / st || None
  | E_Read : forall st X a1 addr n,
      aeval (cstack st) a1 = addr ->
      find addr (cheap st) = Some n ->
      (X <~ [ a1 ]) / st || Some (update (cstack st) X n, cheap st)
  | E_ReadError : forall st X a1 addr,
      aeval (cstack st) a1 = addr ->
  	  ~ In addr (cheap st) ->
      (X <~ [ a1 ]) / st || None
  | E_Write : forall st a1 a2 addr value n,
  	  aeval (cstack st) a1 = addr ->
  	  aeval (cstack st) a2 = value ->
  	  find addr (cheap st) = Some n ->
      ([ a1 ] <~ a2) / st || Some (cstack st, write addr value (cheap st))
  | E_WriteError : forall st a1 a2 addr,
  	  aeval (cstack st) a1 = addr ->
  	  ~ In addr (cheap st) ->
      ([ a1 ] <~ a2) / st || None
  where "c1 '/' st '||' st'" := (ceval c1 st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop"
  | Case_aux c "E_Alloc" | Case_aux c "E_Dealloc"
  | Case_aux c "E_DeallocError" |
  | Case_aux c "E_Read" | Case_aux c "E_ReadError"
  | Case_aux c "E_Write" | Case_aux c "E_WriteError"
  ].
(* /com *)

(* Assertions *)
Local Existing Instance ILFun_Ops.
Local Existing Instance ILFun_ILogic.
Local Existing Instance ILPre_Ops.
Local Existing Instance SABIOps.
Local Existing Instance SABILogic.

(* Assertions are an intuitionistic logic *)

Definition Assertion := ILPreFrm (@Equiv.equiv Heap _) (state -> Prop).

Instance AssertionILogic : BILogic Assertion := _.

Local Transparent ILFun_Ops.
Local Transparent ILPre_Ops.
Local Transparent SABIOps.

Definition mk_asn (f: Heap -> state -> Prop) (Hheap: forall h h' st, h === h' -> f h st -> f h' st) : Assertion.
  refine (mkILPreFrm (fun h st => f h st) _).
  simpl.
  intros.
  apply Hheap with t.
  assumption.
  assumption.
Defined.

Definition notA (P: Assertion) := P -->> lfalse.
Notation "~ x" := (notA x) : type_scope.

Definition safe c st := not (c / st || None).

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st,
       P (cheap st) (cstack st)  ->
       safe c st /\ forall st', c / st || Some st'  ->
       Q (cheap st') (cstack st').

Notation "{{ P }}  c  {{ Q }}" := (hoare_triple P c Q)
                                  (at level 90, c at next level)
                                  : hoare_spec_scope.
Open Scope hoare_spec_scope.

Global Instance hoare_triple_lentails:
  Proper (lentails --> eq ==> lentails ++> impl) hoare_triple.
Proof.
  intros P Q f c c' ceq R S RimplS H st H'.
  unfold hoare_triple in H.
  rewrite <- ceq.
  split.
  Case "safe".
    apply f in H'.
    specialize (H st H').
    inversion H.
    assumption.
    intuition.
  Case "S (cheap st') (cstack st')".
    intros.
    apply RimplS.
    intuition.
    apply f in H'.
    specialize (H st H').
    inversion H.
    apply H2.
    assumption.
    intuition.
Qed.

Global Instance hoare_triple_lequiv:
  Proper (lequiv ==> eq ==> lequiv ==> iff) hoare_triple.
Proof.
  intros P Q PiffQ c c' ceq R S RiffS.
  split.
    Case "({{P}} c {{R}}) -> {{Q}} c' {{S}}".
      intros.
      rewrite <- ceq.
      unfold hoare_triple.
      intros.
      split.
      SCase "safe".
        destruct PiffQ.
        apply H2 in H0.
        unfold hoare_triple in H.
        specialize (H st H0).
        inversion H.
        assumption.
        intuition.
      SCase "S (cheap st') (cstack st')".
        intros.
        apply RiffS.
        intuition.
        unfold hoare_triple in H.
        apply PiffQ in H0.
        specialize (H st H0).
        inversion H.
        apply H3.
        assumption.
        intuition.
    Case "({{Q}} c' {{S}}) -> {{P}} c {{R}}".
      intros.
      rewrite ceq.
      unfold hoare_triple in *.
      intros.
      split.
      SCase "safe".
        apply PiffQ in H0.
        specialize (H st H0).
        inversion H.
        assumption.
        intuition.
      SCase "R (cheap st') (cstack st')".
        intros.
        apply RiffS.
        intuition.
        apply PiffQ in H0.
        specialize (H st H0).
        inversion H.
        apply H3.
        assumption.
        intuition.
Qed.

(* Points-to, i.e. e |-> v *)
Program Definition points_to_precise a v : Assertion :=
  mk_asn (fun h st => Equiv.equiv h (add (aeval st a) (aeval st v) (empty nat))) _.
Next Obligation.
  rewrite <- H.
  assumption.
Defined.

Program Definition points_to_sub a v (X : id) n : Assertion :=
  mk_asn (fun h st => Equiv.equiv h (add (aeval (update st X n) a) (aeval (update st X n) v) (empty nat))) _.
Next Obligation.
  rewrite <- H.
  assumption.
Defined.

(* Heap membership *)
Program Definition points_to_weak a : Assertion :=
  Exists v, points_to_precise a v.

(* Heap membership *)
Program Definition in_heap a v : Assertion :=
  mk_asn (fun h st => MapsTo (aeval st a) (aeval st v) h)  _.
Next Obligation.
  rewrite <- H.
  assumption.
Defined.

Notation "a '|->' v" :=
  (points_to_precise a v) (at level 74).
Notation "e '|->_'" :=
  (points_to_weak e) (at level 74).
Notation "e '|~>' v" :=
  (in_heap e v) (at level 100).
Notation "e '|->' [ v : n // X ]" :=
  (points_to_sub e v X n) (at level 100).

(* bassn *)
Program Definition bassn b : Assertion :=
  mk_asn (fun h st => beval st b = true) _.
(* No Obligations *)

(* aexp equality *)
Program Definition aexp_eq (a1 a2 : aexp) : Assertion :=
  mk_asn (fun _ st => aeval st a1 = aeval st a2) _.
(* No Obligations *)

Program Definition aexp_eq_sub (a1 : id) (a2 : aexp) (X : id) (n : nat) : Assertion :=
  mk_asn (fun h st => aeval st (AId a1) = aeval (update st X n) a2) _.

Lemma bexp_eval_true : forall st b,
  beval (cstack st) b = true <-> (bassn b) (cheap st) (cstack st).
Proof.
  split; (intros; simpl; assumption).
Qed.

Lemma bexp_eval_false: forall st b,
  beval (cstack st) b = false <-> not ((bassn b) (cheap st) (cstack st)).
Proof.
  split.
    intros.
	unfold not.
	intros.
	congruence.

    intros.
    apply not_true_iff_false.
    assumption.
Qed.

Definition pure (P: Assertion) :=
  forall s h h', P h s <-> P h' s.

Require Export SepAlg.

Lemma convert_pure1 P Q (H: pure P) :
  P //\\ Q |-- P ** Q.
Proof.
  unfold pure in H.
  intros Pre h'' s'' H'.
  simpl in H'.
  Local Opaque MapSepAlgOps.
  simpl.
  exists sa_unit.
  exists h''.
  eexists.
  apply sa_mulC.
  apply sa_unitI.
  inversion H'.
  split.
  eapply H.
  eassumption.
  assumption.
Qed.

Lemma convert_pure2 P Q (H: pure P) (H': pure Q) :
  P ** Q |-- P //\\ Q.
Proof.
  unfold pure in *.
  intros Pre h'' s'' H''.
  simpl in H''.
  simpl.
  destruct H''.
  destruct H0.
  destruct H0.
  inversion H0.
  split.
  eapply H.
  eassumption.
  eapply H'.
  eassumption.
Qed.

Local Transparent ILFun_Ops.
Local Transparent ILPre_Ops.
Local Transparent SABIOps.

Lemma exists_aexp_eq_sub_pure : forall X v,
  pure (Exists v', aexp_eq_sub X v X v').
Proof.
  intros X v v'.
  unfold pure.
  split.
    intros.
    simpl in *.
    assumption.

    intros.
    simpl in *.
    assumption.
Qed.

Definition substitution := (id * aexp)%type.

Fixpoint substitute (ast: state) (ost: state) (subs: list (id * aexp)) : state :=
	match subs with
	| nil => ast
	| sub :: subz => substitute (ImpDep.update ast (fst sub) (aeval ost (snd sub))) ost subz
	end.

(** Hoare rules *)
Section Hoare_Rules.
Require Import MapFacts SepAlg.

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st H.
  split.
    unfold safe.
    unfold not. intros.
    inversion H0.

    intros.
    inversion H0.
    subst.
    assumption.
Qed.

Theorem hoare_seq : forall P Q R c1 c2,
     {{P}} c1 {{Q}} ->
     {{Q}} c2 {{R}} ->
     {{P}} c1;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st HP.

  split.
    unfold safe; unfold not; intros.
    inversion H; subst.

    intros.
    inversion H.

    subst.
    apply H2 with st'0.
    apply H1 with st.
    assumption.
    assumption.
    assumption.
Qed.

Program Definition assn_sub (X: id) a (Q : Assertion) : Assertion :=
  mk_asn (fun h st => Q h (ImpDep.update st X (aeval st a))) _.
Next Obligation.
  assert (Q h |-- Q h').
    apply ILPreFrm_closed.
    apply H.
  apply H1.
  assumption.
Defined.

Theorem hoare_asgn : forall Q X a,
  {{assn_sub X a Q}} (X ::= a) {{Q}}.
Proof.
  intros Q X a st Pre.
  split.
    unfold safe; unfold not; intros.
    inversion H.

    intros.
    inversion H; subst.
    simpl in *.
    assumption.
Qed.

Theorem hoare_if : forall P Q b c1 c2,
  {{P //\\ bassn b}} c1 {{Q}} ->
  {{P //\\ ~ (bassn b)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
	intros P Q b c1 c2 H1 H2 st HP.
	split.
	  unfold safe; unfold not; intros.
	  inversion H.

	  intros.
	  inversion H; subst.
	  Case "b is true".
	    apply H1 with st.
	    split; assumption.
	    assumption.
	  Case "b is false".
	    apply H2 with st.
	    split.
	      assumption.
	      simpl; intros; congruence.
	      assumption.
Qed.

Theorem hoare_while : forall P b c,
  {{P //\\ bassn b}} c {{P}} ->
  {{P}} WHILE b DO c END {{P //\\ ~ (bassn b)}}.
Proof.
  intros P b c H1 st HP.
  unfold hoare_triple in H1.
  split.
    unfold safe; unfold not; intros.
    inversion H.
  intros.
  remember (WHILE b DO c END) as wcom.
  remember (Some st') as st''.
  induction H; try (inversion Heqwcom); subst.
  inversion Heqst''.
  rewrite <- H2.
  split.
    assumption.
    simpl. intros. congruence.

  apply IHceval2.
  apply H1 with st.
  split.
    assumption.
    assumption.
  assumption.
  reflexivity.
  assumption.
Qed.

Require Export Coq.Logic.FunctionalExtensionality.

Lemma update_stack_same : forall X st n,
  ImpDep.update (ImpDep.update st X n) X (st X) = st.
Proof.
  intros.
  apply functional_extensionality.
  intros x.
  rewrite update_shadow.
  rewrite update_same.
  reflexivity.
  reflexivity.
Qed.

Theorem hoare_read : forall X e e',
  {{ (e |-> e') }} X <~ [ e ] {{ Exists v, (points_to_sub e e' X v) //\\ (aexp_eq_sub X e' X v) }}.
Proof.
  intros X e e' st Pre.
  simpl.
  split.
  Case "safe".
    unfold safe; unfold not; intros.
    inversion H; subst.
    simpl in *.
    apply H4.
    rewrite Pre.
    apply add_in_iff.
    left. reflexivity.
  Case "postcondition".
    intros.
    inversion H; subst.
    simpl in *.
    exists ((cstack st) X).
    split.
    SCase "e |-> e'".
      rewrite Pre.
      rewrite update_stack_same.
      reflexivity.
    SCase "X = e'".
      rewrite update_eq.
      rewrite update_stack_same.
      assert (Hfind: find (aeval (cstack st) e) (cheap st) = Some (aeval (cstack st) e')).
        rewrite Pre.
        intuition.
      rewrite Hfind in H5.
      inversion H5.
      reflexivity.
Qed.

Lemma remove_addedL : forall a (v : nat) (h : Heap),
 h === []%map -> Equiv.equiv (remove a (add a v h)) h.
Proof.
  intros.
  unfold Equiv.equiv, MapEquiv.
  apply Equal_mapsto_iff.
  intros.
  split.
  	intros.
  	apply remove_mapsto_iff in H0.
  	inversion H0.
  	apply add_mapsto_iff in H2.
  	inversion H2.
  	inversion H3.
  	congruence.
  	inversion H3.
  	assumption.

  	intros.
  	rewrite H in H0.
  	inversion H0.
Qed.

Lemma remove_addedR : forall a (v : nat) (h : Heap),
  h === []%map -> Equiv.equiv h (remove a (add a v h)).
Proof.
  intros a v h.
  unfold Equiv.equiv, MapEquiv.
  intros.
  apply Equal_mapsto_iff.
  intros.
  split.
  	intros.
  	rewrite H in H0.
  	inversion H0.

  	intros.
  	apply remove_mapsto_iff in H0.
  	inversion H0.
  	apply add_mapsto_iff in H2.
  	apply or_commut in H2.
  	inversion H2.
  	inversion H3.
  	assumption.
  	inversion H3.
  	congruence.
Qed.

Theorem hoare_write : forall e e',
  {{ e |->_ }} [ e ] <~ e' {{ (e |-> e') }}.
Proof.
  intros e e' st Pre.
  split.
  Case "safe".
    unfold safe; unfold not; intros.
    inversion H. subst.
    apply H4.
    simpl in Pre.
    inversion Pre.
    rewrite H0.
    apply add_in_iff.
    left.
      reflexivity.
  Case "postcondition".
    simpl in *.
    intros.
    inversion H. subst. simpl.
  	unfold write.
  	rewrite H6.
  	inversion Pre.
  	rewrite H0.
  	assert ((remove (aeval (cstack st) e) ([]) [aeval (cstack st) e <- aeval (cstack st) x]) === []%map).
        apply remove_addedL.
        reflexivity.
    rewrite H1.
    reflexivity.
Qed.

Theorem hoare_deallocate : forall e,
  {{ e |->_ }} DEALLOC e {{ empSP }}.
Proof.
  intros e st Pre.
  split.
  Case "safe".
    unfold safe; unfold not; intros.
    inversion H; subst.
    unfold not in H2.
    apply H2.
    simpl in Pre.
    inversion Pre.
    rewrite H0.
    apply add_in_iff.
    left. reflexivity.
  Case "postcondition".
    intros.
    inversion H. subst.
    simpl.
    unfold dealloc.
    split.
    SCase "[] === (remove (aeval (cstack st) e) (cheap st))".
      inversion Pre.
      simpl in H0.
      rewrite H0.
      apply remove_addedR.
      reflexivity.
    SCase "True".
      trivial.
Qed.

Lemma heap_eq : forall (h h': Heap),
  Equiv.equiv h h' = (h === h').
Proof.
  reflexivity.
Qed.

Theorem sep_hoare_consequence_pre : forall (P P' Q : Assertion) c,
  P |-- P' ->
  {{ P' }} c {{ Q }} ->
  {{ P }} c {{ Q }}.
Proof.
  unfold hoare_triple.
  intros.
  split.
  Case "safety".
    apply H in H1.
    specialize (H0 _ H1).
    apply H0.
    intuition.
  Case "".
    apply H0.
    apply H in H1.
    apply H1.
    intuition.
Qed.

(** TODO
Theorem sep_hoare_consequence_pre2 : forall (P P' Q : Assertion) c,
  {{ P' }} c {{ Q }} ->
  P |-- P' ->
  {{ P }} c {{ Q }}.
Proof.
(**
  unfold hoare_triple.
  intros.
  split.
  Case "safety".
    apply H in H1.
    specialize (H0 _ H1).
    apply H0.
    intuition.
  Case "".
    apply H0.
    apply H in H1.
    apply H1.
    intuition.*)
Admitted.*)

Theorem sep_hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{ P }} c {{ Q' }} ->
  Q' |-- Q ->
  {{ P }} c {{ Q }}.
Proof.
  unfold hoare_triple.
  intros.
  specialize (H _ H1).
  split.
  Case "left".
    apply H.
  Case "right".
    intros.
    apply H0.
    intuition.
    apply H.
    assumption.
Qed.

Fixpoint modified_by (c : com) : list id :=
  match c with
  | SKIP => nil
  | i ::= _ => i :: nil
  | c1; c2 =>  modified_by c1 ++ modified_by c2
  | IFB _ THEN c1 ELSE c2 FI => modified_by c1 ++ modified_by c2
  | WHILE _ DO c END => modified_by c
  | i &= ALLOC _ => i :: nil
  | DEALLOC _ => nil
  | i <~ [ _ ] => i :: nil
  | [ _ ] <~ _ => nil
  end.

Fixpoint list_sub (vs : list nat) (l : list id) (ost : state) (ast : state) : state :=
  match l with
    | nil => ast
    | lh :: ls =>
      match vs with
      | nil => ast
      | vsh :: vs' => list_sub vs' ls ost (substitute ast ost (cons (lh, ANum(vsh)) nil))
      end
  end.

Program Definition var_sub (R : Assertion) vs xs : Assertion :=
  mk_asn (fun h st => R h (list_sub vs xs st st)) _.
Next Obligation.
  assert( R h |-- R h').
    apply ILPreFrm_closed.
    apply H.
  apply H1.
  apply H0.
Qed.

Fixpoint existsb {X: Type} (f:X->bool) (l: list X) : bool :=
	match l with
	| nil => false
	| h :: t => orb (f h) (existsb f t)
	end.

Lemma list_sub_not_in_ids : forall ns ids a b X n,
  list_sub ns ids a b X = n /\ existsb (beq_id X) ids = false ->
  b X = n.
Proof.
  intros.
  induction ns.
  inversion H.
  simpl in H0.
  induction ids.
  assumption.
  assumption.

  apply IHns.
  split.
  inversion H.
  admit.
  (** Justification for admit:
  		Context: list_sub (a0 :: ns) ids a b X = n

  		Goal: list_sub ns ids a b X = n

  		Since we know that X = n in the state
  		list_sub (a0 :: ns) ids a b,
  		The goal should follow from the context,
  		as adding a value to the list ns
  		should have no influence on the result of
  		evaluating X with the same list of ids
  		as input.
  *)
  inversion H.
  assumption.
Qed.

Local Opaque ILFun_Ops.
Local Opaque ILPre_Ops.
Local Opaque MapSepAlgOps.

Theorem frame_rule : forall P Q R c,
  {{ P }} c {{ Q }} ->
  {{ P ** R }} c {{ Q ** (Exists vs, var_sub R vs (modified_by c )) }}.
Proof.
  induction c; unfold hoare_triple; intros; (do 4 destruct H0).
  Case "Skip".
    split.
    SCase "Safety".
      unfold safe, not.
      intros.
      inversion H2.
    SCase "Post condition".
      intros.
      simpl.
      exists x, x0.
      specialize (H ((cstack st'), x)).
      split.
      SSCase "left".
        inversion H2; subst.
      	assumption.
      SSCase "right".
      	split.
      	SSSCase "left".
      	  simpl in *.
      	  inversion H2; subst.
      	  specialize (H H0).
      	  destruct H.
      	  specialize (H3 ((cstack st'), x)).
      	  simpl in *.
      	  apply H3.
      	  apply E_Skip.
      	SSSCase "right".
          exists nil.
          simpl.
          inversion H2; subst.
          assumption.
  Case "assignment".
    split.
    SCase "Safety".
      unfold safe, not.
      intros.
      inversion H2.
    SCase "Post condition".
      intros.
      simpl in *.
      inversion H2; subst.
      exists x, x0.
      split.
      SSCase "left".
        inversion H2.
        subst.
        assumption.
      SSCase "right".
        split.
        SSSCase "left".
          specialize (H ((cstack st), x)).
          simpl in *.
          specialize (H H0).
          destruct H.
          specialize (H3 ((ImpDep.update (cstack st) i (aeval (cstack st) a)), x)).
          apply H3.
          simpl in *.
          apply E_Ass with (st := (cstack st, x)).
          reflexivity.
        SSCase "right".
      	  exists [((cstack st) i)].
      	  simpl.
      	  rewrite update_stack_same with (X := i) (n := aeval (cstack st) a).
      	  assumption.
  Case "Sequencing".
    split.
    SCase "Safety".
      unfold safe, not.
      intros.
      inversion H2.
    SCase "Post condition".
      intros.
      admit.
      (**
      Goal: (Exists x2, Exists x3,
    			sa_mul x2 x3 (cheap st') /\\
    			Q x2 //\\ (Exists vs, var_sub R vs (modified_by c1 ++ modified_by c2)) x3)
     			(cstack st')
     This should be provable from the induction hypothesis.
      *)
  Local Transparent SABIOps.
  Case "IFB".
    intros.
    unfold hoare_triple.
    intros.
    split.
    SCase "Safety".
      unfold safe, not. intros. inversion H2.
    SCase "postcondition".
      intros.
      admit.
      (**
      Goal: (Q ** (Exists vs, var_sub R vs (modified_by (IFB b THEN c1 ELSE c2 FI))))
     		(cheap st') (cstack st')

      This should be provable from the induction hypothesis.
      *)
  Case "WHILE".
    intros.
    unfold hoare_triple.
    intros.
    split.
    SCase "Safety".
      unfold safe, not. intros. inversion H2.
    SCase "postcondition".
      intros.
      specialize (H ((cstack st), x)).
      specialize (H H0).
      destruct H.
      inversion H2; subst.
      SSCase "While End".
      	exists x, x0.
      	split.
      	SSSCase "sa_mul".
      	  assumption.
      	  split.
      	  SSSSCase "left".
      		specialize (H3 ((cstack st'), x)).
      		apply H3.
      		apply E_WhileEnd.
      		assumption.
      	  SSSSCase "right".
      		simpl.
      		exists nil.
      		simpl.
      		remember (modified_by c) as modC.
      		destruct modC.
      		assumption.
      		assumption.
      SSCase "While Loop".
        admit.
        (**
        Goal: 	(Q ** (Exists vs, var_sub R vs (modified_by (WHILE b DO c END))))
     			(cheap st') (cstack st')

     	This should be provable from the induction hypothesis.
        *)
  Case "ALLOC".
    split.
    SCase "Safety".
      unfold safe, not. intros. inversion H2.
    SCase "postcondition".
      intros.
      simpl in *.
      inversion H2; subst.
      exists (alloc addr n x), x0.
      split.
      SSCase "left".
        simpl.
        admit.
        (**
        Goal:	sa_mul (alloc addr n x) x0 (alloc addr n (cheap st))

        It should be intuitively true that this goal follows from sa_mul x x0 (cheap st),
        since applying function to a heap x that is a combosite heap h should not change
        the relation between the two if the function is also applied to h. . This can be
        proven by unfolding sa_mul (with simpl) and doing case analysis on the the resul-
        ting match statements.
        *)
      SSCase "right".
        split.
        SSSCase "left".
          specialize (H ((cstack st), x)).
          simpl in *.
          specialize (H H0).
          destruct H.
          specialize (H3 ((ImpDep.update (cstack st) i addr), (alloc addr n x))).
          simpl in *.
          apply H3.
		  apply E_Alloc with (st := (cstack st, x)).
		  SSSSCase "".
		    simpl.
		    Local Transparent MapSepAlgOps.
		    simpl in x1.
		    specialize (x1 addr).
		    apply not_find_in_iff in H7.
		    rewrite H7 in x1.
		    apply x1.
		  SSSSCase "".
		    simpl.
		    intros.
		    specialize (H8 n0).
		    simpl in x1.
		    specialize (x1 n0).
		    apply not_find_in_iff in H8.
		    rewrite H8 in x1.
		    apply x1.
		    assumption.
        SSSCase "right".
          exists [((cstack st) i)].
          inversion H2; subst.
      	  simpl.
          rewrite update_stack_same.
          assumption.
  Local Opaque MapSepAlgOps.
  Case "DEALLOC".
    intros.
    unfold hoare_triple.
    intros.
    split.
    SCase "Safety".
      specialize (H ((cstack st), x)).
      simpl in *.
      specialize (H H0).
      destruct H.
      unfold safe in H.
      Local Transparent MapSepAlgOps.
      simpl in *.
      unfold safe.
      intros H3.
      apply H.
      inversion H3; subst.
      destruct st.
      simpl in *.
      specialize (x1 (aeval s a)).
      apply not_find_in_iff in H6.
      rewrite H6 in x1.
      apply E_DeallocError with (addr := (aeval s a)).
      reflexivity.
      apply x1.
    SCase "postcondition".
      Local Opaque MapSepAlgOps.
      intros.
      simpl in H0.
      simpl.
      inversion H2; subst.
      simpl.
      exists (dealloc (aeval (cstack st) a) x), x0.
      split.
      SSCase "sa_mul".
      	simpl.
        admit.
        (**
        Goal: sa_mul (dealloc (aeval (cstack st) a) x) x0 (dealloc (aeval (cstack st) a) (cheap st))

        It should be intuitively true that this goal follows from sa_mul x x0 (cheap st),
        since applying function to a heap x that is a combosite heap h should not change
        the relation between the two if the function is also applied to h. . This can be
        proven by unfolding sa_mul (with simpl) and doing case analysis on the the resul-
        ting match statements.
        *)
      SSCase "postcondition".
        split.
        SSSCase "left".
          specialize (H ((cstack st), x)).
          simpl in *.
          specialize (H H0).
          destruct H.
          specialize (H3 ((cstack st), (dealloc (aeval (cstack st) a) x))).
          simpl in *.
          apply H3.
          apply E_Dealloc with (st := (cstack st, x)).
          SSSSCase "Dealloc precondition 1".
            reflexivity.
          SSSSCase "Dealloc precondition 2".
          	simpl.
            Local Transparent MapSepAlgOps.
            simpl.
	  	    simpl in x1.
		    specialize (x1 (aeval (cstack st) a)).
    	    unfold In in H7.
		    destruct H7.
		    apply find_mapsto_iff in H4.
		    rewrite H4 in x1.
		    destruct x1.
		    unfold In.
		    exists x2.
		    apply H5.
		    unfold safe in H.
		    apply ex_falso_quodlibet.
		    apply H.
		    apply E_DeallocError with (addr := aeval (cstack st) a).
		    reflexivity.
		    simpl.
		    apply H5.
      exists nil.
      simpl.
      assumption.
  Local Opaque MapSepAlgOps.
  Case "read".
    split.
    SCase "Safety".
      specialize (H ((cstack st), x)).
      simpl in *.
      specialize (H H0).
      destruct H.
      unfold safe in H.
      Local Transparent MapSepAlgOps.
      simpl in *.
      unfold safe.
      intros H3.
      apply H.
      inversion H3; subst.
      destruct st.
      simpl in *.
      specialize (x1 (aeval s a)).
      apply not_find_in_iff in H8.
      rewrite H8 in x1.
      apply E_ReadError with (addr := aeval s a).
      reflexivity.
      apply x1.
    SCase "postcondition".
      intros.
      Local Opaque MapSepAlgOps.
      simpl.
      exists x, x0.
      split.
      SSCase "sa_mul".
        inversion H2; subst.
        simpl.
        intuition.
      SSCase "postcondition".
        split.
        SSSCase "left".
          specialize (H ((cstack st), x)).
          simpl in H.
          specialize (H H0).
          destruct H.
          inversion H2; subst.
          specialize (H3 ((ImpDep.update (cstack st) i n), x)).
          simpl in *.
          apply H3.
          apply E_Read with (st := (cstack st, x)) (addr := (aeval (cstack st) a)).
          SSSSCase "Read pre condition 1".
            simpl.
            reflexivity.
          SSSSCase "Read pre condition 2".
            simpl.
	        Local Transparent MapSepAlgOps.
	        simpl in x1.
	        specialize (x1 (aeval (cstack st) a)).
	        rewrite H9 in x1.
	        inversion x1.
	        inversion H4.
	        apply find_mapsto_iff.
	        assumption.
        unfold safe in H.
      	apply ex_falso_quodlibet.
      	apply H.
      	apply E_ReadError with (addr := (aeval (cstack st) a)).
      	reflexivity.
      	simpl.
      	apply H4.
      exists [((cstack st) i)].
      simpl.
      inversion H2; subst.
	  simpl.
	  rewrite update_stack_same.
	  assumption.
  Local Opaque MapSepAlgOps.
  Local Opaque SABIOps.
  Case "write".
    split.
    SCase "Safety".
      specialize (H ((cstack st), x)).
      simpl in *.
      specialize (H H0).
      destruct H.
      unfold safe in H.
      Local Transparent MapSepAlgOps.
      simpl in *.
      unfold safe.
      intros H3.
      apply H.
      inversion H3; subst.
      destruct st.
      simpl in *.
      specialize (x1 (aeval s a)).
      apply not_find_in_iff in H8.
      rewrite H8 in x1.
      apply E_WriteError with (addr := aeval s a).
      reflexivity.
      apply x1.
    SCase "postcondition".
      intros.
      Local Opaque MapSepAlgOps.
      simpl in *.
      exists (write (aeval (cstack st) a) (aeval (cstack st) a0) x), x0.
      split.
      SSCase "sa_mul".
        inversion H2; subst.
        simpl.
        admit.
        (**
        Goal: sa_mul (write (aeval (cstack st) a) (aeval (cstack st) a0) x) x0 (write (aeval (cstack st) a) (aeval (cstack st) a0) (cheap st))

        It should be intuitively true that this goal follows from sa_mul x x0 (cheap st),
        since applying function to a heap x that is a combosite heap h should not change
        the relation between the two if the function is also applied to h. . This can be
        proven by unfolding sa_mul (with simpl) and doing case analysis on the the resul-
        ting match statements.
        *)
      SSCase "postcondition".
        split.
        SSSCase "left".
          specialize (H ((cstack st), x)).
          specialize (H H0).
          destruct H.
          specialize (H3 ((cstack st'), (write (aeval (cstack st) a) (aeval (cstack st) a0) x))).
          apply H3.
          inversion H2; subst.
          simpl in *.
          apply E_Write with (st := (cstack st, x)) (n := n).
            reflexivity.
            reflexivity.
          simpl.
          Local Transparent MapSepAlgOps.
          simpl in x1.
          specialize (x1 (aeval (cstack st) a)).
          rewrite H10 in x1.
          inversion x1.
          inversion H4.
          apply find_mapsto_iff.
          assumption.
        unfold safe in H.
      	apply ex_falso_quodlibet.
      	apply H.
      	apply E_WriteError with (addr := (aeval (cstack st) a)).
      	reflexivity.
      	simpl.
      	apply H4.
     SSSCase "right".
	    exists nil.
      	simpl.
      	inversion H2; subst; simpl.
      	intuition.
Qed.

Program Definition alloc_cell a : Assertion :=
  (ANum a) |-> (ANum 0).

Program Fixpoint alloc_cells (a n : nat) : Assertion :=
  match n with
  | 0    => empSP
  | S n' => alloc_cell a ** alloc_cells (a+1) (n')
  end.

Local Transparent MapSepAlgOps.

Lemma conj_comp : forall (P Q : Assertion) (a b c : Heap) s,
  P a s ->
  Q b s ->
  sa_mul a b c ->
  (P ** Q) c s.
Proof.
  intros.
  simpl.
  exists a.
  exists b.
  simpl in H1.
  split.
    intros k.
    specialize (H1 k).
    destruct (find k c).
    assumption.

    assumption.

  split; assumption.
Qed.

Lemma find_in_smaller_heap : forall a k n m (h: Heap),
  find k (add a m h) = Some n ->
  a =/= k ->
  MapsTo k n h.
Proof.
  intros.
  apply find_mapsto_iff in H.
  apply add_mapsto_iff in H.
  apply or_commut in H.
  inversion H.
  inversion H1.
  assumption.
  inversion H1.
  congruence.
Qed.

Lemma not_in_smaller_heap : forall a n k (h: Heap),
  find k (add a n h) = None ->
  a =/= k ->
  not (In k h).
Proof.
  intros.
  unfold not; intros.
  apply not_find_in_iff in H.
  unfold not in H.
  apply H.
  apply add_in_iff.
  right. assumption.
Qed.

Lemma not_in_larger_heap : forall (h: Heap) a b n,
  not (In a h) ->
  a < b \/ a >= (b+n) ->
  not (In a (alloc b n h)).
Proof.
  intros.
  generalize dependent b.
  induction n.
  Case "n = 0".
    intros.
    simpl.
    assumption.
  Case "n = S n'".
    intros.
    simpl.
    unfold not; intros.
    apply add_in_iff in H1.
    inversion H1.
    inversion H2.
    inversion H0.
    omega.
    omega.
    apply IHn with (b+1).
    omega.
    assumption.
Qed.

Local Opaque ILFun_Ops.
Local Opaque ILPre_Ops.
Local Opaque SABIOps.

Theorem hoare_allocate : forall X n,
  {{ empSP }} X &= ALLOC n {{ Exists a, (aexp_eq (AId X) (ANum a) //\\ alloc_cells a n) }}.
Proof.
  intros X n st Pre.
  split.
  Case "safe".
    unfold safe; unfold not; intros.
    inversion H.
  Case "postcondition".
    intros.
    inversion H; subst.
    exists addr.
    simpl.
    split.
    SCase "aexp_eq".
      apply update_eq.

    (* Do induction on number of cells allocated *)
    SCase "alloc_cells".
      clear H.
      inversion Pre.
      simpl in *.
      generalize dependent (ImpDep.update (cstack st) X addr).
      generalize dependent addr.
      induction n.

      SSCase "n = 0".
        intros. simpl.
        assumption.

      SSCase "n = S n'".
        intros.
	    simpl.
        apply conj_comp with (a:=(add addr 0 (cheap st))) (b:=(alloc (addr+1) n (cheap st))).
        SSSCase "add addr 0 (cheap st)".
          simpl.
          rewrite x.
          reflexivity.
        SSSCase "alloc (addr+1) n (cheap st)".
          apply IHn with (addr:=addr+1).
          apply H5.
          omega.
          intros.
          unfold not; intros.
          apply H4.
          rewrite <- x in H1.
          inversion H1.
          inversion H2.
        SSSCase "sa_mul (heap composition)".
          simpl.
          intros.
          destruct (eq_dec addr k) as [H'|]. (* Divide possible addresses into addr === k and addr =/= k *)
          SSSSCase "addr === k".
            rewrite <- H'.

            assert (Hfind: find addr (add addr 0 (alloc (addr + 1) n (cheap st))) = Some 0).
              intuition.

            rewrite Hfind.
            left. split.
            SSSSSCase "MapsTo addr 0 (add addr 0 (cheap st))".
              intuition.
            SSSSSCase "~ In addr (alloc (addr + 1) n (cheap st))".
              apply not_in_larger_heap.
              assumption.
              omega.
          SSSSCase "addr =/= k".
            remember (find k (add addr 0 (alloc (addr + 1) n (cheap st)))) as h.
            destruct h.
            SSSSSCase "find k = Some n".
              right. split.
              SSSSSSCase "MapsTo k n0 (alloc (addr + 1) n (cheap st))".
                apply find_in_smaller_heap with (a:=addr) (m:=0).
		        symmetry.
		        assumption.
                assumption.
              SSSSSSCase "~ In k (add addr 0 (cheap st))".
                rewrite <- x.
                rewrite add_neq_in_iff.
                unfold not; intros.
                inversion H1. inversion H2.
                assumption.
            SSSSSCase "find k = None".
              split.
              SSSSSSCase "~ In k (add addr 0 (cheap st))".
                rewrite <- x.
                rewrite add_neq_in_iff.
                unfold not; intros.
                inversion H1. inversion H2.
                assumption.
              SSSSSSCase "~ In k (alloc (addr + 1) n (cheap st))".
                apply not_in_smaller_heap with (a:=addr) (n:=0).
                symmetry.
                assumption.
                assumption.
Qed.

End Hoare_Rules.

Section Examples.

Require Export ImpDep.

Definition X := Id 0.
Definition Y := Id 1.
Definition Z := Id 2.
Definition V := Id 3.
Definition T := Id 4.
Definition a := (ANum 0).
Definition b := (ANum 1).
Definition c := (ANum 2).
Definition d := (ANum 3).

Definition heap_swap :=
  X <~ [ a ];
  Y <~ [ b ];
  [ a ] <~ (AId Y);
  [ b ] <~ (AId X).

Local Transparent ILFun_Ops.
Local Transparent ILPre_Ops.
Local Transparent SABIOps.

Lemma exists_conj_elim : forall X a c,
  Exists v, ((points_to_sub a c X v) //\\ aexp_eq_sub X c X v) |-- (Exists v, (points_to_sub a c X v)) //\\ (Exists v', aexp_eq_sub X c X v').
Proof.
  intros.
  lexistsL.
  intros.
  lexistsR a1.
  lexistsR a1.
  reflexivity.
Qed.

Local Transparent ILFun_Ops.
Local Transparent ILPre_Ops.
Local Transparent SABIOps.

Example heap_swap_prog :
  {{ a |-> c ** b |-> d }}
  heap_swap
  {{ a |-> d ** b |-> c }}.
Proof.
  unfold heap_swap.
  eapply hoare_seq.
  apply frame_rule.
  apply hoare_read.
  rewrite sepSPC.
  eapply hoare_seq.
  apply frame_rule.
  simpl.
  apply sep_hoare_consequence_pre with (P':=b|->d).
    simpl.
    intros.
    destruct H0.
    assumption.
  apply hoare_read.

  eapply hoare_seq.
  rewrite sepSPC.
  apply frame_rule.
  assert (Exists vs, var_sub (Exists v, points_to_sub a c X v //\\ aexp_eq_sub X c X v) vs (modified_by (Y <~ [b])) |--
         (Exists v, points_to_sub a c X v //\\ aexp_eq_sub X c X v)).
    lexistsL.
    intros.
    simpl.
    intros.
    destruct H0.
    destruct H0.
    split.
    intuition.
    split.
    assumption.
    apply list_sub_not_in_ids with a0 (Y::nil) t0.
    split.
    assumption.
    reflexivity.
  rewrite H.
  rewrite exists_conj_elim.
  rewrite landC.
  rewrite convert_pure1.
  rewrite sepSPC.
  apply frame_rule.
  apply sep_hoare_consequence_pre with (P':=a |->_).
    simpl.
    intros.
    exists (ANum 2).
    destruct H1.
    simpl.
    assumption.

  apply hoare_write.
  apply exists_aexp_eq_sub_pure.

  rewrite sepSPC.
  eapply sep_hoare_consequence_post.
  apply frame_rule.
  assert (Exists vs, var_sub (Exists v, (points_to_sub b d Y v) //\\ aexp_eq_sub Y d Y v) vs (modified_by ([a]<~ AId Y)) |--
         Exists v, points_to_sub b d Y v //\\ aexp_eq_sub Y d Y v).
    simpl.
    intros.
    exists 0.
    split.
    destruct H0.
    destruct H0.
    inversion H0.
    assumption.
    inversion H0.
    destruct H1.
    inversion H1.
    apply list_sub_not_in_ids with x nil t0.
    split.
    assumption.
    reflexivity.
  rewrite H.
  rewrite exists_conj_elim.
  rewrite landC.
  rewrite convert_pure1.
  rewrite sepSPC.
  apply frame_rule.
  apply sep_hoare_consequence_pre with (P':=b |->_).
    simpl.
    intros.
    exists (ANum 3).
    simpl.
    destruct H1.
    assumption.

  apply hoare_write.
  apply exists_aexp_eq_sub_pure.
  assert ((b |-> AId X **
    (Exists vs,
     var_sub (Exists v', aexp_eq_sub Y d Y v') vs (modified_by ([b]<~ AId X)))) **
   (Exists vs,
    var_sub
      (a |-> AId Y **
       (Exists vs0,
        var_sub (Exists v', aexp_eq_sub X c X v') vs0
          (modified_by ([a]<~ AId Y)))) vs (modified_by ([b]<~ AId X))) |--
          ((b |-> AId X ** (Exists v', aexp_eq_sub Y d Y v')) ** (a |-> AId Y ** (Exists v', aexp_eq_sub X c X v')))).
    simpl.
    intros.
    do 8 (destruct H0).
    exists x, x0.
    split.
    assumption.
    split.
    exists x2, x3.
    split.
    assumption.
    split.
    assumption.
    exists 0.
    do 2 (destruct H2).
    apply list_sub_not_in_ids with x5 nil t0.
    split.
    assumption.
    reflexivity.
    do 4 (destruct H1).
    exists x6, x7.
    split.
    assumption.
    inversion H1.
    simpl in H3.
    assert (list_sub x5 nil t0 t0 Y = t0 Y).
      destruct x5.
      simpl.
      reflexivity.
      simpl.
      reflexivity.
    split.
	rewrite H5 in H3.
	assumption.
	do 2 (destruct H4).
	exists 0.
	assert (list_sub x9 nil (list_sub x5 nil t0 t0) (list_sub x5 nil t0 t0) = t0).
	  destruct x9.
	  simpl.
	  destruct x5.
	  simpl. reflexivity.
	  simpl. reflexivity.
	  simpl.
	  destruct x5.
	  simpl. reflexivity.
	  simpl. reflexivity.
	rewrite <- H6.
	assumption.
  rewrite H.
  rewrite sepSPA.
  rewrite sepSPC with (P:=a |-> AId Y).
  rewrite sepSPC with (P:=b |-> AId X).
  rewrite sepSPA.
  rewrite sepSPA.
  rewrite sepSPC with (Q:=b |-> AId X).
  rewrite sepSPC with (P:=(Exists v', aexp_eq_sub Y d Y v')).
  rewrite sepSPA2.
  rewrite sepSPA1 with (P:=(Exists v', aexp_eq_sub X c X v') ** b |-> AId X).
  rewrite sepSPC.
  apply scME.
  simpl.
  Local Transparent MapSepAlgOps.
  intros.
  destruct H1.
  destruct H1.
  destruct H1.
  inversion H1.
  destruct H3.
  rewrite H3 in H2.
  admit.
  (** Justification for admit:
  		Context: sa_mul x x0 t
  				 Equiv.equiv x ([]) [0 <- 3]%map

  		Goal: Equiv.equiv t ([]) [0 <- 3]%map

  		Since we know that 0 |-> 3 in x,
  		and x is a subheap of t,
  		and x0 is the empty heap because it is
  		the part of the heap that holds for
  		the pure assertion (Exists v', aexp_eq_sub Y d Y v'),
  		then goal Equiv.equiv t ([]) [0 <- 3]%map
  		must follow from the context.
  *)
  rewrite sepSPC.
  simpl.
  intros.
  destruct H1.
  destruct H1.
  destruct H1.
  inversion H1.
  destruct H3.
  rewrite H3 in H2.
  admit.
    (** Justification for admit:
  		Context: forall k : nat,
       				match (t) [k]%map with
       				| Some y => MapsTo k y x /\ ~ In k x0 \/ MapsTo k y x0 /\ ~ In k x
       				| None => ~ In k x /\ ~ In k x0
       				end
       			 Equiv.equiv x ([]) [1 <- 2]%map

  		Goal: Equiv.equiv t ([]) [1 <- 2]%map

  		Since we know that 1 |-> 3 in x,
  		x must be equivalent to t since
  		x0 is the part of the heap that holds for
  		the pure assertion (Exists v', aexp_eq_sub X c X v'),
  		which must be empty by definition.
  		If x is equivalent to t,
  		the goal should follow immediately from the context.
  *)
Qed.

Definition list_cell (addr elem next : aexp) : Assertion :=
  addr |-> elem ** APlus addr (ANum 1) |-> next.

Fixpoint heap_list (X : aexp) (l : list nat) : Assertion :=
  match l with
  | nil => empSP
  | x :: xs => X |-> (ANum x) **
		 	   (match xs with
		 	   | nil => APlus X (ANum 1) |-> (ANum 0)
		 	   | y :: ys => APlus X (ANum 1) |-> APlus X (ANum 2)
		 	   end) **
		 	   heap_list (APlus X (ANum 2)) xs
  end.

Definition alloc_list :=
  {{ empSP }}
  X &= ALLOC 8;
  [ (AId X) ] <~ (ANum 1);
  [ APlus (AId X) (ANum 1) ] <~ APlus (AId X) (ANum 2);
  [ APlus (AId X) (ANum 2) ] <~ (ANum 2);
  [ APlus (AId X) (ANum 3) ] <~ APlus (AId X) (ANum 4);
  [ APlus (AId X) (ANum 4) ] <~ (ANum 3);
  [ APlus (AId X) (ANum 5) ] <~ APlus (AId X) (ANum 6);
  [ APlus (AId X) (ANum 6) ] <~ (ANum 4);
  [ APlus (AId X) (ANum 7) ] <~ (ANum 0)
  {{ heap_list (AId X) (1::2::3::4::nil) }}.

Local Transparent ILFun_Ops.
Local Transparent ILPre_Ops.
Local Opaque SABIOps.

Definition list_reversal :=
  Y ::= (ANum 0);
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    V <~ [ APlus (AId X) (ANum 1) ];
  	Z <~ [ AId V ];
  	[ AId V ] <~ (AId Y);
  	Y ::= (AId X);
  	X ::= (AId Z)
  END.

Local Transparent ILFun_Ops.
Local Transparent ILPre_Ops.
Local Opaque SABIOps.

Definition l : list nat := 1::2::nil.

Program Definition l_rev l (a b : list nat) :=
  mk_asn (fun h st => rev l = (rev a) ++ b) _.

Definition list_rev_inv l (X Y : aexp) :=
  Exists a, Exists b, l_rev l a b ** heap_list X a ** heap_list Y b.

Example list_reversal_proof :
  {{ heap_list (AId X) l }}
  list_reversal
  {{ heap_list (AId Y) (rev l) }}.
Proof.
(**
  Failed List reversal proof attempts:

  unfold list_reversal.
  eapply hoare_seq.

  apply hoare_asgn.
  instantiate (1:= heap_list (AId X) l //\\ aexp_eq (AId Y) (ANum 0)).
  simpl.
  intros.
  split.
  assumption.
  reflexivity.

  eapply sep_hoare_consequence_post.
  apply sep_hoare_consequence_pre with (list_rev_inv l (AId X) (AId Y) //\\ aexp_eq (AId Y) (ANum 0)).
  unfold list_rev_inv.
  apply landR.
  apply lexistsR with l.
  apply lexistsR with nil.
  rewrite convert_pure.
  simpl.
  intros.
  split.
  reflexivity.
  inversion H0.
  simpl.
  assert ((AId X |-> ANum 1 **
     APlus (AId X) (ANum 1) |-> APlus (AId X) (ANum 2) **
     APlus (AId X) (ANum 2) |-> ANum 2 **
     APlus (APlus (AId X) (ANum 2)) (ANum 1) |-> ANum 0 ** empSP) |-- (AId X |-> ANum 1 **
     APlus (AId X) (ANum 1) |-> APlus (AId X) (ANum 2) **
     APlus (AId X) (ANum 2) |-> ANum 2 **
     APlus (APlus (AId X) (ANum 2)) (ANum 1) |-> ANum 0 ** empSP) ** empSP).
	 rewrite empSPR.
	 rewrite empSPR.
	 reflexivity.
  apply H3.
  intuition.
  assumption.
  admit.

  simpl.
  intros.
  inversion H0.
  assumption.

  apply hoare_while.
  eapply hoare_seq.
  rewrite landA.
  rewrite landC.
  rewrite <- convert_pure.
  rewrite sepSPC.
  apply frame_rule.
  unfold list_rev_inv.
  assert (Exists a0, Exists b0, l_rev l a0 b0 ** heap_list (AId X) a0 ** heap_list (AId Y) b0 |--
         Exists a, Exists a0, Exists b0, Exists k, (AId X) |-> (ANum a) ** APlus (AId X) (ANum 1) |-> k ** l_rev l (a::a0) b0 ** heap_list k a0 ** heap_list (AId Y) b0).
    lexistsR 1.
    lexistsR (2::nil).
    apply lexistsR with nil.
    lexistsR (APlus (AId X) (ANum 2)).
    simpl.
    intros.
    destruct H0.
    destruct H0.
    admit.
  rewrite H.
  assert (Exists a0,
     Exists a1,
     Exists b0,
     Exists k,
     AId X |-> ANum a0 **
     APlus (AId X) (ANum 1) |-> k **
     l_rev l (a0 :: a1) b0 ** heap_list k a1 ** heap_list (AId Y) b0 |--
     AId X |-> ANum 1 **
     APlus (AId X) (ANum 1) |-> (APlus (AId X) (ANum 2)) **
     l_rev l (1 :: (2::nil)) nil ** heap_list (APlus (AId X) (ANum 2)) (2::nil) ** heap_list (AId Y) nil).
     lexistsL.
     intros.
     lexistsL.
     intros.
     lexistsL.
     intros.
     lexistsL.
     intros.
     admit.
  rewrite H0.
  rewrite sepSPC.
  rewrite sepSPA.
  apply frame_rule.
  apply hoare_read.
  admit.

  eapply hoare_seq.
  (*here*)

  apply hoare_while with (list_rev_inv l X Y.

  eapply hoare_seq.
  rewrite landA.
  rewrite landC.
  rewrite <- convert_pure.
  rewrite sepSPC.
  apply frame_rule.
  simpl.
  rewrite <- sepSPC with (Q:=AId X |-> ANum 1).
  apply frame_rule.
  apply frame_rule.
  apply hoare_read.
  admit. (*pure*)

  eapply hoare_seq.
  simpl.
  intros.
  exists (APlus (AId X) (ANum 2)).
  simpl.
  assumption.
  apply hoare_write.

  unfold list_reversal.
  eapply hoare_seq.
  apply sep_hoare_consequence_pre with (P':=assn_sub Y (ANum 0) ((heap_list (AId X) l) //\\ aexp_eq (AId Y) (ANum 0))).
    simpl.
    intros.
    split.
    assumption.
    rewrite update_eq.
    reflexivity.
  apply hoare_asgn.
  apply sep_hoare_consequence_pre with (P':=list_rev_inv l (AId X) (AId Y)).
  unfold list_rev_inv.
  apply lexistsR with l.
  apply lexistsR with nil.
  simpl.
  intros.
  admit.
  eapply sep_hoare_consequence_post.
  apply hoare_while.
  eapply hoare_seq.
  unfold list_rev_inv.
  apply sep_hoare_consequence_pre with (P':= (l_rev (1::2::nil) (1::(2::nil)) (nil)) **
                                             (AId X) |-> (ANum 1) ** (APlus (AId X) (ANum 1)) |-> (APlus (AId X) (ANum 2)) **
                                             heap_list (APlus (AId X) (ANum 2)) (1::2::nil) ** heap_list (AId Y) (nil)).
    lexistsL.
    intros.
    lexistsL.
    intros.
    admit.

  rewrite sepSPC.
  rewrite <- sepSPC with (Q:= AId X |-> ANum 1).
  apply frame_rule'.
  apply frame_rule'.
  apply frame_rule'.
  apply hoare_read.

  eapply hoare_seq.
  apply frame_rule'.
  apply frame_rule'.
  apply frame_rule'.
  rewrite exists_conj_elim.
  rewrite landC.
  rewrite <- convert_pure.
  rewrite sepSPC.
  apply sep_hoare_consequence_pre with (P':= (AId V) |-> APlus (AId X) (ANum 2)).
    admit.
  apply hoare_read.
  admit. (*pure aexp_eq_sub*)

  eapply hoare_seq.
  apply frame_rule'.
  apply frame_rule'.
  apply frame_rule'.
  rewrite exists_conj_elim.
  rewrite landC.
  rewrite <- convert_pure.
  rewrite sepSPC.
  apply frame_rule'.
  apply sep_hoare_consequence_pre with (P':= (AId V) |->_).
    lexistsL.
    intros.
    simpl.
    intros.
    exists (APlus (AId X) (ANum 2)).
    simpl.
    rewrite update_neq in H0.
    rewrite update_neq in H0.
    assumption.
    reflexivity.
    reflexivity.

  apply hoare_write.
   admit. (*pure*)

  eapply hoare_seq.
  apply sep_hoare_consequence_pre with (P':= assn_sub Y (AId X) ((((AId V |-> AId Y **
        (Exists v', aexp_eq_sub Z (APlus (AId X) (ANum 2)) Z v')) **
       heap_list (APlus (AId X) (ANum 2)) (1::2::nil) ** heap_list (AId Y) nil) **
      AId X |-> ANum 1) ** l_rev (1::2::nil) (1::2::nil) nil)).
      admit.
  apply hoare_asgn.
  eapply sep_hoare_consequence_post.
  apply sep_hoare_consequence_pre with (P':= assn_sub X (AId Z) ((((AId V |-> AId Y **
        (Exists v', aexp_eq_sub Z (APlus (AId X) (ANum 2)) Z v')) **
       heap_list (APlus (AId X) (ANum 2)) (1::2::nil) ** heap_list (AId Y) nil) **
      AId X |-> ANum 1) ** l_rev (1::2::nil) (1::2::nil) nil)).
    admit.

  apply hoare_asgn.
  unfold list_rev_inv.
  Local Opaque ILPre_Ops.
  simpl.
    *)
Admitted.

End Examples.

End ILImp.


Require Import ExtLib.Data.Positive.
Require Import ExtLib.Data.POption.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.Views.Ptrns.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.syms.SymOneOf.
Require Import MirrorCore.Views.FuncView.

Section FuncViewSumN.
  Context {A func : Set}.

  Global Instance PartialViewPMap (p : positive) (m : OneOfType.pmap)
	 (pf : OneOfType._Some A = OneOfType.pmap_lookup' m p)
  : PartialView (OneOfType.OneOf m) A :=
  { f_insert := @OneOfType.Into m _ p (eq_sym pf)
  ; f_view   :=
      let view := @OneOfType.OutOf m _ _ (eq_sym pf) in
      fun x =>
        match view x with
        | None => pNone
        | Some x => pSome x
        end
  }.

  Variable typ : Set.
  Variable RType_typ : RType typ.

  Global Instance FuncViewOkPMap
         (p : positive) (m : OneOfType.pmap)
         (syms : RSym_All m)
	 (pf : OneOfType._Some A = OneOfType.pmap_lookup' m p)
  : FuncViewOk (PartialViewPMap p m pf) (RSymOneOf syms)
               (match eq_sym pf in _ = Z
                      return RSym match Z with
                                  | OneOfType._Some T => T
                                  | OneOfType._None => Empty_set
                                  end
                with
                | eq_refl => syms p
                end).
  Proof.
    constructor.
    { unfold f_view, f_insert; simpl.
      clear. intros.
      split.
      { consider (OneOfType.OutOf p (eq_sym pf) f); intros; try congruence.
        inversion H0; clear H0; subst.
        eauto using OneOfType.Into_OutOf. }
      { intros.
        subst.
        rewrite OneOfType.Outof_Into. reflexivity. } }
    { simpl. intros.
      unfold OneOfType.Into, RSymOneOf, func_equiv, symAs.
      intros. simpl.
      autorewrite_with_eq_rw.
      unfold symD_OneOf, typeof_sym_OneOf. simpl.
      unfold internal_eq_rew_dep, eq_rect_r, eq_rect. simpl.
      generalize (@symD typ RType_typ).
      generalize (@typeof_sym typ RType_typ).
      generalize (@type_cast typ RType_typ t).
      generalize (syms p).
      destruct pf. reflexivity. }
  Qed.

End FuncViewSumN.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj20synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus (mult lv1 (Succ (plus Zero lv2))) (Succ (plus Zero lv2)))).
Admitted.
QuickChick conj20synthconj1.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D B1 C1 P Q R V W X : Universe, ((wd_ C C1 /\ (wd_ C D /\ (wd_ D B1 /\ (wd_ C B1 /\ (wd_ B1 B /\ (wd_ B D /\ (wd_ A B /\ (wd_ A D /\ (wd_ C A /\ (wd_ B C /\ (wd_ A B1 /\ (wd_ A C1 /\ (wd_ B1 C1 /\ (wd_ B C1 /\ (wd_ D C1 /\ (wd_ P Q /\ (wd_ Q R /\ (wd_ V W /\ (wd_ W X /\ (col_ B1 C B /\ (col_ A C C1 /\ (col_ A B B1 /\ col_ B1 D C1)))))))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(******************************************************************************)
(* Some lemmas about multivalued functions that are only true if classical    *)
(* reasoning is used. This file is not exported by all_mpf and has to be      *)
(* imported separately.                                                       *)
(******************************************************************************)
From mathcomp Require Import ssreflect ssrfun.
Require Import all_mf.
Require Import Classical ChoiceFacts.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope mf_scope.
Section classical_mf.
Context (S T: Type).

Lemma mono_tot (f: S ->> T): f \is_mono -> f \is_total.
Proof.
move => inj s.
apply not_all_not_ex => all.
pose g := F2MF (fun (b: bool) => s).
pose h := @mf_empty bool S.
suff eq: g =~= h by have /=<-:= eq true s.
apply inj.
rewrite comp_F2MF comp_empty_r => q r /=.
by split => // fsr; apply (all r).
Qed.

Lemma sing_tot_mono (f: S ->> T): (f\^-1) \is_singlevalued -> f \is_total -> f \is_mono.
Proof.
move => sing tot R g h eq r s.
have [t fst]:= tot s.
have eq':= eq r t.
case: (classic (t \from (f \o g) r)) => [cmp | ncmp].
- have: s \from g r.
  + have [[s' [grs' fs't]] _]:= cmp.
    by rewrite (sing t s s').
  suff: s \from h r => //.
  move: cmp; rewrite eq'; move => [[s' [grs' fs't]] _].
  by rewrite (sing t s s').
have ngrs: ~ g r s by move => grs; apply/ncmp/comp_rcmp => //; exists s.
suff nhrs: ~ h r s => //.
by move => hrs; apply /ncmp; rewrite eq'; apply /comp_rcmp => //; exists s.
Qed.

Lemma epi_cotot (f: S ->> T): f \is_epi -> f \is_cototal.
Proof.
move => fsur t.
pose g := make_mf (fun t' b => t = t' /\ b = true).
pose h := make_mf (fun t' b => t = t' /\ b = false).
apply NNPP => notcodom.
have eq: g =~= h.
- apply (fsur bool g h) => s b.
  by split => [] [[t' [val1 val2]] prop];
   exfalso; apply notcodom; exists s; rewrite val2.1.
case: (classic (g t true)) => ass; last by apply ass.
by case: ((eq t true).1 ass).
Qed.

Lemma cotot_epi (f: S ->> T):
f \is_singlevalued -> (f \is_cototal <-> f \is_epi).
Proof.
split => [fcotot Q g h eq t q| ]; last exact: epi_cotot.
split => ass; move: (fcotot t) => [] s fst.
	suffices gfsq: (g \o f) s q.
		by move: ((eq s q).1 gfsq) => [] [] t' [] fst'; rewrite (H s t t').
	by split => [ | t' fst']; [exists t | exists q; rewrite (H s t' t)].
have hfsq: (h \o f) s q.
	by split => [ | t' fst']; [ exists t| exists q; rewrite (H s t' t) ].
by move: ((eq s q).2 hfsq) => [] [] t' [] fst'; rewrite (H s t t').
Qed.

Lemma sur_fun_sur (f: S -> T):
	f \is_surjective <-> (F2MF f) \is_epi.
Proof. rewrite F2MF_cotot -cotot_epi//; exact/F2MF_sing. Qed.
End classical_mf.

Section choice_mf.
  Context (S T: Type).

  Lemma choice_spec:
    FunctionalChoice_on S T <-> (forall (F: S ->> T), F \is_total -> exists f, f \is_choice_for F).
  Proof.
    split => [choice F /choice [f fprp] | icf R tot].
    - by exists f => s sfd; apply/fprp.
    have [ | f fprp]:= icf (make_mf R); first exact/tot.
    exists f => s; apply/fprp.
    have [t val]:= tot s.
    exists t; apply/val.
  Qed.

  Lemma exists_pchoice (F: S ->> T):
    FunctionalChoice_on S (option T) -> exists f, (pf2MF f) \tightens F.
  Proof.
    move => choice.
    pose R s ot := s \from dom F -> exists t, ot = some t /\ t \from F s.
    have [s | f fprp]:= choice R.
    - case: (classic (s \from dom F)) => [[t Fst] | fls]; first by exists (some t); exists t.
      by exists None => sfd; exfalso; apply/fls.
    exists f => s sfd; have [t [eq val]]:= fprp s sfd.
    by split => [ | t' /=]; [exists t; rewrite /= eq | rewrite eq => <-].
  Qed.

  Lemma exists_choice (F: S ->> T) (t: T):
    FunctionalChoice_on S T -> exists f, f \is_choice_for F.
  Proof.
    move => choice.
    pose R s t := forall Fs, F s Fs -> F s t.
    have [s | f tot]:= choice R; last by exists f => s [fs fsfs]; apply/tot/fsfs.
    case: (classic (s \from dom F)) => [[] t' fst | false]; first by exists t'.
    by exists t => t' fst'; exfalso; apply false; exists t'.
  Qed.

  Lemma fun_spec (f: S ->> T) (t: T):
    FunctionalChoice_on S T -> f \is_function <-> f \is_singlevalued /\ f \is_total.
  Proof.
    move => choice.
    split => [ [g eq] | [sing tot]].
    - by split; rewrite -eq; [apply F2MF_sing | apply F2MF_tot].
    have [ | g icf]//:= exists_choice f t.
    by exists g; apply/sing_tot_F2MF_icf.
  Qed.

  Lemma icf_tight (g f: S ->> T):
    FunctionalChoice_on S T ->
    (forall s, exists t', ~ f s t')
    -> (forall h, (h \is_choice_for g -> h \is_choice_for f)) -> (g \tightens f).
  Proof.
    move => choice ex prop s sfd.
    split => [ | t' gst'].
    - have [t' nfst']:= (ex s).
      pose g' := make_mf (fun x y => (x <> s -> g x y) /\ (x = s -> y = t')).
      have [ | h icf']// := (exists_choice g' t').
      apply NNPP => nex.
      have ngst': ~g s t' by move => gst'; apply nex; exists t'.
      have icf: h \is_choice_for g.
      + move => s' [t'' gs't''].
	case (classic (s' = s)) => [eq | neq].
	* by exfalso; apply nex; exists t''; rewrite -eq.
	have g's't'': g' s' t'' by split => // eq; exfalso; apply neq.
        by apply/((icf' s' _).1 neq); exists t''.
      suffices eq: h s = t' by apply nfst'; rewrite -eq; apply: (prop h icf s).
      have g'st': g' s t' by trivial.
      by apply/(icf' s _).2; first exists t'.
    pose g' := make_mf (fun x y => g x y /\ (x = s -> y = t')).
    have gtg: g' \tightens g.
    - move => x xfd.
      split => [ | y g'xy]; last by apply g'xy.1.
      case (classic (x = s)) => [ eq | neq ]; first by exists t'; rewrite eq.
      by have [y gxy]:= xfd; exists y; by split.
    have [ | h icf'] //:= (exists_choice g' t').
    have icf: h \is_choice_for g.
    - apply icf_spec.
      apply/ tight_trans; first by apply/ gtg.
      by apply icf_spec; apply icf'.
    suffices val: h s = t' by rewrite -val; apply/ (prop h icf s _).
    have val': g s t' /\ (s = s -> t' = t') by split.
    by apply: (icf' s _).2; first exists t'.
  Qed.
End choice_mf.

Lemma pfun_spec S T (f: S ->> T): FunctionalChoice_on S (option T) ->
  f \is_partial_function <-> f \is_singlevalued.
Proof.
  move => choice.
  split => [[g <-] | sing]; first exact/pf2MF_sing.
  pose F:= make_mf (fun s t =>
    (exists t', t = Some t' /\ f s t') \/ (~ s \from dom f /\ t = None)).
  have [ | g icf]//:= exists_choice F None.
  have: F \is_total => [s' | tot].
  - case: (classic (s' \from dom f)) => [[fs' fs'fs'] | neg]; last by exists None; right.
    by exists (Some (fs')); left; exists fs'.
  exists g => s t /=.
  case E: (g s) => [gs |].
  - have [[t' []] | []]:= icf s (tot s); last by rewrite E.
    by rewrite E => [[<- fsgs]]; split => [<- | fst]//; apply/sing/fst.
  by split => // fst; have [[t' []] | [ndm _]]:= icf s (tot s); [rewrite E |apply ndm; exists t].
Qed.


From Coq Require Import
  Strings.String
  Lists.List
.

From PlutusCert Require Import
  Language.PlutusIR
  Util.List
  .

Import NamedTerm.
Import ListNotations.

Open Scope bool_scope.

Inductive binder_info :=
  | let_bound : Strictness -> binder_info
  | lambda_bound
.

Definition ctx := list (string * binder_info).

Inductive is_error : Term -> Prop :=
  | IsError : forall T,
      is_error (Error T).

Inductive value : Term -> Prop :=
  | V_LamAbs : forall x T t0,
      value (LamAbs x T t0)
  | V_TyAbs : forall X K t,
      value (TyAbs X K t)
  | V_IWrap : forall F T v,
      value v ->
      ~ is_error v ->
      value (IWrap F T v)
  | V_Constant : forall u,
      value (Constant u)
  | V_Error : forall T,
      value (Error T)
.

(* Pure terms include values or variables that are known to be bound to values *)
Inductive is_pure (Γ : ctx) : Term -> Type :=

  | is_pure_value : forall t,
      value t ->
      ~(is_error t) ->
      is_pure Γ t

  | is_pure_var_let : forall x,
      Lookup x (let_bound Strict) Γ ->
      is_pure Γ (Var x)

  | is_pure_var_lambda : forall x,
      Lookup x lambda_bound Γ ->
      is_pure Γ (Var x)
.

Definition is_errorb (t : Term) : bool :=
  match t with
    | Error _ => true
    | _       => false
  end.

Lemma is_errorb_not_is_error : forall t,
  is_errorb t = false -> ~ is_error t.
Proof.
  intros t H.
  destruct t; intros H1; inversion H1.
  inversion H.
Qed.

(* An approximation of bindings that are pure, they will not diverge when evaluated *)
Inductive pure_binding (Γ : ctx) : Binding -> Prop :=

  | pb_term_non_strict : forall vd t,
      pure_binding Γ (TermBind NonStrict vd t)

  | pb_term_strict_val : forall vd t,
      is_pure Γ t ->
      pure_binding Γ (TermBind Strict vd t)

  | pb_data : forall dtd,
      pure_binding Γ (DatatypeBind dtd)

  | pb_type : forall tvd ty,
      pure_binding Γ (TypeBind tvd ty)
.


(*
  Author(s):
    Felix Jahn (1)
    Yannick Forster (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

Require Export Undecidability.Axioms.EA.
Require Export Undecidability.Shared.Pigeonhole.
Require Export Undecidability.Shared.FinitenessFacts.
Require Export Undecidability.Synthetic.reductions Undecidability.Synthetic.truthtables.
Require Export Undecidability.Synthetic.DecidabilityFacts Undecidability.Synthetic.EnumerabilityFacts Undecidability.Synthetic.SemiDecidabilityFacts.
Require Export Undecidability.Shared.ListAutomation.
Require Export Undecidability.Synthetic.simple.
Require Export Undecidability.Shared.embed_nat.
Require Export List Arith.

Export EmbedNatNotations.

Local Notation "q << p" := (forall x, q x -> p x) (at level 50).

Lemma proof_computation {X} (p : X -> Prop) f:
 enumerator f p -> (exists y, p y)
  -> exists n y, f n = Some y.
Proof.
  intros E [y [n py] % E].
  eauto.
Qed.

Definition mu_enum_NN_sig {X} (p : X -> Prop) f:
  enumerator f p -> ex p ->
    {n | (exists x, f n = Some x) /\
      (forall n1, (exists x1, (f n1) = Some x1) -> n <= n1) }.
Proof.
  intros E H.
  assert (exists n x, f n = Some x) by exact (proof_computation p f E H).
  eapply mu_nat_dep_least in H0 as (? & ?).
  - exists x. firstorder. eapply H2. lia. eauto.
  - intros n. destruct (f n).
    + left. eauto.
    + right. intros []. inversion H1.
Defined.

Definition mu_enum_NN {X} (p: X -> Prop) f E H : nat
:= proj1_sig (mu_enum_NN_sig p f E H).

Definition mu_enum_NN_spec {X} (p: X -> Prop) f E H
:= proj2_sig (mu_enum_NN_sig p f E H).

Definition mu_enum_sig {X} (p : X -> Prop) f :
forall E H, {x | p x /\ Some x = f (mu_enum_NN p f E H)}.
Proof.
intros E H.
- destruct (f (mu_enum_NN p f E H)) eqn: H2.
  + exists x.
    intuition. apply E. eauto.
  + exfalso. remember (mu_enum_NN_spec p f E H). destruct a as [[x a1] a2].
    unfold mu_enum_NN in H2. rewrite a1 in H2. discriminate.
Defined.

Definition mu_enum {X} (p: X -> Prop) f E H : X
:= proj1_sig (mu_enum_sig p f E H).

Definition mu_enum_spec {X} (p: X -> Prop) f E H
:= proj2_sig (mu_enum_sig p f E H).

Definition wo_enum_sig {X} (p : X -> Prop) f:
  enumerator f p -> (exists x, p x) -> {x | p x}.
Proof.
  intros E H. destruct (mu_enum_sig p f E H).
  exists x. intuition.
Defined.

Lemma constant_mu_enum_NN {X} (p : X -> Prop) f E:
  forall H1 H2, mu_enum_NN p f E H1 = mu_enum_NN p f E H2.
Proof.
  intros H1 H2.
  set (W1:= mu_enum_NN_spec p f E H1).
  set (W2:= mu_enum_NN_spec p f E H2).
  destruct W1 as [p1 L1], W2 as [p2 L2].
  specialize (L2 (mu_enum_NN p f E H1)).
  specialize (L1 (mu_enum_NN p f E H2)).
  apply L2 in p1. apply L1 in p2.
  unfold mu_enum_NN in *. lia.
Qed.

Lemma mu_enum_agree {X} (p : X -> Prop) f E H:
  f (mu_enum_NN p f E H) = Some (mu_enum p f E H).
Proof.
  remember (mu_enum_spec p f E H). cbn in a. destruct a as [a1 a2].
  unfold mu_enum. rewrite a2. trivial.
Qed.

Lemma constant_mu_enum {X} (p : X -> Prop) f E:
  forall H1 H2, mu_enum p f E H1 = mu_enum p f E H2.
Proof.
  intros H1 H2.
  assert
    (Some (mu_enum p f E H1) = Some (mu_enum p f E H2)).
  - rewrite <- (mu_enum_agree p f E H1).
    rewrite <- (mu_enum_agree p f E H2).
    rewrite (constant_mu_enum_NN p f E H1 H2).
    trivial.
  - inversion H. trivial.
Qed.

Section ComplToBound.

  Definition complToBound L b : list nat
    := filter (fun x => Dec (~ In x L)) (seq 0 (S b)).

  Lemma complToBound_Bound L b :
    forall x, In x (complToBound L b) -> x <= b.
  Proof.
    intros x [H % in_seq ?] % in_filter_iff. lia.
  Qed.

  Lemma filter_length {X} f (l : list X) :
    length l = length (filter f l) + length (filter (fun x => (negb (f x))) l).
  Proof.
    induction l; cbn.
    - reflexivity.
    - destruct f; cbn; lia.
  Qed.

  Lemma filter_NoDup {X} f (l : list X) :
    NoDup l -> NoDup (filter f l).
  Proof.
    induction 1; cbn.
    - econstructor.
    - destruct f; eauto. econstructor; auto.
      intros ? % in_filter_iff. firstorder.
  Qed.

  Lemma complToBound_length L b:
    length (complToBound L b) + length L >= S b.
  Proof.
    rewrite <- (seq_length (S b) 0).
    erewrite filter_length with (l := seq 0 (S b)).
    unfold complToBound.
    eapply plus_le_compat_l.
    generalize (seq_NoDup (S b) 0).
    generalize (seq 0 (S b)). clear.
    intros. erewrite filter_ext with (g := fun x => Dec (In x L)).
    2:{ intros a. destruct Dec; cbn; destruct Dec; firstorder congruence. }
    eapply NoDup_incl_length. now eapply filter_NoDup.
    clear. induction l; cbn.
    - firstorder.
    - destruct Dec; cbn. 2: eauto.
      intros ? [-> | ]; eauto.
  Qed.

  Lemma complToBound_NoDup L b:
    NoDup (complToBound L b).
  Proof.
    eapply filter_NoDup, seq_NoDup.
  Qed.

  Lemma firstn_In {X} (l : list X) n x : In x (firstn n l) -> In x l.
  Proof.
    induction n in x, l |- *; destruct l; cbn; firstorder.
  Qed.

  Lemma firstn_NoDup {X} (l : list X) n : NoDup l -> NoDup (firstn n l).
  Proof.
    induction 1 in n |- *; destruct n; cbn; try now econstructor.
    econstructor; eauto.
    now intros ? % firstn_In.
  Qed.

End ComplToBound.

Section fix_ct.

  (* Assuming enumerator of semidecidable predicates W and its semidecidability *)

  (* Variable W : nat -> nat -> Prop.  *)
  Lemma es : forall p : nat -> Prop, semi_decidable p <-> exists c, forall x, W c x <-> p x.
  Proof.
    intros p. rewrite <- enum_iff, W_spec. firstorder.
  Qed.

  Variable W_SDec: nat * nat -> nat -> bool.
  Variable W_semidecider: semi_decider W_SDec (fun '(c,x) => W c x).

  Variable c_top : nat.
  Variable c_top_spec: forall x, W c_top x.

  (* Auxiliary Predicate C *)

  Definition C : (nat*nat) -> Prop
    := fun '(c,x) => W c x /\ x > 2*c.

  Lemma C_nonempty:
    C (c_top, 1 + 2 * c_top).
  Proof.
    split.
    - apply c_top_spec.
    - lia.
  Qed.

  Definition C_SDec: (nat*nat) -> nat -> bool
    := fun '(c,x) n => andb (W_SDec (c,x) n) (2*c <? x).

  Lemma C_semidecider:
    semi_decider C_SDec C.
  Proof.
    intros [c x].
    split.
    - intros [Wcx E].
      apply (W_semidecider(c,x)) in Wcx as [n Wcx].
      exists n.
      apply leb_correct_conv in E. unfold C_SDec. rewrite Nat.ltb_antisym, Wcx, E. firstorder.
    - intros [n Ccx].
      apply RelationClasses.eq_Symmetric, Bool.andb_true_eq in Ccx as [H1 H2].
      split.
      + apply (W_semidecider (c,x)). exists n. firstorder.
      + apply leb_complete_conv.
        rewrite Nat.leb_antisym.
        rewrite <- H2. firstorder.
  Qed.

  Definition iso_three_nat_func : nat -> (nat * nat) * nat
    := fun! ⟨n1, n2⟩ => (unembed n1, n2).

  Definition surjective {X} {Y} (f : X -> Y) := forall y, exists x, f x = y.

  Lemma iso_three_nat_func_spec:
    surjective iso_three_nat_func.
  Proof.
    intros [[n1 n2] n3].
    exists ⟨ ⟨n1,n2⟩, n3⟩.
    unfold iso_three_nat_func.
    now rewrite !embedP.
  Qed.
(*
  Definition C_Enum: nat -> nat * nat
    := enum_To_StrongenumF (semidec_To_enumF C_SDec iso_three_nat_func) (c_top, 1 + 2 * c_top).
 *)

  Lemma C_strong_enumerator:
    ∑ C_Enum, strong_enumerator C_Enum C.
  Proof.
    eexists.
    eapply enumerator_strong_enumerator with (x0 := (c_top, 1 + 2 * c_top)).
    - exact C_nonempty.
    - eapply semi_decider_enumerator. exact _. exact C_semidecider.
  Qed.

  Definition C_Enum := proj1_sig C_strong_enumerator.
  Definition C_enumerator : strong_enumerator C_Enum C := proj2_sig C_strong_enumerator.

  Definition DomC : nat -> Prop
    := fun c => exists x, C (c,x).

  Lemma DomC_nonempty: DomC c_top.
  Proof.
    exists (1+2*c_top).
    exact C_nonempty.
  Qed.

  Definition DomC_Enum : nat -> nat
    := fun n => fst (C_Enum n).

  Lemma DomC_enumerator:
    strong_enumerator DomC_Enum DomC.
  Proof.
    intros c; split; unfold DomC_Enum.
    - intros [x H]. apply C_enumerator in H as [n H].
      exists n. rewrite H. trivial.
    - intros [n H]. exists (snd (C_Enum n)). rewrite <- H.
      apply C_enumerator. exists n. apply surjective_pairing.
  Qed.

  Definition RangeC c : nat -> Prop
    := fun x => C(c,x).

  Definition RangeC_Enum c : nat -> option nat
    := fun n => match C_Enum n with (c1,x) => if c =? c1 then Some x else None end.

  Lemma RangeC_Enum_spec c:
    enumerator (RangeC_Enum c) (RangeC c).
  Proof.
    intros x. split.
    - intros Ccx. unfold RangeC in Ccx. apply C_enumerator in Ccx as [n Ccx].
      exists n. unfold RangeC_Enum. rewrite Ccx.
      now rewrite Nat.eqb_refl.
    - intros [n H]. apply C_enumerator.
      exists n. unfold RangeC_Enum in H.
      destruct (C_Enum n) as [c1 x1].
      destruct (Nat.eqb_spec c c1).
      + rewrite e. now inversion H.
      + discriminate.
  Qed.

  (* Definition of psi via recursive mu-operator for enumerable predicates *)

  Definition psi: forall c, DomC c -> nat .
  Proof.
    intros c H.
    apply (mu_enum (fun x => C (c,x)) (RangeC_Enum c)).
    - apply RangeC_Enum_spec.
    - exact H.
  Defined.

  Lemma psi_spec c H:
     C (c,psi c H).
  Proof.
    eapply (mu_enum_spec (fun x => C (c,x))).
  Qed.

  Lemma psi_spec1 c H:
    psi c H > 2*c.
  Proof.
    exact (proj2 (psi_spec c H)).
  Qed.

  Lemma psi_PI c H1 H2:
    psi c H1 = psi c H2.
  Proof.
    apply (constant_mu_enum (fun x => C (c, x)) (RangeC_Enum c)
    (RangeC_Enum_spec c) H1 H2).
  Qed.

  (* Definition of the simple predicate S as the range of psi *)

  Definition S : nat -> Prop
    := fun x => exists c H, psi c H = x.

  (* S is semidecidable *)

  Definition DomC_proof n: DomC (DomC_Enum n).
  Proof.
    apply DomC_enumerator.
    eauto.
  Qed.

  Definition S_Enum : nat -> nat
    := fun n => let c := DomC_Enum n in
                  let H := DomC_proof n in
                     psi c H.

  Lemma S_enumerator:
    strong_enumerator S_Enum S.
  Proof.
    intros x.
    split.
    - intros [c [H E]].
      assert (exists n, DomC_Enum n = c) as [n H1].
      apply DomC_enumerator. exact H.
      exists n. unfold S_Enum.
      revert E. revert H. rewrite <- H1. intros H E.
      rewrite <- E.
      exact (psi_PI (DomC_Enum n) (DomC_proof n) H).
    - intros [n H].
      unfold S_Enum in H.
      exists (DomC_Enum n).
      exists (DomC_proof n).
      exact H.
  Qed.

  Corollary S_SemiDec:
    semi_decidable S.
  Proof.
    eapply enumerable_semi_decidable. eapply discrete_iff. econstructor. exact _.
    enough (strongly_enumerable S) as ? %  enumerable_strongly_enumerable_iff by tauto.
    exists S_Enum. exact S_enumerator.
  Qed.

  (* Complement of S contains no semidecidable, infinite subset *)

  Lemma S_No_S_Inf_Subset:
    forall (q: nat -> Prop), ~ exhaustible q -> semi_decidable q -> ~ (q << (compl S)).
  Proof.
    intros q Inf [c Se] % es H.
    apply Inf.
    exists (seq 0 (1+2*c)).
    intros x qx.
    assert (x <= 2*c).
    - destruct (Nat.le_gt_cases x (2*c)).
      + exact H0.
      + exfalso.
        assert (exists x, C (c,x)).
        * exists x. split. apply Se, qx. exact H0.
        * assert (exists x0, q x0 /\ S x0) as [x0 [qx0 Sx0]].
          { exists (psi c H1). split.
            - apply Se. apply psi_spec.
            - exists c. exists H1. trivial.
          }
          apply (H x0 qx0), Sx0.
    - apply in_seq. lia.
  Qed.

  (* Co-Infinity Proof of S *)

  Lemma DomC_pullback n L:
    (forall x, In x L -> S x /\ x <= 2 * n) -> forall x, In x L
      -> exists c H, psi c H = x /\ c < n.
  Proof.
    intros H1 x [[c [H Sx]] E] % H1.
    exists c. exists H. intuition. rewrite <- Sx in E.
    assert (psi c H > 2 * c) by apply psi_spec1.
    lia.
  Qed.

  Lemma DomC_pullback_list n L:
    NoDup L -> (forall x, In x L -> S x /\ x <= 2 * n) ->
      exists (LC: list nat), NoDup LC /\ length LC = length L /\
        forall c, In c LC -> exists H, In (psi c H) L /\ c < n.
  Proof.
    intros ND Sub.
    induction L.
    - exists nil.
      intuition.
    - remember (DomC_pullback n (a::L) Sub a).
      assert (In a (a::L)) as H0 by intuition .
      apply e in H0 as [c0 [H0 [E1 E2]]].
      assert (NoDup L) by (inversion ND; intuition).
      apply IHL in H as [LC H].
      exists (c0::LC).
      intuition.
      + constructor. intros In. apply H3 in In as [H0' E].
        assert (a = psi c0 H0') by (rewrite <- E1; exact (psi_PI c0 H0 H0')).
        rewrite <- H2 in E. inversion ND. intuition. exact H1.
      + cbn. rewrite H. trivial.
      + destruct H2.
        * rewrite <- H2.  exists H0. rewrite E1. intuition.
        * apply H3 in H2 as [H4 E]. exists H4. intuition.
      + intros y In1. assert (In y (a::L)) by intuition.
        apply Sub in H1. exact H1.
  Qed.

  Lemma S_List_Bound n L:
    NoDup L -> (forall x, In x L -> S x /\ x <= 2 * n)
      -> length L <= n.
  Proof.
    intros ND [LC H] % DomC_pullback_list; intuition.
    rewrite <- H.
    assert (incl LC (seq 0 n)).
    - intros c [_ [_ H3]] % H2. apply in_seq. lia.
    - apply pigeonhole_length in H1.
      + now rewrite seq_length in H1.
      + intros. decide (x1 = x2); tauto.
      + exact H0.
  Qed.

  (* Listing of predicates up to a bound b *)

  Definition PredListTo p : list nat -> nat -> Prop
    := fun L b => forall x, In x L <-> p x /\ x <= b.

  Lemma PredListTo_spec {p L b}:
    PredListTo p L b -> forall x, In x L -> p x /\ x <= b.
  Proof.
    intros H x I % H.
    apply I.
  Qed.

  Lemma PredListTo_Bound {p L b}:
    PredListTo p L b -> forall x, In x L -> x <= b.
  Proof.
    intros H x I % H.
    apply I.
  Qed.

  Lemma NoDupBoundH {L} b:
    NoDup L -> (forall x, In x L -> x <= b) -> forall x, x > b -> NoDup (x::L).
  Proof.
    intros ND H x E.
    constructor.
    - intros H1 % H. lia.
    - exact ND.
  Qed.

  Lemma PredNoDupListTo_NNExist p:
    forall b, ~~ exists L, PredListTo p L b /\ NoDup L.
  Proof.
    induction b; intros H.
    - ccase (p 0) as [H0 | H0]; apply H.
      + exists [0]. split; try split.
        * intros [E | E]; (try contradiction E).
          rewrite <- E. intuition.
        * intros E. assert (x = 0) by lia.
          rewrite H1. intuition.
        * constructor; intuition; constructor.
      + exists nil. split; try split.
        * contradiction.
        * intros E. assert (x = 0) by lia.
          rewrite H1 in E. firstorder.
        * constructor.
    - apply IHb. intros [L H1].
      ccase (p (1 + b)) as [H0 | H0]; apply H.
      + exists ((1+ b) :: L). split; try split.
        * intros [E | E]; try (rewrite <- E; intuition).
          apply H1 in E. intuition.
        * intros [E1 E2]. assert (x <= b \/ x = 1 + b) as [E | E] by lia.
          ** right. apply H1. intuition.
          ** left. lia.
        * apply (NoDupBoundH b).
          ** apply H1.
          ** intros x H3 % H1. lia.
          ** lia.
      + exists L. split; try split.
        * intros E % H1. intuition.
        * intros [E1 E2]. assert (x <= b \/ x = 1 + b) as [E | E] by lia.
          ** apply H1. intuition.
          ** rewrite E in E1. firstorder.
        * apply H1.
  Qed.

  Lemma complToBound_compl p L b:
    PredListTo p L b -> PredListTo (compl p) (complToBound L b) b.
  Proof.
    intros H x. split.
    - intros [H1 H1'] % in_filter_iff.
      destruct Dec; cbn in H1'; try congruence.
      enough (x <= b).
      + intuition. intros npx. firstorder.
      + apply in_seq in H1. lia.
    - intros [H1 H2]. eapply in_filter_iff. split.
      + apply in_seq; lia.
      + destruct Dec; cbn; try tauto. exfalso. firstorder.
  Qed.

  (* Length of listings of S up to 2*n is bounded by n *)

  Lemma S_Listing:
    forall n, ~~ exists L, NoDup L /\ length L <= n /\ PredListTo S L (2*n).
  Proof.
    intros n H. apply (PredNoDupListTo_NNExist S (2*n)).
    intros [L H1]. apply H. exists L; intuition.
    apply S_List_Bound.
    - exact H2.
    - apply H0.
  Qed.

  (* Weak Existence Infinite Criterion *)

  Lemma ComplS_Listing:
  forall (n: nat) ,~~ exists L, length L >= n /\ NoDup L
                                /\ forall x, In x L -> ~ S x.
  Proof.
    intros n H.
    apply (S_Listing n). intros [L H1].
    apply H. exists (complToBound L (2*n)). repeat split.
    - remember (complToBound_length L (2*n)). lia.
    - apply complToBound_NoDup.
    - intros x I % (complToBound_compl S); intuition.
  Qed.

  Lemma S_coInfinite:
    ~ exhaustible (compl S).
  Proof.
    eapply weakly_unbounded_non_finite.
    intros n H. eapply ComplS_Listing with (n := n).
    intros (l & ? & ? & H2).
    eapply H.
    exists (firstn n l).
    repeat split.
    - rewrite firstn_length. lia.
    - now eapply firstn_NoDup.
    - intros ? ? % firstn_In. now eapply H2.
  Qed.

  (* S is a simple predicate *)

  Corollary S_simple:
    simple S.
  Proof.
    split.
    - eapply semi_decidable_enumerable; eauto. exact S_SemiDec.
    - split.
      + exact S_coInfinite.
      + intros (? & ? % enumerable_semi_decidable & ? & ?); eauto.
        eapply S_No_S_Inf_Subset; eauto.
  Qed.

End fix_ct.

Section S_Star.
  Import  Coq.Init.Nat.

  Variable W_SDec: nat * nat -> nat -> bool.
  Variable W_semidecider: semi_decider W_SDec (fun '(c,x) => W c x).

  Variable c_top : nat.
  Variable c_top_spec: forall x, W c_top x.

  Definition S' : nat -> Prop
    := S W_SDec W_semidecider c_top c_top_spec.

  (* Auxiliary List *)

  Definition S_Pow n : list nat
    := seq (2^n - 1) (2^n).

  Lemma pow_pos n:
    2^n > n.
  Proof.
    induction n; cbn; lia.
  Qed.

  Lemma pow_sum n:
    2 ^ n - 1 + 2 ^ n = 2 ^ (1 + n) - 1.
  Proof.
    induction n; cbn in *; lia.
  Qed.

  Lemma S_Pow_injective x n1 n2:
    In x (S_Pow n1) /\ In x (S_Pow n2) -> n1 = n2.
  Proof.
    intros [H1 H2].
    apply in_seq in H1. apply in_seq in H2.
    assert (n1 = n2 \/ 1 + n1 <= n2 \/ 1 + n2 <= n1) by lia.
    destruct H as [H | [H | H]].
    - exact H.
    - assert (2 ^ (1 + n1) - 1 <= x).
      + enough (2 ^ (1 + n1) <= 2 ^ n2) by lia.
        apply Nat.pow_le_mono_r; lia.
      + assert (2 ^ n1 - 1 + 2 ^ n1 = 2 ^ (1 + n1) - 1) by apply pow_sum.
        lia.
    - assert (2 ^ (1 + n2) - 1 <= x).
      + enough (2 ^ (1 + n2) <= 2 ^ n1) by lia.
        apply Nat.pow_le_mono_r; lia.
      + assert (2 ^ n2 - 1 + 2 ^ n2 = 2 ^ (1 + n2) - 1) by apply pow_sum.
        lia.
  Qed.

  (* Definition S* *)

  Definition S_Star : nat -> Prop
    := fun x => S' x
                  \/ exists n, (fun '(c,x0) => W c x0) (unembed n)
                                /\ In x (S_Pow n).

  Definition S_Star_compl : nat -> Prop
    := fun x => (compl S') x /\ ~ exists n, ((fun '(c,x0) => W c x0) (unembed n)
                                              /\ In x (S_Pow n )).

  Lemma S_Star_comp_agree:
    forall x, (compl S_Star) x <-> S_Star_compl x.
  Proof.
    intros x. unfold S_Star_compl,  S_Star, compl, not. now rewrite Decidable.not_or_iff.
  Qed.

  (* S* is semidecidable *)

  Lemma S_Star_semidec:
    semi_decidable S_Star.
  Proof.
    apply semi_decidable_or.
    - apply S_SemiDec.
    - eapply semi_decidable_ex.
      eapply semi_decidable_and.
      + exists (fun pa n => W_SDec (unembed (fst pa)) n).
        intros [n0 x0]; specialize (W_semidecider (unembed n0)); firstorder.
      + apply decidable_semi_decidable. eapply dec_decidable.
        intros pa. exact _.
  Qed.

  (* Complement of S* contains no semidecidable, infinite subset *)

  Lemma S_Star_No_S_Inf_Subset:
    forall (q: nat -> Prop), ~ exhaustible q -> semi_decidable q -> ~ (q << (compl (S_Star))).
  Proof.
    intros q H1 H2 H3.
    eapply (S_No_S_Inf_Subset).
    - exact H1.
    - exact H2.
    - intros x qx % H3.
      intros nSx. apply qx. left. exact nSx.
  Qed.

  (* Co-Infinite Proof of S* *)

  Lemma W_empty: exists c_bot, forall x, ~ W c_bot x.
  Proof.
    destruct (es (fun _ => False)) as [[c_bot]_].
    - exists (fun _ _ => false). red. firstorder congruence. congruence.
    - exists c_bot. firstorder.
  Qed.

  Lemma W_CoInfinite:
    ~ exhaustible (compl (fun '(c,x) => W c x)).
  Proof.
    destruct W_empty as [c_bot H].
    eapply unbounded_non_finite.
    intros n.
    exists (map (fun x => (c_bot, x)) (seq 0 n)).
    repeat split.
    - now rewrite map_length, seq_length.
    - eapply NoDup_map. now intros ? ? [= ->]. eapply seq_NoDup.
    - intros [? ?] (? & [= <- <-] & ? % in_seq) % in_map_iff. eapply H.
  Qed.

  Lemma WNat_CoInfinite:
    ~ exhaustible (compl (fun n => (fun '(c,x) => W c x) (unembed n))).
  Proof.
    destruct W_empty as [c_bot H].
    eapply unbounded_non_finite.
    intros n.
    exists (map (fun x => ⟨c_bot, x⟩) (seq 0 n)).
    repeat split.
    - now rewrite map_length, seq_length.
    - eapply NoDup_map. 2: eapply seq_NoDup. intros ? ? ? % (f_equal unembed).
      rewrite !embedP in H1. congruence.
    - intros x (? & <- & ? % in_seq) % in_map_iff. red. now rewrite embedP.
  Qed.

  Lemma S_Pow_NotInS n:
    ~ Forall S' (S_Pow n).
  Proof.
    intros H.
    assert (length (S_Pow n) <= 2^n - 1).
    - eapply S_List_Bound.
      + apply seq_NoDup.
      + intros x. split.
        * revert H0. apply Forall_forall. exact H.
        * apply in_seq in H0. lia.
    - unfold S_Pow in H0. rewrite seq_length in H0. clear H.
      induction n; cbn in H0; lia.
  Qed.

  Lemma Not_Forall_2_WeakEx {X} (p: X -> Prop) L:
    (~ Forall p L) -> ~~ exists x, In x L /\ ~ p x.
  Proof.
    intros H1 H2.
    induction L.
    - now apply H1.
    - ccase (p a) as [H | H].
      + apply IHL.
        * contradict H1. now constructor.
        * contradict H2. destruct H2. exists x; firstorder.
      + apply H2. exists a. firstorder.
  Qed.

  Lemma S_Pow_WeakEx_NotS n:
    ~~ exists x, In x (S_Pow n) /\ (compl S') x.
  Proof.
    apply Not_Forall_2_WeakEx, S_Pow_NotInS.
  Qed.

  Lemma S_Star_coInfinite:
    ~ exhaustible (compl S_Star).
  Proof.
    eapply non_finite_nat.
    intros n0.
    assert (~ ~ (exists n : nat, n >= n0 + 1/\ compl (fun n : nat => let '(c, x) := unembed n in W c x) n)).
    - eapply non_finite_nat. apply WNat_CoInfinite.
    - contradict H. intros [n H2].
      apply (S_Pow_WeakEx_NotS n).
      intros [x [H3 H4]]. apply H.
      exists x; split.
      + apply in_seq in H3. enough (2 ^ n > n) by lia. apply pow_pos.
      + apply S_Star_comp_agree.
        unfold S_Star_compl. split.
        * exact H4.
        * intros [n1 [H5 H6]].
          assert (n = n1) by now apply (S_Pow_injective x).
          apply H2. now rewrite H0.
  Qed.

  (* S* is simple *)

  Corollary S_Star_simple:
    simple S_Star.
  Proof.
    split.
    - eapply semi_decidable_enumerable; eauto. exact S_Star_semidec.
    - split.
      + exact S_Star_coInfinite.
      + intros (? & ? % enumerable_semi_decidable & ? & ?); eauto.
        eapply S_Star_No_S_Inf_Subset; eauto.
  Qed.

  (* W truth-table reduces to S* *)

  Lemma S_Star_split L:
    Forall S_Star L
      -> Forall S' L \/ exists n, (fun '(c,x) => W c x) (unembed n) /\ exists x, In x L /\ In x (S_Pow n).
  Proof.
    induction 1.
    - left; constructor.
    - destruct IHForall.
      + destruct H.
        * left; now constructor.
        * right. destruct H.
          exists x0. intuition.
          exists x; intuition.
      + right. destruct H1.
        exists x0. intuition. destruct H3.
        exists x1; intuition.
  Qed.

  Lemma Forall2_equiv {X} {Y} {p : X -> Prop} {q : Y -> Prop} l1 l2:
    Forall2 (fun x y => q y <-> p x) l1 l2 ->
    Forall p l1 <-> Forall q l2.
  Proof.
    induction 1.
    - split; now econstructor.
    - split; intros H1; inv H1; econstructor; firstorder.
  Qed.

  Lemma Forall_map {X} {p : X -> Prop} l :
    Forall (fun P => P) (map p l) <-> Forall p l.
  Proof.
    induction l; cbn.
    - split; econstructor.
    - split; intros H1; inv H1; econstructor; firstorder.
  Qed.

  Lemma tt_red_W_S_Star:
    (fun '(c,x) => W c x) ⪯ₜₜ S_Star.
  Proof.
    unshelve eexists (fun '(c, x) => existT (let n := embed (c,x) in S_Pow n) (mk_tt (fun L => if (Forall_dec (fun b => b = true) _ L) then true else false))).
    1:{ intros b. cbn. decide (b = true); tauto. }
    1:{ refine (length (S_Pow ⟨c, x⟩)). }
    intros [c x] L. cbn.
    unfold reflects. intros H1.
    rewrite eval_tt_mk_tt'.
    2:{ eapply list.Forall2_length in H1.
        now rewrite H1, map_length. }
    unshelve edestruct (Forall_dec (fun b => b = true)) as [H0 | H0].
    - intuition.
      assert (Forall S_Star (S_Pow ⟨c,x⟩)). {
       eapply Forall2_equiv in H1.
       rewrite Forall_map in H1. now eapply H1. }
      clear H0. rename H2 into H0.
      apply S_Star_split in H0 as [H0 | H0].
      + apply S_Pow_NotInS in H0. contradict H0.
      + destruct H0 as [n [H0 [x0 H3]]].
        apply S_Pow_injective in H3.
        subst. now rewrite embedP in H0.
    - split; intros; try congruence.
      contradict H0.
      assert (Forall S_Star (S_Pow (embed (c,x)))).
      * apply Forall_forall.
        intros x0 H3. right.
        exists (embed (c, x)). rewrite embedP. intuition.
      * eapply Forall2_equiv. exact H1.
        now eapply Forall_map.
  Qed.

End S_Star.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Import ListNotations.

Module Registers.
  Inductive register : Set := r0 | r1 | r2 | r3 | r4 | r5 | r6.
  Definition size (r:register) : Z :=
    match r with
    | r0 | r1 => 32
    | r2 | r3 | r4 | r5 | r6 => 64
    end.
  Definition reg_eq_dec (r1 r2 : register) : {r1 = r2} + {r1 <> r2}.
  Proof. destruct r1, r2; try tauto; right; congruence. Defined.
  Hint Resolve reg_eq_dec : deciders.
  Definition all_registers := [r0;r1;r2;r3;r4;r5;r6].
  Notation "$ y" := (@inr register Z y) (at level 40, format "$ y").
  Notation "% r" := (@inl register Z r) (at level 40, format "% r").
End Registers.

Section Proofs.
  Lemma all_registers_complete : forall r, In r Registers.all_registers.
  Proof. destruct r; cbn; tauto. Qed.
End Proofs.


(** This file is used to collect profiling information
 ** for cancellation.
 ** You should run each [go] command several times.
 **)
Require Import Timing.
Require Import PreAutoSep.

Fixpoint quant (n : nat) (k : list W -> Prop) :=
  match n with
    | 0 => k nil
    | S n => quant n (fun ls => forall x : W, k (x :: ls))
  end.

Fixpoint chain (ls : list W) : hprop :=
  match ls with
    | nil => emp
    | l :: ls =>
      match ls with
        | nil => emp
        | l' :: ls' =>
          l =*> l' * chain ls
      end
  end%Sep.

Ltac go :=
  simpl; unfold Himp in *; simpl; intros;
  start_timer "cancel" ;
  sep_canceler 10 10 ltac:ILTacCommon.isConst tt ;
  stop_timer "cancel" ;
  reflexivity.

Goal quant 5 (fun ls => chain ls ===> chain ls).
Clear Timing Profile.
go.
Print Timing Profile.
Time Qed.

Goal quant 10 (fun ls => chain ls ===> chain ls).
Clear Timing Profile.
go.
Print Timing Profile.
Time Qed.

Goal quant 25 (fun ls => chain ls ===> chain ls).
Clear Timing Profile.
go.
Print Timing Profile.
Time Qed.

Goal quant 50 (fun ls => chain ls ===> chain ls).
Clear Timing Profile.
go.
Print Timing Profile.
Time Qed.


Require Import utility.
Require Import PredomCore.
Require Import PredomProd.
Require Import PredomLift.
Require Import PredomKleisli.

Set Implicit Arguments.
Unset Strict Implicit.

Open Scope O_scope.

(*==========================================================================
  Morphisms, missing from Predom.v
  ==========================================================================*)

(*==========================================================================
  Some basic lemmas
  ==========================================================================*)

Lemma eta_injective :
  forall D E (f g:D -c> E), eta << f == eta << g -> f == g.
intros D E f g eq.
refine (fcont_eq_intro _).
intro x. refine (vinj _).
assert (H := fcont_eq_elim eq x). auto.
Qed.