Require Import CaMain.
Import ListNotations.

Obligation Tactic := program_simpl; congruence.

Inductive modelPortsType :=
	a | y | b | x | i | j | l | k | m | n |  c.
Program Instance modelPortsEqDec : EqDec modelPortsType eq :=
	{equiv_dec x y :=
		 match x, y with
		| a , a => in_left
		| a , y => in_right
		| a , b => in_right
		| a , x => in_right
		| a , i => in_right
		| a , j => in_right
		| a , l => in_right
		| a , k => in_right
		| a , m => in_right
		| a , n => in_right
		| a , c => in_right
		| y , a => in_right
		| y , y => in_left
		| y , b => in_right
		| y , x => in_right
		| y , i => in_right
		| y , j => in_right
		| y , l => in_right
		| y , k => in_right
		| y , m => in_right
		| y , n => in_right
		| y , c => in_right
		| b , a => in_right
		| b , y => in_right
		| b , b => in_left
		| b , x => in_right
		| b , i => in_right
		| b , j => in_right
		| b , l => in_right
		| b , k => in_right
		| b , m => in_right
		| b , n => in_right
		| b , c => in_right
		| x , a => in_right
		| x , y => in_right
		| x , b => in_right
		| x , x => in_left
		| x , i => in_right
		| x , j => in_right
		| x , l => in_right
		| x , k => in_right
		| x , m => in_right
		| x , n => in_right
		| x , c => in_right
		| i , a => in_right
		| i , y => in_right
		| i , b => in_right
		| i , x => in_right
		| i , i => in_left
		| i , j => in_right
		| i , l => in_right
		| i , k => in_right
		| i , m => in_right
		| i , n => in_right
		| i , c => in_right
		| j , a => in_right
		| j , y => in_right
		| j , b => in_right
		| j , x => in_right
		| j , i => in_right
		| j , j => in_left
		| j , l => in_right
		| j , k => in_right
		| j , m => in_right
		| j , n => in_right
		| j , c => in_right
		| l , a => in_right
		| l , y => in_right
		| l , b => in_right
		| l , x => in_right
		| l , i => in_right
		| l , j => in_right
		| l , l => in_left
		| l , k => in_right
		| l , m => in_right
		| l , n => in_right
		| l , c => in_right
		| k , a => in_right
		| k , y => in_right
		| k , b => in_right
		| k , x => in_right
		| k , i => in_right
		| k , j => in_right
		| k , l => in_right
		| k , k => in_left
		| k , m => in_right
		| k , n => in_right
		| k , c => in_right
		| m , a => in_right
		| m , y => in_right
		| m , b => in_right
		| m , x => in_right
		| m , i => in_right
		| m , j => in_right
		| m , l => in_right
		| m , k => in_right
		| m , m => in_left
		| m , n => in_right
		| m , c => in_right
		| n , a => in_right
		| n , y => in_right
		| n , b => in_right
		| n , x => in_right
		| n , i => in_right
		| n , j => in_right
		| n , l => in_right
		| n , k => in_right
		| n , m => in_right
		| n , n => in_left
		| n , c => in_right
		| c , a => in_right
		| c , y => in_right
		| c , b => in_right
		| c , x => in_right
		| c , i => in_right
		| c , j => in_right
		| c , l => in_right
		| c , k => in_right
		| c , m => in_right
		| c , n => in_right
		| c , c => in_left
	end
	}.
Inductive merger1StatesType :=
	q0.
Program Instance merger1EqDec : EqDec merger1StatesType eq :=
	{equiv_dec x y :=
		 match x, y with
		| q0 , q0 => in_left
	end
	}.
Inductive sync2StatesType :=
	q1.
Program Instance sync2EqDec : EqDec sync2StatesType eq :=
	{equiv_dec x y :=
		 match x, y with
		| q1 , q1 => in_left
	end
	}.
Inductive sync3StatesType :=
	q2.
Program Instance sync3EqDec : EqDec sync3StatesType eq :=
	{equiv_dec x y :=
		 match x, y with
		| q2 , q2 => in_left
	end
	}.
Inductive sync4StatesType :=
	q3.
Program Instance sync4EqDec : EqDec sync4StatesType eq :=
	{equiv_dec x y :=
		 match x, y with
		| q3 , q3 => in_left
	end
	}.
Inductive transformer5StatesType :=
	q4.
Program Instance transformer5EqDec : EqDec transformer5StatesType eq :=
	{equiv_dec x y :=
		 match x, y with
		| q4 , q4 => in_left
	end
	}.
Inductive sync6StatesType :=
	q5.
Program Instance sync6EqDec : EqDec sync6StatesType eq :=
	{equiv_dec x y :=
		 match x, y with
		| q5 , q5 => in_left
	end
	}.
Inductive sync7StatesType :=
	q6.
Program Instance sync7EqDec : EqDec sync7StatesType eq :=
	{equiv_dec x y :=
		 match x, y with
		| q6 , q6 => in_left
	end
	}.
Inductive fifo8StatesType :=
	 q7 | 	 p0 | 	p1.
Program Instance fifo8EqDec : EqDec fifo8StatesType eq :=
	{equiv_dec x y :=
		 match x, y with
		| q7 , q7 => in_left
		| q7 , p0 => in_right
		| q7 , p1 => in_right
		| p0 , q7 => in_right
		| p0 , p0 => in_left
		| p0 , p1 => in_right
		| p1 , q7 => in_right
		| p1 , p0 => in_right
		| p1 , p1 => in_left
	end
	}.
Inductive merger9StatesType :=
	q8.
Program Instance merger9EqDec : EqDec merger9StatesType eq :=
	{equiv_dec x y :=
		 match x, y with
		| q8 , q8 => in_left
	end
	}.
Definition merger1rel (s: merger1StatesType) :=
	match s with
		 | q0 => [([a;y], ConstraintAutomata.eqDc nat a y , q0);([b;y], ConstraintAutomata.eqDc nat b y , q0)]
	end.
Definition merger1Automaton := {|
	ConstraintAutomata.Q := [q0];
	ConstraintAutomata.N := [a;y;b];
	ConstraintAutomata.T := merger1rel;
	ConstraintAutomata.Q0 := [q0]
|}.
Definition sync2rel (s: sync2StatesType) :=
	match s with
		 | q1 => [([y;x], ConstraintAutomata.eqDc nat y x  , q1)]
	end.
Definition sync2Automaton := {|
	ConstraintAutomata.Q := [q1];
	ConstraintAutomata.N := [y;x];
	ConstraintAutomata.T := sync2rel;
	ConstraintAutomata.Q0 := [q1]
|}.
Definition sync3rel (s: sync3StatesType) :=
	match s with
		 | q2 => [([x;i], ConstraintAutomata.eqDc nat x i  , q2)]
	end.
Definition sync3Automaton := {|
	ConstraintAutomata.Q := [q2];
	ConstraintAutomata.N := [x;i];
	ConstraintAutomata.T := sync3rel;
	ConstraintAutomata.Q0 := [q2]
|}.
Definition sync4rel (s: sync4StatesType) :=
	match s with
		 | q3 => [([x;j], ConstraintAutomata.eqDc nat x j  , q3)]
	end.
Definition sync4Automaton := {|
	ConstraintAutomata.Q := [q3];
	ConstraintAutomata.N := [x;j];
	ConstraintAutomata.T := sync4rel;
	ConstraintAutomata.Q0 := [q3]
|}.

Close Scope Q_scope.
Definition swap01 (n:nat) :=
  match n with
  | 0 => 1
  | 1 => 0
  | S o => S o
  end.

Definition transformer5rel (s: transformer5StatesType) :=
	match s with
		 | q4 => [([j;l], ConstraintAutomata.trDc swap01 j l , q4)]
	end.
Definition transformer5Automaton := {|
	ConstraintAutomata.Q := [q4];
	ConstraintAutomata.N := [j;l];
	ConstraintAutomata.T := transformer5rel;
	ConstraintAutomata.Q0 := [q4]
|}.
Definition sync6rel (s: sync6StatesType) :=
	match s with
		 | q5 => [([i;k], ConstraintAutomata.eqDc nat i k  , q5)]
	end.
Definition sync6Automaton := {|
	ConstraintAutomata.Q := [q5];
	ConstraintAutomata.N := [i;k];
	ConstraintAutomata.T := sync6rel;
	ConstraintAutomata.Q0 := [q5]
|}.
Definition sync7rel (s: sync7StatesType) :=
	match s with
		 | q6 => [([l;m], ConstraintAutomata.eqDc nat l m  , q6)]
	end.
Definition sync7Automaton := {|
	ConstraintAutomata.Q := [q6];
	ConstraintAutomata.N := [l;m];
	ConstraintAutomata.T := sync7rel;
	ConstraintAutomata.Q0 := [q6]
|}.
Definition fifo8rel (s: fifo8StatesType) :=
	match s with
		 | q7 => [([k], ConstraintAutomata.dc k 0 , p0); ([k], ConstraintAutomata.dc k 1 , p1)]
		 | p0 => [([n], ConstraintAutomata.dc n 0 , q7)]
		 | p1 => [([n], ConstraintAutomata.dc n 1 , q7)]
	end.
Definition fifo8Automaton := {|
	ConstraintAutomata.Q := [q7;p0;p1];
	ConstraintAutomata.N := [k;n];
	ConstraintAutomata.T := fifo8rel;
	ConstraintAutomata.Q0 := [q7]
|}.
Definition merger9rel (s: merger9StatesType) :=
	match s with
		 | q8 => [([m;c], ConstraintAutomata.eqDc nat m c , q8);([n;c], ConstraintAutomata.eqDc nat n c , q8)]
	end.
Definition merger9Automaton := {|
	ConstraintAutomata.Q := [q8];
	ConstraintAutomata.N := [m;c;n];
	ConstraintAutomata.T := merger9rel;
	ConstraintAutomata.Q0 := [q8]
|}.
Definition merger1sync2Product := ProductAutomata.buildPA merger1Automaton sync2Automaton.
Definition sync2sync3Product := ProductAutomata.buildPA merger1sync2Product sync3Automaton.
Definition sync3sync4Product := ProductAutomata.buildPA sync2sync3Product sync4Automaton.
Definition sync4transformer5Product := ProductAutomata.buildPA sync3sync4Product transformer5Automaton.
Definition transformer5sync6Product := ProductAutomata.buildPA sync4transformer5Product sync6Automaton.
Definition sync6sync7Product := ProductAutomata.buildPA transformer5sync6Product sync7Automaton.
Definition sync7fifo8Product := ProductAutomata.buildPA sync6sync7Product fifo8Automaton.
Definition fifo8merger9Product := ProductAutomata.buildPA sync7fifo8Product merger9Automaton.

(**** Readequar trecho de código abaixo para o exemplo acima ***)

(*We may state that from a initial state of the automaton (i.e., possible data gateway into *)
(* it is possible that a given traffic light may be open for an amount of time   *)
(* which may disturb pedestrians waiting to cross the road. *)
(* We may split this properties into two lemmas *)

(* The first one states that, from any initial state of te automaton, it is not possible  *)
(* to repeat the same state (i.e., the same signal) if data have left from a (the sensor) *)
(* to c (the receiver)                                                                    *)

Lemma possibleTrafficLightToBeOpenedNotTheSame : forall state,forall transition,
  In (state) (ConstraintAutomata.Q0 fifo8merger9Product) /\
  In (transition) (ConstraintAutomata.T fifo8merger9Product state) /\
  In (a) (fst(fst(transition))) /\ In (c) (fst(fst(transition))) ->
  snd(transition) <> (q0,q1,q2,q3,q4,q5,q6,q7,q8).
Proof.
intros. destruct H.
simpl in H. destruct H. destruct H0.
- rewrite <- H in H0. vm_compute in H0. repeat (destruct H0).
+ simpl; discriminate.
+ simpl; discriminate.
+ simpl; discriminate.
+ simpl; discriminate.
- inversion H.
Qed.

(* And now, we may state that, from any state reached from a initial state, they cannot reach a
scenario where one of the traffic light have dhe same data*)
Lemma possibleTrafficLightToBeOpenedNotTheSame2 : forall state,forall transition,
  In (state) (ConstraintAutomata.Q fifo8merger9Product) /\
  In (transition) (ConstraintAutomata.T fifo8merger9Product state) /\
  In (a) (fst(fst(transition))) /\ In (c) (fst(fst(transition))) ->
  snd(transition) <> (state).
Proof.
intros. destruct H.
simpl in H. destruct H. destruct H0.
- rewrite <- H in H0. vm_compute in H0. repeat (destruct H0).
+ rewrite <- H. simpl; discriminate.
+ rewrite <- H. simpl; discriminate.
+ rewrite <- H. simpl; discriminate.
+ rewrite <- H. simpl; discriminate.
- destruct H. destruct H0.
 rewrite <- H in H0. vm_compute in H0. repeat (destruct H0).
+ rewrite <- H. simpl; discriminate.
+ destruct H. destruct H0 .
  rewrite <- H in H0. vm_compute in H0. repeat (destruct H0).
  rewrite <- H. simpl; discriminate.
  inversion H.
Qed.

(*data flow*)
Definition dataAssignmentA (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentB (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentC (n:nat) :=
    match n with
    | 0 =>  0
    | 1 =>  (0)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentD (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentE (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentF (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentG (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentH (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentI (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentJ (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentK (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentL (n:nat) :=
    match n with
    | 0 =>  0
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentM (n:nat) :=
    match n with
    | 0 =>  0
    | 1 =>  (0)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentN (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentX (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

  Definition dataAssignmentY (n:nat) :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S p =>  0
    end.

   Definition timeStampSequencerA(n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

  Definition timeStampSequencerB (n:nat) : QArith_base.Q :=
    match n with
    | 0 => 30#1
    | 1 => 70#1
    | 2 => 90#1
    | 3 => 120#1
    | 4 => 150#1
    | 5 => 180#1
    | S p =>  Z.of_nat(S p) + 190#1
    end.

  Definition timeStampSequencerC (n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 19#1
    end.

  Definition timeStampSequencerD (n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

  Definition timeStampSequencerE (n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

  Definition timeStampSequencerF (n:nat) : QArith_base.Q :=
    match n with (*filtro de cima*)
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

  Definition timeStampSequencerG (n:nat) : QArith_base.Q :=
    match n with
    | 0 => 30#1
    | 1 => 60#1
    | 2 => 80#1
    | 3 => 110#1
    | 4 => 140#1
    | 5 => 170#1
    | S p =>  Z.of_nat(S p) + 170#1
    end.

  Definition timeStampSequencerH (n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

   Definition timeStampSequencerI(n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

   Definition timeStampSequencerJ(n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

   Definition timeStampSequencerK(n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

   Definition timeStampSequencerL(n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

   Definition timeStampSequencerM(n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

   Definition timeStampSequencerN (n:nat) : QArith_base.Q :=
    match n with
    | 0 => 30#1
    | 1 => 50#1
    | 2 => 80#1
    | 3 => 110#1
    | 4 => 140#1
    | 5 => 170#1
    | S p =>  Z.of_nat (S p) + 170#1
    end.

   Definition timeStampSequencerX(n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

  Definition timeStampSequencerY(n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S p =>  Z.of_nat(S p) + 17#1
    end.

  Lemma timeStampSequencerAHolds : forall p,
    Qlt (timeStampSequencerA p) (timeStampSequencerA (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerA. reflexivity.
  unfold timeStampSequencerA. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat.  Defined.

  Lemma timeStampSequencerBHolds : forall p,
    Qlt (timeStampSequencerB p) (timeStampSequencerB (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerB. reflexivity.
  unfold timeStampSequencerB. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. apply orderZofNat. Defined.

  Lemma timeStampSequencerCHolds : forall p,
    Qlt (timeStampSequencerC p) (timeStampSequencerC (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerC. reflexivity.
  unfold timeStampSequencerC. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. apply orderZofNat. Defined.

  Lemma timeStampSequencerDHolds : forall p,
    Qlt (timeStampSequencerD p) (timeStampSequencerD (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerD. reflexivity.
  unfold timeStampSequencerD. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. apply orderZofNat. Defined.

  Lemma timeStampSequencerEHolds : forall p,
    Qlt (timeStampSequencerE p) (timeStampSequencerE (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerE. reflexivity.
  unfold timeStampSequencerE. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. apply orderZofNat. Defined.

  Lemma timeStampSequencerFHolds : forall p,
    Qlt (timeStampSequencerF p) (timeStampSequencerF (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerF. reflexivity.
  unfold timeStampSequencerF. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. apply orderZofNat. Defined.

  Lemma timeStampSequencerGHolds : forall p,
    Qlt (timeStampSequencerG p) (timeStampSequencerG (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerG. reflexivity.
  unfold timeStampSequencerG. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. apply orderZofNat. Defined.

  Lemma timeStampSequencerHHolds : forall p,
    Qlt (timeStampSequencerH p) (timeStampSequencerH (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerH. reflexivity.
  unfold timeStampSequencerH. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. apply orderZofNat. Defined.

  Lemma timeStampSequencerIHolds : forall p,
    Qlt (timeStampSequencerI p) (timeStampSequencerI (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerI. reflexivity.
  unfold timeStampSequencerI. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat.  Defined.

  Lemma timeStampSequencerJHolds : forall p,
    Qlt (timeStampSequencerJ p) (timeStampSequencerJ (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerJ. reflexivity.
  unfold timeStampSequencerJ. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat.  Defined.

  Lemma timeStampSequencerKHolds : forall p,
    Qlt (timeStampSequencerK p) (timeStampSequencerK (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerK. reflexivity.
  unfold timeStampSequencerK. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat.  Defined.

  Lemma timeStampSequencerLHolds : forall p,
    Qlt (timeStampSequencerL p) (timeStampSequencerL (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerL. reflexivity.
  unfold timeStampSequencerL. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat.  Defined.

  Lemma timeStampSequencerMHolds : forall p,
    Qlt (timeStampSequencerM p) (timeStampSequencerM (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerM. reflexivity.
  unfold timeStampSequencerM. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat.  Defined.

  Lemma timeStampSequencerNHolds : forall p,
    Qlt (timeStampSequencerN p) (timeStampSequencerN (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerN. reflexivity.
  unfold timeStampSequencerN. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat.  Defined.

  Lemma timeStampSequencerXHolds : forall p,
    Qlt (timeStampSequencerX p) (timeStampSequencerX (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerX. reflexivity.
  unfold timeStampSequencerX. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat.  Defined.

  Lemma timeStampSequencerYHolds : forall p,
    Qlt (timeStampSequencerY p) (timeStampSequencerY (S p)).
  Proof.
  intros. destruct p. unfold timeStampSequencerY. reflexivity.
  unfold timeStampSequencerY. case (p). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat.  Defined.

  Definition portA := {|
        ConstraintAutomata.id := a;
        ConstraintAutomata.dataAssignment := dataAssignmentA;
        ConstraintAutomata.timeStamp := timeStampSequencerA;
        ConstraintAutomata.tdsCond := timeStampSequencerAHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portB := {|
        ConstraintAutomata.id := b;
        ConstraintAutomata.dataAssignment := dataAssignmentB;
        ConstraintAutomata.timeStamp := timeStampSequencerB;
        ConstraintAutomata.tdsCond := timeStampSequencerBHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portC := {|
        ConstraintAutomata.id := c;
        ConstraintAutomata.dataAssignment := dataAssignmentC;
        ConstraintAutomata.timeStamp := timeStampSequencerC;
        ConstraintAutomata.tdsCond := timeStampSequencerCHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portI := {|
        ConstraintAutomata.id := i;
        ConstraintAutomata.dataAssignment := dataAssignmentI;
        ConstraintAutomata.timeStamp := timeStampSequencerI;
        ConstraintAutomata.tdsCond := timeStampSequencerIHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portJ := {|
        ConstraintAutomata.id := j;
        ConstraintAutomata.dataAssignment := dataAssignmentJ;
        ConstraintAutomata.timeStamp := timeStampSequencerJ;
        ConstraintAutomata.tdsCond := timeStampSequencerJHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portK := {|
        ConstraintAutomata.id := k;
        ConstraintAutomata.dataAssignment := dataAssignmentK;
        ConstraintAutomata.timeStamp := timeStampSequencerK;
        ConstraintAutomata.tdsCond := timeStampSequencerKHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portL := {|
        ConstraintAutomata.id := l;
        ConstraintAutomata.dataAssignment := dataAssignmentL;
        ConstraintAutomata.timeStamp := timeStampSequencerL;
        ConstraintAutomata.tdsCond := timeStampSequencerLHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portM := {|
        ConstraintAutomata.id := m;
        ConstraintAutomata.dataAssignment := dataAssignmentM;
        ConstraintAutomata.timeStamp := timeStampSequencerM;
        ConstraintAutomata.tdsCond := timeStampSequencerMHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portN := {|
        ConstraintAutomata.id := n;
        ConstraintAutomata.dataAssignment := dataAssignmentN;
        ConstraintAutomata.timeStamp := timeStampSequencerN;
        ConstraintAutomata.tdsCond := timeStampSequencerNHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portX := {|
        ConstraintAutomata.id := x;
        ConstraintAutomata.dataAssignment := dataAssignmentX;
        ConstraintAutomata.timeStamp := timeStampSequencerX;
        ConstraintAutomata.tdsCond := timeStampSequencerXHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portY := {|
        ConstraintAutomata.id := y;
        ConstraintAutomata.dataAssignment := dataAssignmentY;
        ConstraintAutomata.timeStamp := timeStampSequencerY;
        ConstraintAutomata.tdsCond := timeStampSequencerYHolds;
        ConstraintAutomata.index := 0 |}.

  Definition dataFlow := [portA;portB;portC;portI;
                        portJ;portK;portL;portM;portN;portX;portY].

  Eval vm_compute in ConstraintAutomata.run fifo8merger9Product dataFlow 2.

  Require Extraction.
  Extraction Language Haskell.
  Extraction "trafficLightsCertified" fifo8merger9Product.


Require Import Program.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Language.

Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Behavior.

Require Import SimMemory.
Require Import Simulation.

Set Implicit Arguments.

Lemma sim_adequacy
      ths_src sc_src mem_src
      ths_tgt sc_tgt mem_tgt
      (WF_SRC: Configuration.wf (Configuration.mk ths_src sc_src mem_src))
      (WF_TGT: Configuration.wf (Configuration.mk ths_tgt sc_tgt mem_tgt))
      (SC: TimeMap.le sc_src sc_tgt)
      (MEMORY: sim_memory mem_src mem_tgt)
      (SIM: sim ths_src sc_src mem_src ths_tgt sc_tgt mem_tgt):
  behaviors Configuration.step (Configuration.mk ths_tgt sc_tgt mem_tgt) <1=
  behaviors Configuration.step (Configuration.mk ths_src sc_src mem_src).
Proof.
  s. i.
  revert WF_SRC WF_TGT SC MEMORY SIM.
  revert ths_src sc_src mem_src.
  dependent induction PR; i.
  - punfold SIM. exploit SIM; eauto; try refl. i. des.
    exploit TERMINAL0; eauto. i. des.
    + inv FAILURE. des.
      eapply rtc_tau_step_behavior; eauto.
      econs 3. eauto.
    + eapply rtc_tau_step_behavior; eauto.
      econs 1. eauto.
  - destruct c2.
    punfold SIM. exploit SIM; eauto; try refl. i. des.
    exploit STEP0; eauto. i. des.
    + inv FAILURE. des.
      eapply rtc_tau_step_behavior; eauto.
      econs 3. eauto.
    + inv SIM0; [|done].
      eapply rtc_tau_step_behavior; eauto.
      exploit Configuration.step_future; try apply STEP; eauto. i. des.
      exploit Configuration.rtc_step_future; eauto. i. des.
      inv STEP_SRC. econs 2; eauto.
      exploit Configuration.step_future; try apply STEP1; eauto. i. des.
      eapply IHPR; eauto.
  - destruct c2.
    punfold SIM. exploit SIM; eauto; try refl. i. des.
    exploit STEP0; eauto. i. des.
    + inv FAILURE. des.
      eapply rtc_tau_step_behavior; eauto.
      econs 3; eauto.
    + inv SIM0; [|done].
      eapply rtc_tau_step_behavior; eauto.
      exploit Configuration.step_future; try apply STEP; eauto. i. des.
      exploit Configuration.rtc_step_future; eauto. i. des.
      inv STEP_SRC. econs 3; eauto.
  - destruct c2.
    punfold SIM. exploit SIM; eauto; try refl. i. des.
    exploit STEP0; eauto. i. des.
    + inv FAILURE. des.
      eapply rtc_tau_step_behavior; eauto.
      econs 3; eauto.
    + inv SIM0; [|done].
      eapply rtc_tau_step_behavior; eauto.
      exploit Configuration.step_future; try apply STEP; eauto. i. des.
      exploit Configuration.rtc_step_future; eauto. i. des.
      inv STEP_SRC.
      * eapply IHPR; eauto.
      * econs 4; eauto.
        exploit Configuration.step_future; try apply STEP1; eauto. s. i. des.
        eapply IHPR; eauto.
Qed.


(* Applying the order of sep clauses from an old hypothesis onto a new hypothesis: *)

Require Export Coq.ZArith.ZArith. Open Scope Z_scope.
Require Import coqutil.Z.Lia.
Require Export coqutil.Byte.
Require Import coqutil.Datatypes.HList.
Require Import coqutil.Datatypes.PropSet.
Require Export coqutil.Datatypes.Inhabited.
Require Import coqutil.Tactics.rewr coqutil.Tactics.rdelta.
Require Import Coq.Program.Tactics.
Require Export coqutil.Tactics.Tactics.
Require Export coqutil.Tactics.autoforward.
Require Export coqutil.Map.Interface coqutil.Map.Properties coqutil.Map.OfListWord.
Require Export coqutil.Word.Interface coqutil.Word.Properties.
Require Import coqutil.Sorting.OrderToPermutation.
Require Export coqutil.Tactics.fwd.
Require Import coqutil.Tactics.ltac_list_ops.
Require Export bedrock2.Lift1Prop.
Require Export bedrock2.Map.Separation bedrock2.Map.SeparationLogic.
Require Import bedrock2.Array.
Require Export bedrock2.ZnWords.
Require Import bedrock2.ptsto_bytes bedrock2.Scalars.
Require Export bedrock2.SepClause.
Import List.ListNotations. Local Open Scope list_scope.

Section TransferSepsOrder.
  Context {width : Z} {word : Word.Interface.word width} {word_ok: word.ok word}
          {mem : map.map word byte} {mem_ok: map.ok mem}.

  Lemma reorder_is_iff1: forall (order: list nat) (l: list (mem -> Prop)),
      List.length order = List.length l ->
      iff1 (seps l) (seps (reorder order l)).
  Proof.
    intros. rewrite <-2seps'_iff1_seps. rewrite seps'_fold_right.
    rewrite reorder_comm_fold_right.
    - reflexivity.
    - intros. eapply iff1ToEq. cancel.
    - assumption.
  Qed.
End TransferSepsOrder.

(* If the second-to-last argument of a predicate is a word, we assume it's the address.
   Could be made more flexible and accurate using typeclasses, but that would require
   adding an instance for each predicate. *)
Ltac get_addr clause :=
  lazymatch clause with
  | _ ?a _ => lazymatch type of a with
              | @word.rep _ _ => constr:(a)
              end
  end.

Ltac clause_index clause clauses start_index default_index :=
  match clauses with
  | cons clause _ => constr:(start_index)
  | cons ?otherclause _ =>
      let a := get_addr clause in
      lazymatch get_addr otherclause with
      | a => constr:(start_index)
      end
  | cons _ ?tail => clause_index clause tail (S start_index) default_index
  | nil => constr:(default_index)
  end.

Ltac get_order_rec old_clauses new_clauses default_index :=
  lazymatch new_clauses with
  | nil => constr:(@nil nat)
  | cons ?clause ?tail =>
    let priority := clause_index clause old_clauses 0%nat default_index in
    let rest := get_order_rec old_clauses tail priority in
    constr:(priority :: rest)
  end.

Ltac get_order old_clauses new_clauses :=
  (* if the first clause is not found in old_clauses, we put it at the end;
     if a non-first clause is not found, we put it after the clause that's
     to the left of it in new_clauses, so we give it the same priority value,
     so the returned order might have duplicate priority values, and we rely
     on mergesort being stable to keep the order between clauses of the same priority *)
  let n := list_length old_clauses in
  get_order_rec old_clauses new_clauses n.

Ltac is_fresh x := assert_succeeds (pose proof tt as x).

Ltac make_fresh x :=
  tryif is_fresh x then idtac else let x' := fresh x "_0" in rename x into x'.

(* Given an old and a new sep hyp, transfers the order of the sepclauses from the old one
   to the new one *)
Ltac transfer_sep_order_from_to HOld HNew :=
  flatten_seps_in HNew;
  flatten_seps_in HOld;
  lazymatch type of HOld with
  | seps ?old_clauses ?mOld =>
    lazymatch type of HNew with
    | seps ?new_clauses ?mNew =>
      let tmem := type of mNew in
      let E := fresh "E" in
      eassert (@iff1 tmem (seps new_clauses) _) as E;
      [ (* from `seps new_clauses` to `seps (reorder order new_clauses)` *)
        let order := get_order old_clauses new_clauses in
        etransitivity; [
          eapply (reorder_is_iff1 order new_clauses); reflexivity
        |];
        (* from `seps (reorder order new_clauses)` to cbv'd version of it *)
        cbv [reorder];
        let r := eval vm_compute in (order_to_permutation order) in
            change (order_to_permutation order) with r;
        cbv [apply_permutation apply_permutation_with_default my_list_map my_list_nth];
        cbn [seps];
        reflexivity
      | let HNewNew := fresh in pose proof (proj1 (E mNew) HNew) as HNewNew;
        clear E HOld HNew;
        rename HNewNew into HOld;
        try clear mOld;
        (* won't work if mNew or mOld is not a variable *)
        try (make_fresh mOld; rename mNew into mOld) ]
    end
  end.

Ltac transfer_sep_order :=
  lazymatch goal with
  | HOld: sep _ _ _, HNew: sep _ _ _ |- _ =>
      transfer_sep_order_from_to HOld HNew
  end.

Section TestTransferSepsOrder.
  Context {width : Z} {word : Word.Interface.word width} {word_ok: word.ok word}
          {mem : map.map word byte} {mem_ok: map.ok mem}.

  Lemma reordering_test: forall addr1 addr2 addr3 addr4 v1_old v1_new v2 v3 v4 R (m m': mem),
    seps [scalar addr1 v1_old; scalar addr2 v2; scalar addr3 v3; R] m ->
    (* value at addr1 was updated, addr2 was consumed, addr4 was added, and order changed: *)
    seps [R; seps [scalar addr3 v3; scalar addr4 v4]; scalar addr1 v1_new] m' ->
    True ->
    True.
  Proof.
    intros *. intros M M2 ExtraHyp.
    (*            0                    1                2                3
       M  : seps [scalar addr1 v1_old; scalar addr2 v2; scalar addr3 v3; R] m
       M2 : seps [R; seps [scalar addr3 v3; scalar addr4 v4]; scalar addr1 v1_new] m'
       order :=  [3; 2;                     2;                0                  ] *)
    transfer_sep_order_from_to M M2.
    flatten_seps_in M.
    lazymatch type of M with
    | seps [scalar addr1 v1_new; scalar addr3 v3; scalar addr4 v4; R] m =>
        idtac
    end.
  Abort.
End TestTransferSepsOrder.


(** * Study of controlled simulations *)

Require Export Theory.
Set Implicit Arguments.

(** ** Relaxed expansion: Subsection 3.2 *)
Section RelaxedExpansion.

  Variables A X Y: Type.
  Variable TX: reduction_t A X.
  Variable TY: reduction_t A Y.

  Variable B: relation X.
  Hypothesis HB: wexpansion1 TX TX B.

  (** Silent case *)
  Let wexpansion1_ctrl_t:
  forall R, evolve_t TX TY R (comp (star B) R) -> simulation_t TX TY (comp (star B) R).
  Proof.
    intros R HR x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
    cgen Hxx'; cgen x'; induction xRw as [ x | z x w xRz zRw IH ]; intros x' Hxx'.
    apply (HR _ _ _ Hxx' wRy).
    destruct (HB Hxx' xRz) as [ z' Hzz' x'Rz' ].
    celim Hzz'; intro Hzz'.
    destruct Hzz'; exists y; auto; exists w; auto; apply star_trans with z; auto.
    destruct (IH wRy _ Hzz') as [ y' Hyy' z'Ry' ] ; destruct z'Ry' as [ w' ].
    exists y'; auto; exists w'; auto; apply S_star with z'; auto.
  Qed.

  (** Lemma 3.10 *)
  Theorem wexpansion1_ctrl: wexpansion1 TX TX B -> controlled TX TY B.
  Proof.
    split; auto.
    intros R S HR HS HRS HRS' a x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
    cgen Hxx'; cgen x'; induction xRw as [ x | z x w xRz zRw IH ]; intros x' Hxx'.
    destruct (HRS _ _ _ _ Hxx' wRy) as [ y' Hyy' w'Ry' ]; exists y'; auto; exists x'; auto.
    destruct (HB Hxx' xRz) as [ z' Hzz' x'Rz' ].
    destruct Hzz' as [ z1 Hzz1 Hz1z' ].
    destruct (IH wRy _ Hzz1) as [ y1 Hyy1 z1Ry1 ].
    cut (simulation_t TX TY (comp (star B) S)).
    intro HS'; destruct (weak_strong_t HS' _ Hz1z' z1Ry1) as [ y' Hy1y' z'Ry' ]; exists y'.
    apply weak_taus with y1; auto.
    destruct z'Ry' as [ w' ]; exists w'; auto; apply S_star with z'; auto.
    apply wexpansion1_ctrl_t; auto.
    unfold evolve_t; eapply evolve_incl; try apply HS; intros u v K; exists u; auto.
  Qed.

End RelaxedExpansion.

(** ** Termination Guarantees: Subsection 3.3 *)
Section PlusWf.

  Variable A: Type.
  Variable X: Set.
  Variable Y: Type.
  Variable TX: reduction_t A X.
  Variable TY: reduction_t A Y.

  Variable B: relation X.
  Hypothesis HB: evolve TX TX B (plus B).
  Hypothesis HB': well_founded (trans B).

  (** Theorem 3.11 *)
  Theorem plus_wf_controlled: controlled TX TY B.
  Proof.
    split.
    intros R HR x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ]; destar xRw z.
    apply (HR _ _ _ Hxx' wRy).
    elim (diagram_plus_wf_2 (HB (l:=T _)) HB') with (eq (A:=X)) Y R R (TY (T A)) (eq (A:=Y)) x x' y; auto.
    intros y' Hyy' x'Ry'; exists y'; auto; destruct Hyy' as [ y1 Hyy1 Hy1y' ]; destruct Hy1y'; auto.
    intros u u' v Huu' uRv; destruct Huu'; exists v; auto; exists v; auto.
    intros u u' v Huu' uRv; destruct Huu'; exists v; auto; (exists v || exists u); auto.
    exists x'; auto.
    exists w; auto.

    intros R S HR HS HRS HRS' a x x' y Hxx' xRy.
    elim (diagram_plus_wf_2 (HB (l:=T _)) HB') with
      (comp (TX (L a)) (star (TX (T _)))) Y R S (TY (T _))
      (comp (TY (L a)) (star (TY (T _)))) x x' y; auto.
    intros y' Hyy' x'Ry'; exists y'; auto.
    clear Hxx' xRy x x' y; intros x x' y Hxx' xRy; destruct Hxx' as [ x1 Hxx1 Hx1x' ].
    destruct (HB Hxx1 xRy) as [ y1 Hyy1 x1Ry1 ].
    destruct (diagram_plus_wf (HB (l:=T _)) HB' Hx1x' x1Ry1) as [ y' Hy1y' x'Ry' ].
    exists y'; auto; fold (Weak TX (L a)); apply weak_taus with y1; auto.
    clear Hxx' xRy x x' y; intros x x' y Hxx' xRy; destruct Hxx' as [ x1 Hxx1 Hx1x' ].
    destruct (HRS _ _ _ _ Hxx1 xRy) as [ y1 Hyy1 x1Ry1 ].
    destruct (weak_strong_t HS _ Hx1x' x1Ry1) as [ y' Hy1y' x'Ry' ]; exists y'.
    fold (Weak TY (L a)); apply weak_taus with y1; auto.
    exists x'; auto.
    exists x; auto; exists x'; auto.
  Qed.

End PlusWf.

Section StarWf.

  Variable A: Type.
  Variable X: Set.
  Variable Y: Type.
  Variable TX: reduction_t A X.
  Variable TY: reduction_t A Y.

  Variable B: relation X.
  Hypothesis HB: evolve TX TX B (star B).
  Hypothesis HB': well_founded (trans (comp (plus B) (plus (TX (T _))))).

  (** Theorem 3.12 *)
  Theorem star_wf_controlled: controlled TX TY B.
  Proof.
    split.
    intros R HR; unfold simulation_t, evolve_t, evolve_1, Weak.
    apply diagram_reverse; apply diagram_incl with (star (TX (T _))) (star (TY (T _))); auto; apply diagram_reverse.
    apply diagram_star_wf_1; auto; exact (HB (l:=T _)).

    intros R S HR HS HRS HRS' a; unfold evolve_1.
    apply diagram_reverse; apply diagram_incl with (Weak TX (L a)) (Weak TY (L a)); auto; apply diagram_reverse.
    unfold Weak; apply diagram_star_wf_2; auto; try exact (HB (l:=T _));
      intros x x' y Hxx' xRy; destruct Hxx' as [ x1 Hxx1 Hx1x' ].
    destruct (HB Hxx1 xRy) as [ y1 Hyy1 x1Ry1 ].
    destruct (diagram_star_wf (HB (l:=T _)) HB' Hx1x' x1Ry1) as [ y' Hy1y' x'Ry' ].
    exists y'; auto; fold (Weak TX (L a)); apply weak_taus with y1; auto.
    destruct (HRS _ _ _ _ Hxx1 xRy) as [ y1 Hyy1 x1Ry1 ].
    destruct (weak_strong_t HS _ Hx1x' x1Ry1) as [ y' Hy1y' x'Ry' ]; exists y'.
    fold (Weak TY (L a)); apply weak_taus with y1; auto.
    exists x'; auto.
  Qed.

End StarWf.


From Undecidability Require Import TM.Util.TM_facts.
Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.

(** A firstorder encoding and the connection to an arbitrary TM *)
Inductive flatTM : Type :=
  { sig : nat;
    tapes : nat;
    states : nat;
    trans : list ((nat * list (option nat)) * (nat * list (option nat * move)));
    start : nat;
    halt : list bool
  }.

Inductive isFlatteningTransOf {st sig : finType} {n}
          (f:list (nat * list (option nat) * (nat * list (option nat * move))))
          (f': st * Vector.t (option sig) n -> st * Vector.t (option sig * move) n): Prop :=
  mkIsFlatteningTransOf
    (R__sound :
       (forall s s' v v', (((s,v),(s',v')) el f ->
                     ((exists s0 s0' v0 v0', ( f' (s0,v0) = (s0', v0')
                                          /\ s = index s0
                                          /\ s' = index s0'
                                          /\ v = map (option_map index) (Vector.to_list v0)
                                          /\ v' = map (map_fst (option_map index)) (Vector.to_list v0')))))))
    (R_complete : (forall s0 v0, let (s0',v0') := f' (s0,v0)
                             in ((index s0,map (option_map index) (Vector.to_list v0))
                                 ,(index s0',map (map_fst (option_map index)) (Vector.to_list v0'))) el f
                                \/ (s0=s0' /\ v0' = Vector.const (None,TM.Nmove) n)))
  : isFlatteningTransOf f f'.

Inductive isFlatteningHaltOf {st:finType} (f : list bool) (f' : st -> bool) : Prop :=
  mkIsFlatteningHaltOf
    (R__halt : forall (p:st),
        nth (index p) f false = f' p) : isFlatteningHaltOf f f'.

Inductive isFlatteningTMOf {sig' n} (M:flatTM) (M': TM sig' n) : Prop :=
  mkIsFlatteningTMOf
    (eq__tapes : tapes M = n)
    (eq__sig : sig M = |elem sig'|)
    (eq__states : (states M) = |elem (TM.state M')| )
    (R__trans : isFlatteningTransOf (trans M) (TM.trans (m:=M')))
    (eq__start : start M = index (TM.start M'))
    (R__halt : isFlatteningHaltOf (halt M) (TM.halt (m:=M')))
  : isFlatteningTMOf M M'.

Inductive isFlatteningTapesOf {sig : finType} {n}: list (tape nat) ->  Vector.t (tape sig) n -> Prop :=
  mkIsFlatteningTapeOf t : isFlatteningTapesOf (Vector.to_list(mapTapes index t)) t.

Lemma isFlatteningTapesOf_iff (sig : finType) (n : nat) y (t:Vector.t (tape sig) n):
  isFlatteningTapesOf y t <-> y = (Vector.to_list (mapTapes index t)).
Proof.
  split. now inversion 1. intros ->;easy.
Qed.

Definition mconfigFlat :Type := nat * list (tape nat).
Inductive isFlatteningConfigOf {st sig : finType} {n}: mconfigFlat -> mconfig st sig n -> Prop :=
  mkisFlatteningConfigOf t c'  (Ht:isFlatteningTapesOf t c'.(ctapes))
  : isFlatteningConfigOf (index c'.(cstate),t) c'.

Lemma isFlatteningConfigOf_iff {st sig : finType} n c (c' : mconfig st sig n):
  isFlatteningConfigOf c c' <-> exists t, isFlatteningTapesOf t c'.(ctapes) /\ c = (index c'.(cstate),t).
Proof.
  split. inversion 1;subst. eauto. intros (?&?&->). easy.
Qed.


(* Extra Lemmas not needed at present *)
(*
Lemma unique_store_events: forall t p tr ev1 ev2 loc,
  well_formed t ->
  Trace.trace t p tr ->
  In ev1 tr ->
  In ev2 tr ->
  store_event ev1 loc ->
  store_event ev2 loc ->
  ev1 <> ev2 ->
  False.
Proof.
  intros.
  assert (ev1 = ev2).
  {
    eapply store_events_injective;
      try eassumption;
      try (eapply Trace.trace_events; eassumption).
  }
  congruence.
Defined.
 *)

(*
Lemma noDup_store_events: forall t p ev loc tr,
  well_formed t ->
  store_event ev loc ->
  Trace.trace t p tr ->
  In ev tr ->
  NoDup ev.
 *)

(*
Inductive store_event_evsys: EvSys Ev -> Loc -> Prop :=
| inevsys_leaf: forall r ev loc,
    store_event ev loc ->
    store_event_evsys (leaf r ev) loc
| inevsys_before_l: forall r es1 es2 loc,
    store_event_evsys es1 loc ->
    store_event_evsys (before r es1 es2) loc
| inevsys_before_r: forall r es1 es2 loc,
    store_event_evsys es2 loc ->
    store_event_evsys (before r es1 es2) loc
| inevsys_merge_l: forall r es1 es2 loc,
    store_event_evsys es1 loc ->
    store_event_evsys (merge r es1 es2) loc
| inevsys_merge_r: forall r es1 es2 loc,
    store_event_evsys es2 loc ->
    store_event_evsys (merge r es1 es2) loc.
Hint Constructors store_event_evsys: core.
 *)

(*
Lemma alt_store_event_evsys: forall es loc,
    store_event_evsys es loc <-> store_event_evsys es loc.
Proof.
  intros.
  unfold store_event_evsys.
  split.
  -
    generalizeEverythingElse es.
    induction es; intros loc H;
      inv H;
      try (eauto; tauto);
      try ( try (edestruct IHes1; [eauto | destruct_conjs; eauto]; tauto);
            try (edestruct IHes2; [eauto | destruct_conjs; eauto]; tauto)
          ).
  -
    generalizeEverythingElse es.
    induction es; intros loc H;
      destruct H as [x [xx H1]];
      inv H1; eauto.
Defined.
*)

(*
Lemma aff: forall es1 loc,
    store_event_evsys es1 loc ->
    exists ev, store_event ev loc /\ ev_in ev es1.
Proof.
  intros.
  unfold store_event_evsys in *.
  eauto.
Defined.

  intros.
  induction H;
    try eauto;
    try (
        edestruct IHstore_event_evsys;
        destruct_conjs;
        exists x;
        split; eauto).
Defined.
 *)

(*

Inductive top_level_at: (*Plc ->*) Loc -> AnnoTerm -> Prop :=
(*| top_at_rec: forall r p q loc t',
          top_level_at q loc t' ->
          top_level_at p loc (aatt r q t') *)
| top_at_l: forall q t' loc loc2,
    top_level_at loc (aatt (loc,loc2) q t')
| top_at_r: forall q t' loc loc2,
    top_level_at (pred loc2) (aatt (loc,loc2) q t')
| top_lseq_l: forall r loc t1 t2,
    top_level_at loc t1 ->
    top_level_at loc (alseq r t1 t2)
| top_lseq_r: forall r loc t1 t2,
    top_level_at loc t2 ->
    top_level_at loc (alseq r t1 t2)
| top_bseq_l: forall r s loc t1 t2,
    top_level_at loc t1 ->
    top_level_at loc (abseq r s t1 t2)
| top_bseq_r: forall r s loc t1 t2,
    top_level_at loc t2 ->
    top_level_at loc (abseq r s t1 t2)
| top_bpar_l: forall r s loc t1 t2,
    top_level_at loc t1 ->
    top_level_at loc (abpar r s t1 t2)
| top_bpar_r: forall r s loc t1 t2,
    top_level_at loc t2 ->
    top_level_at loc (abpar r s t1 t2).

Lemma store_event_facts: forall loc t p,
    store_event_evsys (ev_sys t p) loc ->
    top_level_at loc t.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a;

      inv H;
        repeat break_let;
        try solve_by_inversion;
        inv H0; inv H1.
  -
    cbn in *.
    repeat break_let.
    invc H.
    +
      invc H4.
      invc H2.
      econstructor.
    +
      invc H4.
      invc H2.
      econstructor.
  -
    cbn in *.
    invc H.
    +
      econstructor.
      eauto.
    +
      eapply top_lseq_r.
      eauto.
  -
    cbn in *.
    repeat break_let.
    invc H.
    +
      invc H4.
      invc H2.
    +
      invc H4.
      ++
        invc H3.
        +++
          econstructor.
          eauto.
        +++
          eapply top_bseq_r.
          eauto.
      ++
        invc H3.
        invc H2.
  -
    cbn in *.
    repeat break_let.
    invc H.
    +
      invc H4.
      invc H2.
    +
      invc H4.
      ++
        invc H3.
        +++
          econstructor.
          eauto.
        +++
          eapply top_bpar_r.
          eauto.
      ++
        invc H3.
        invc H2.
Defined.

Lemma wf_att_fact: forall x y q t',
    well_formed (aatt (x, y) q t') ->
    x > (Nat.pred y) ->
    False.
Proof.
  intros.
  inv H.
  simpl in *.
  lia.
Defined.

Lemma good_par : forall r s p t1 t2 loc,
    well_formed (abpar r s t1 t2) ->
    store_event_evsys (ev_sys t1 p) loc ->
    store_event_evsys (ev_sys t2 p) loc ->
    False.
Proof.
  intros.
  eapply store_event_facts in H0.
  eapply store_event_facts in H1.
  inv H.
  Check anno_mono.
  inv H0; inv H1; cbn in *.

  invc H0; invc H1;
    try lia.

  invc H0; invc H1;
    try lia.

  eapply wf_att_fact.
  apply H7.
  lia.

  rewrite <- H3 in *.
  subst.
  invc H7.
  simpl in *.
  lia.

  invc H6.
  simpl in *.
  subst.

  invc H0; try lia.
  pose (wf_mono t' H12).
  simpl in *.
  subst.
  rewrite <- H13 in *.
  rewrite H14 in *.
  simpl in *.
  destruct (range t') eqn:hey.
  simpl in *.
  subst.
  destruct r.
  simpl in *.
  subst.
  destruct r0.
  simpl in *.
  subst.
  clear H1.
  invc H7.
  subst.

  simpl in *.
  subst.
  pose (wf_mono t1 H4).
  subst.
  rewrite H8 in *.
  subst.
  rewrite <- H6 in *; clear H6.
  rewrite <- H8 in *; clear H8.

  subst.
  admit.

Admitted.

 *)

(*

Theorem no_store_conflicts: forall t p,
    well_formed t ->
    not (store_conflict (ev_sys t p)).
Proof.
  Print ev_sys.
  unfold not; intros.
  generalize dependent p.
  induction t; intros.
  -
    destruct a;
      try (inv H0; repeat break_let; solve_by_inversion).
  -
    cbn in *.
    repeat break_let.
    invc H0.
    +
      solve_by_inversion.
    +
      solve_by_inversion.
  -
    inv H.
    invc H0; eauto.
  -
    inv H.
    invc H0;
      repeat break_let;
      try solve_by_inversion.
    +
      invc H1.
      solve_by_inversion.
    +
      invc H1.
      invc H2.
      ++
        invc H1; eauto.
      ++
        solve_by_inversion.
  -
    inv H.
    invc H0;
      repeat break_let;
      try solve_by_inversion.
    +
      invc H1.
      solve_by_inversion.
    +
      invc H1.
      invc H2; try solve_by_inversion.
      invc H1.

      eapply good_par; eauto.
Defined.

  *)


Require Import StlcEqui.SpecSyntax.

#[export]
Hint Constructors PCtx : pctx.

(* Lemmas to solve program context equations via eauto. *)
Lemma eq_pctx_papp₁ c t c₁ t₂ :
  c = papp₁ c₁ t₂ → app (pctx_app t c₁) t₂ = pctx_app t c.
Proof. intros; subst; reflexivity. Qed.
#[export]
Hint Resolve eq_pctx_papp₁ : pctx.

Lemma eq_pctx_papp₂ c t t₁ c₂ :
  c = papp₂ t₁ c₂ → app t₁ (pctx_app t c₂) = pctx_app t c.
Proof. intros; subst; reflexivity. Qed.
#[export]
Hint Resolve eq_pctx_papp₂ : pctx.

(* Lemma eq_pctx_pite₁ c t c₁ t₂ t₃ : *)
(*   c = pite₁ c₁ t₂ t₃ → ite (pctx_app t c₁) t₂ t₃ = pctx_app t c. *)
(* Proof. intros; subst; reflexivity. Qed. *)
(* #[export]
Hint Resolve eq_pctx_pite₁ : pctx. *)

(* Lemma eq_pctx_ppair₁ c t c₁ t₂ : *)
(*   c = ppair₁ c₁ t₂ → pair (pctx_app t c₁) t₂ = pctx_app t c. *)
(* Proof. intros; subst; reflexivity. Qed. *)
(* #[export]
Hint Resolve eq_pctx_ppair₁ : pctx. *)

(* Lemma eq_pctx_ppair₂ c t t₁ c₂ : *)
(*   c = ppair₂ t₁ c₂ → pair t₁ (pctx_app t c₂) = pctx_app t c. *)
(* Proof. intros; subst; reflexivity. Qed. *)
(* #[export]
Hint Resolve eq_pctx_ppair₂ : pctx. *)

(* Lemma eq_pctx_pproj₁ c t c₁ : *)
(*   c = pproj₁ c₁ → proj₁ (pctx_app t c₁) = pctx_app t c. *)
(* Proof. intros; subst; reflexivity. Qed. *)
(* #[export]
Hint Resolve eq_pctx_pproj₁ : pctx. *)

(* Lemma eq_pctx_pproj₂ c t c₁ : *)
(*   c = pproj₂ c₁ → proj₂ (pctx_app t c₁) = pctx_app t c. *)
(* Proof. intros; subst; reflexivity. Qed. *)
(* #[export]
Hint Resolve eq_pctx_pproj₂ : pctx. *)

Lemma eq_pctx_pinl c t c₁ :
  c = pinl c₁ → inl (pctx_app t c₁) = pctx_app t c.
Proof. intros; subst; reflexivity. Qed.
#[export]
Hint Resolve eq_pctx_pinl : pctx.

Lemma eq_pctx_pinr c t c₁ :
  c = pinr c₁ → inr (pctx_app t c₁) = pctx_app t c.
Proof. intros; subst; reflexivity. Qed.
#[export]
Hint Resolve eq_pctx_pinr : pctx.

Lemma eq_pctx_pcaseof₁ c t c₁ t₂ t₃ :
  c = pcaseof₁ c₁ t₂ t₃ → caseof (pctx_app t c₁) t₂ t₃ = pctx_app t c.
Proof. intros; subst; reflexivity. Qed.
#[export]
Hint Resolve eq_pctx_pcaseof₁ : pctx.

(* Lemma eq_pctx_pseq₁ c t c₁ t₂ : *)
(*   c = pseq₁ c₁ t₂ → seq (pctx_app t c₁) t₂ = pctx_app t c. *)
(* Proof. intros; subst; reflexivity. Qed. *)
(* #[export]
Hint Resolve eq_pctx_pseq₁ : pctx. *)

(* Lemma eq_pctx_pfixt c t τ₁ τ₂ c₁ : *)
(*   c = pfixt τ₁ τ₂ c₁ → fixt τ₁ τ₂ (pctx_app t c₁) = pctx_app t c. *)
(* Proof. intros; subst; reflexivity. Qed. *)
(* #[export]
Hint Resolve eq_pctx_pfixt : pctx. *)


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import NArith List.
Import ListNotations.
Open Scope list.

Require Import Tries.Canonical.
Import PTree.

From Utils Require Import Utils Monad.
From Pyrosome.Theory Require Import Core.
Import Core.Notations.

Require Import Utils.UnionFind.
Require Import Utils.TrieMap.
Import TrieArrayList.
From coqutil Require Import Map.Interface.

Section WithVar.
  Context (V : Type)
          {V_Eqb : Eqb V}
          {V_default : WithDefault V}.

  Notation named_list := (@named_list V).
  Notation named_map := (@named_map V).
  Notation term := (@term V).
  Notation ctx := (@ctx V).
  Notation sort := (@sort V).
  Notation subst := (@subst V).
  Notation rule := (@rule V).
  Notation lang := (@lang V).

  Notation eq_subst l :=
    (eq_subst (Model:= core_model l)).
  Notation eq_args l :=
    (eq_args (Model:= core_model l)).
  Notation wf_subst l :=
    (wf_subst (Model:= core_model l)).
  Notation wf_args l :=
    (wf_args (Model:= core_model l)).
  Notation wf_ctx l :=
    (wf_ctx (Model:= core_model l)).

  Variant node : Type :=
    (* variable name *)
    | nvar : V -> node
    (* Rule label, list of subterms*)
    | ncon : V -> list positive -> node.
                                     (*
    | ncemp : node
    | nccons : positive -> positive -> node.*)

  (* We assume that the head is the root by default.
     Invariant: all indices of the head are < length of the tail
   *)

  Definition pf := list node.

  (*TODO: backport these to core.v. Copied from TreeProofs.v*)

    Local Lemma term_con_congruence l c t name s1 s2 c' args t'
      : In (name, term_rule c' args t') l ->
        t = t'[/with_names_from c' s2/] ->
        wf_lang l ->
        eq_args l c c' s1 s2 ->
        eq_term l c t (con name s1) (con name s2).
    Proof.
      intros.
      assert (wf_ctx l c') by with_rule_in_wf_crush.
      rewrite <- (wf_con_id_args_subst c' s1);[| basic_core_crush..].
      rewrite <- (wf_con_id_args_subst c' s2);[|basic_core_crush..].
      subst.
      change (con ?n ?args[/?s/]) with (con n args)[/s/].
      eapply eq_term_subst; eauto.
      {
        apply eq_args_implies_eq_subst; eauto.
      }
      {
        constructor.
        replace t' with t'[/id_subst c'/].
        - eapply wf_term_by; basic_core_crush.
        - basic_core_crush.
      }
    Qed.

    Local Lemma sort_con_congruence l c name s1 s2 c' args
      : In (name, sort_rule c' args) l ->
        wf_lang l ->
        eq_args l c c' s1 s2 ->
        eq_sort l c (scon name s1) (scon name s2).
    Proof.
      intros.
      assert (wf_ctx l c') by with_rule_in_wf_crush.
      rewrite <- (wf_con_id_args_subst c' s1);[| basic_core_crush..].
      rewrite <- (wf_con_id_args_subst c' s2);[|basic_core_crush..].
      subst.
      change (scon ?n ?args[/?s/]) with (scon n args)[/s/].
      eapply eq_sort_subst; eauto.
      { apply eq_args_implies_eq_subst; eauto. }
      { constructor.
        eapply wf_sort_by; basic_core_crush.
      }
    Qed.

  Section WithLang.

    Context (l : lang).

  Fixpoint named_list_put {A B} `{Eqb A} (l : @Utils.named_list A B) k v :=
    match l with
    | [] => [(k,v)]
    | (k',v')::l =>
        if eqb k k' then (k,v)::l else (k',v')::(named_list_put l k v)
    end.

  Fixpoint named_list_remove {A B} `{Eqb A} (l : @Utils.named_list A B) k :=
    match l with
    | [] => []
    | (k',v')::l =>
        if eqb k k' then l else (k',v')::(named_list_remove l k)
    end.

    (*TODO: copied; should be deduplicated if not replaced *)
  Section __.
    (* Not fast, but will run*)
    Local Instance named_list_map A B `{Eqb A} : map.map A B :=
      {
        rep := @Utils.named_list A B;
        get := named_list_lookup_err;
        empty := [];
        put := named_list_put;
        remove := named_list_remove;
        fold _ f acc l := List.fold_left (fun acc '(k, v) => f acc k v) l acc;
      }.
  End __.

  (*TODO: this isn't very efficient*)

  Axiom eqb_node : Eqb node.
  Existing Instance eqb_node.
  Definition node_map := (@named_list_map node positive _).

  (* Basically an egraph without congruence closure or saturation *)
  Record proof_context :=
    MkPC {
        id_equiv :  union_find;
        hashcons : node_map;
      }.

  Import StateMonad.

  Notation pfM := (stateT proof_context option).

  (*TODO: move to Monad.v*)

Instance stateT_default S M A `{WithDefault (M (A*S))%type}
  : WithDefault (stateT S M A) :=
  fun _ => default.

Existing  Instance stateT_trans.

  Definition find i : pfM positive :=
    fun pc =>
      @! let (uf', i') <- find pc.(id_equiv) i in
        ret (i',MkPC uf' pc.(hashcons)).

  Definition alloc : pfM positive :=
    fun pc => let (uf', i') := alloc pc.(id_equiv) in
              Some (i', MkPC uf' pc.(hashcons)).

  Definition set_hashcons n i : pfM unit :=
    fun pc => let hc' := map.put pc.(hashcons) n i in
              Some (tt, MkPC pc.(id_equiv) hc').

  Definition canonicalize n : pfM node :=
    match n with
    | ncon name args =>
        @! let args <- list_Mmap find args in
          ret ncon name args
    | nvar x =>
        @! ret nvar x
    end.

    Definition eqb_ids a b : pfM unit :=
      @! let fa <- (find a) in
         let fb <- (find b) in
         let ! eqb fa fb in
         ret tt.

    (*TODO: what's the right output type?
      Shouldn't need the 2nd option (but then need a different combinator)
     *)
    Definition lookup n : pfM (option positive) :=
      fun pc =>
        let mi := map.get pc.(hashcons) n in
        Some (mi,pc).

      (*
      Adds a node to the egraph without checking whether it is valid in the language
     *)
    Definition add_node_unchecked (n : node) : pfM positive :=
      @! let mn <- lookup n in
         match mn with
         | Some i => @! ret i
         | None =>
             @! let i <- alloc in
                let tt <- set_hashcons n i in
                ret i
         end.

    Fixpoint lookup_term (pc : proof_context) (e : term) : option _ :=
      match e with
      | var x => map.get pc.(hashcons) (nvar x)
      | con n s =>
          @! let si <- list_Mmap (lookup_term pc) s in
            (map.get pc.(hashcons) (ncon n si))
      end.

    Definition lookup_sort (pc : proof_context) (t : sort) : option _ :=
      match t with
      | scon n s =>
          @! let si <- list_Mmap (lookup_term pc) s in
            (map.get pc.(hashcons) (ncon n si))
      end.

    Section UnderSubst.

      Context (sub : named_list positive).

      Fixpoint lookup_term' (pc : proof_context) (e : term) : option _ :=
        match e with
        | var x => (named_list_lookup_err sub x)
        | con n s =>
            @! let si <- list_Mmap (lookup_term' pc) s in
              (map.get pc.(hashcons) (ncon n si))
        end.

      Definition lookup_sort' (pc : proof_context) (t : sort) : option _ :=
        match t with
        | scon n s =>
            @! let si <- list_Mmap (lookup_term' pc) s in
              (map.get pc.(hashcons) (ncon n si))
        end.

      Fixpoint add_term_unchecked' (e : term) {struct e} : pfM positive :=
        match e with
        | var x => lift (named_list_lookup_err sub x)
        | con n s =>
            @! let si  <- list_Mmap add_term_unchecked' s in
              (add_node_unchecked (ncon n si))
        end.

      Definition add_sort_unchecked' (t: sort) : pfM positive :=
        match t with
        | scon n s =>
            @! let si <- list_Mmap add_term_unchecked' s in
              (add_node_unchecked (ncon n si))
        end.

    End UnderSubst.

    (*

     Fixpoint add_term_unchecked (e : term) {struct e} : pfM positive :=
        match e with
        | var x => add_node_unchecked (nvar x)
        | con n s =>
            @! let si  <- list_Mmap add_term_unchecked s in
               (add_node_unchecked (ncon n si))
        end.

      Definition add_sort_unchecked (t: sort) : pfM positive :=
        match t with
        | scon n s =>
            @! let si <- list_Mmap add_term_unchecked s in
               (add_node_unchecked (ncon n si))
        end.

    *)

    (*
  Section WithCtx.
    (*TODO: ids or sorts on rhs*)
    Context (c : named_list positive).*)

      Section Inner.

        (*TODO: return sort or no?*)
        Context (add_term' : term -> (*sort*) positive-> pfM positive).

        (*TODO: return pair of lists or list of pairs?*)
        Fixpoint add_args' (s : list term) (c : ctx) {struct s}
          : pfM (list positive) :=
          match s, c with
          | [],[] => @! ret []
          | e::s, (_,t)::c =>
              @! let sci <- add_args' s c in
                (* sort given by c *)
                let ti <- add_sort_unchecked' (with_names_from c sci) t in
                let ei <- add_term' e ti in
                (*  let tt <- eqb_ids ti' ti in *)
                ret ei::sci
          | _,_ => default
          end.
      End Inner.

      Section UnderSubst.

        Context (sub : named_list positive).

        Fixpoint add_term' (e : term) (t_in : positive) {struct e} : pfM positive :=
          match e with
          | var x => lift (named_list_lookup_err sub x)
          | con n s =>
              @! let term_rule c _ t <?- lift (named_list_lookup_err l n) in
                let sci <- add_args' add_term' s c in
                (* sort generated from sort of n rule *)
                let t_out <- add_sort_unchecked' (with_names_from c sci) t in
                let tt <- eqb_ids t_in t_out in
                (add_node_unchecked (ncon n sci))
          end.

        Definition add_sort' (t : sort) : pfM positive :=
          let (n,s) := t in
          @! let sort_rule c _ <?- lift (named_list_lookup_err l n) in
            let sci <- add_args' add_term' s c in
            (add_node_unchecked (ncon n sci)).

      End UnderSubst.

      Section WithCtx.

        Context (ctx : named_list positive).

        Fixpoint add_term (e : term) (t_in : positive) {struct e} : pfM positive :=
          match e with
          | var x =>
              @! let t_out <^- (named_list_lookup_err ctx x) in
                let tt <- eqb_ids t_in t_out in
                (add_node_unchecked (nvar x))
          | con n s =>
              @! let term_rule c _ t <?- lift (named_list_lookup_err l n) in
                let sci <- add_args' add_term s c in
                (* sort generated from sort of n rule *)
                let t_out <- add_sort_unchecked' (with_names_from c sci) t in
                let tt <- eqb_ids t_in t_out in
                (add_node_unchecked (ncon n sci))
          end.

        Definition add_sort (t : sort) : pfM positive :=
          let (n,s) := t in
          @! let sort_rule c _ <?- lift (named_list_lookup_err l n) in
            let sci <- add_args' add_term s c in
            (add_node_unchecked (ncon n sci)).

      End WithCtx.

      Section WithCtx.
        Context (c : ctx).

        Definition lookup_sort_of_node (pc : proof_context) (n : node)
          : option _ :=
          match n with
          | nvar x =>
              @!let t <- named_list_lookup_err c x in
              (*TODO: do I want to have this precomputed?*)
                (lookup_sort pc t)
          | ncon n s =>
              @! let (term_rule _ _ t) <?- named_list_lookup_err l n in
                (lookup_sort' (with_names_from c s) pc t)
          end.

        Definition lookup_term_and_sort (pc : proof_context) (e : term)
          : option _ :=
          match e with
          | var x =>
              @! let i <- map.get pc.(hashcons) (nvar x) in
                let ti <- lookup_sort_of_node pc (nvar x) in
                ret (i,ti)
          | con n s =>
              @! let si <- list_Mmap (lookup_term pc) s in
                let i <- map.get pc.(hashcons) (ncon n si) in
                let ti <- lookup_sort_of_node pc (ncon n si) in
                ret (i,ti)
          end.

        (*TODO: is R really right?*)
      Definition proof_context_valid pc t :=
        uf_ok pc.(id_equiv) t
                  /\ (forall i t, Some i = lookup_sort pc t -> wf_sort l c t)
                  /\ (forall ti i e t,
                         Some ti = lookup_sort pc t ->
                         Some (i,ti) = lookup_term_and_sort pc e ->
                         wf_term l c e t).

      Definition empty := MkPC empty map.empty.

      Lemma empty_ok
        : proof_context_valid empty [].
      Proof.
        unfold proof_context_valid.
        split.
        {
          apply empty_ok.
        }
        split.
        all:intros; simpl in *.
        {
          destruct t0; simpl in *.
          revert H; case_match; congruence.
        }
        {
          destruct e; simpl in *; try congruence.
          revert H0; case_match; congruence.
        }
      Qed.

      Lemma lookup_term_forest_equiv f f' pc1 pc2 e
        : forest_equiv f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          lookup_term pc1 e = lookup_term pc2 e.
      Proof.
        intros; induction e;
          intros; simpl in *.
        1: destruct pc1; destruct pc2; simpl in *; subst; now auto.
        enough (list_Mmap (lookup_term pc1) l0
                = list_Mmap (lookup_term pc2) l0) as H'
            by (rewrite H'; case_match; congruence).
        revert dependent l0.
        induction l0;
          intros; simpl in *; auto.
        break.
        rewrite H3.
        case_match; auto.
        rewrite IHl0; eauto.
      Qed.

      (* TODO: generalize*)
      Lemma list_Mmap_ext_option {A B} (f g : A -> option B) ls
        : (forall x, f x = g x) -> list_Mmap f ls = list_Mmap g ls.
      Proof.
        intro; induction ls;
          basic_goal_prep;
          basic_utils_crush.
        rewrite H.
        case_match; auto.
        rewrite IHls.
        case_match; auto.
      Qed.

      Lemma map_lookup_term_forest_equiv f f' pc1 pc2 e
        : forest_equiv f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          list_Mmap (lookup_term pc1) e = list_Mmap (lookup_term pc2) e.
      Proof.
        intros; eapply list_Mmap_ext_option.
        intros; eapply lookup_term_forest_equiv; eauto.
      Qed.

      Lemma lookup_sort_forest_equiv f f' pc1 pc2 t
        : forest_equiv f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          lookup_sort pc1 t = lookup_sort pc2 t.
      Proof.
        intros; induction t;
          intros; simpl in *.
        enough (list_Mmap (lookup_term pc1) l0
                = list_Mmap (lookup_term pc2) l0) as H'
            by (rewrite H'; case_match; congruence).
        eapply map_lookup_term_forest_equiv; eauto.
      Qed.

      Lemma lookup_term'_forest_equiv f f' pc1 pc2 e sub
        : forest_equiv f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          lookup_term' sub pc1 e = lookup_term' sub pc2 e.
      Proof.
        intros; induction e;
          intros; simpl in *.
        1: destruct pc1; destruct pc2; simpl in *; subst; now auto.
        enough (list_Mmap (lookup_term' sub pc1) l0
                = list_Mmap (lookup_term' sub pc2) l0) as H'
            by (rewrite H'; case_match; congruence).
        revert dependent l0.
        induction l0;
          intros; simpl in *; auto.
        break.
        rewrite H3.
        case_match; auto.
        rewrite IHl0; eauto.
      Qed.

      Lemma map_lookup_term'_forest_equiv f f' pc1 pc2 e sub
        : forest_equiv f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          list_Mmap (lookup_term' sub pc1) e = list_Mmap (lookup_term' sub pc2) e.
      Proof.
        intros; eapply list_Mmap_ext_option.
        intros; eapply lookup_term'_forest_equiv; eauto.
      Qed.

      Lemma lookup_sort'_forest_equiv f f' pc1 pc2 t sub
        : forest_equiv f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          lookup_sort' sub pc1 t = lookup_sort' sub pc2 t.
      Proof.
        intros; induction t;
          intros; simpl in *.
        enough (list_Mmap (lookup_term' sub pc1) l0
                = list_Mmap (lookup_term' sub pc2) l0) as H'
            by (rewrite H'; case_match; congruence).
        eapply map_lookup_term'_forest_equiv; eauto.
      Qed.

      Lemma lookup_term_and_sort_forest_equiv f f' pc1 pc2 e
        : forest_equiv f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          lookup_term_and_sort pc1 e = lookup_term_and_sort pc2 e.
      Proof.
        intros; induction e;
          intros; simpl in *.
        {
          destruct pc1; destruct pc2; simpl in *; subst.
          case_match; eauto.
          my_case Heqnl (named_list_lookup_err c n); eauto.
          erewrite lookup_sort_forest_equiv; eauto.
        }
        {
          erewrite map_lookup_term_forest_equiv; eauto.
          case_match; eauto.
          rewrite H2; case_match; eauto.
          my_case Hnl (named_list_lookup_err l n); auto.
          my_case Hr r; eauto.
          erewrite lookup_sort'_forest_equiv; eauto.
        }
      Qed.

      Lemma lookup_term_forest_subrel f f' pc1 pc2 e
        : forest_subrel f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          forall i,
            Some i = lookup_term pc1 e ->
            Some i = lookup_term pc2 e.
      Proof.
        intros Hsub Hokf Hokf';
          induction e;
          intros; simpl in *.
        1: destruct pc1; destruct pc2; simpl in *; subst; now auto.
        revert H1;
          case_match;[| congruence].

        enough (Some l1 = list_Mmap (lookup_term pc2) l0) as H'.
        {
          rewrite<- H'.
          congruence.
        }
        revert dependent l1.
        revert dependent l0.
        induction l0;
          intros; simpl in *; auto.
        break.
        revert HeqH1.
        case_match;[| congruence].
        case_match;[| congruence].
        intro H'; safe_invert H'.
        specialize (H H0 p eq_refl).
        rewrite <- H.
        erewrite <- IHl0; eauto.
      Qed.

      Lemma map_lookup_term_forest_subrel f f' pc1 pc2 e
        : forest_subrel f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          forall l,
            Some l = list_Mmap (lookup_term pc1) e ->
            Some l = list_Mmap (lookup_term pc2) e.
      Proof.
        intros ? ? ? ?.
        induction e;
          intros; simpl in *; auto.
        break.
        revert H3.
        case_match;[| congruence].
        case_match;[| congruence].
        intro H'; safe_invert H'.
        erewrite <- lookup_term_forest_subrel; eauto.
        erewrite <- IHe; eauto.
      Qed.

      Lemma lookup_sort_forest_subrel f f' pc1 pc2 t
        : forest_subrel f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          forall i,
            Some i = lookup_sort pc1 t ->
            Some i = lookup_sort pc2 t.
      Proof.

        intros Hsub Hokf Hokf';
          induction t;
          intros; simpl in *.
        revert H0;
          case_match;[| congruence].

        enough (Some l1 = list_Mmap (lookup_term pc2) l0) as H'.
        {
          rewrite<- H'.
          congruence.
        }
        revert dependent l1.
        revert dependent l0.
        induction l0;
          intros; simpl in *; auto.
        break.
        revert HeqH0.
        case_match;[| congruence].
        case_match;[| congruence].
        intro H'; safe_invert H'.
        erewrite <- lookup_term_forest_subrel; eauto.
        erewrite <- IHl0; eauto.
      Qed.

      (*TODO: concerning; why is this true?*)
      Lemma lookup_term'_forest_subrel f f' pc1 pc2 e sub
        : forest_subrel f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          lookup_term' sub pc1 e = lookup_term' sub pc2 e.
      Proof.
        intros; induction e;
          intros; simpl in *.
        1: destruct pc1; destruct pc2; simpl in *; subst; now auto.
        enough (list_Mmap (lookup_term' sub pc1) l0
                = list_Mmap (lookup_term' sub pc2) l0) as H'
            by (rewrite H'; case_match; congruence).
        revert dependent l0.
        induction l0;
          intros; simpl in *; auto.
        break.
        rewrite H3.
        case_match; auto.
        rewrite IHl0; eauto.
      Qed.

      Lemma map_lookup_term'_forest_subrel f f' pc1 pc2 e sub
        : forest_subrel f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          list_Mmap (lookup_term' sub pc1) e = list_Mmap (lookup_term' sub pc2) e.
      Proof.
        intros; eapply list_Mmap_ext_option.
        intros; eapply lookup_term'_forest_subrel; eauto.
      Qed.

      Lemma lookup_sort'_forest_subrel f f' pc1 pc2 t sub
        : forest_subrel f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          lookup_sort' sub pc1 t = lookup_sort' sub pc2 t.
      Proof.
        intros; induction t;
          intros; simpl in *.
        enough (list_Mmap (lookup_term' sub pc1) l0
                = list_Mmap (lookup_term' sub pc2) l0) as H'
            by (rewrite H'; case_match; congruence).
        eapply map_lookup_term'_forest_subrel; eauto.
      Qed.

      Lemma lookup_term_and_sort_forest_subrel f f' pc1 pc2 e
        : forest_subrel f f' ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          forall p,
          Some p = lookup_term_and_sort pc1 e ->
          Some p = lookup_term_and_sort pc2 e.
      Proof.
        intros ? ? ? ?; induction e;
          intros; simpl in *.
        {
          revert H3.
          destruct pc1; destruct pc2; simpl in *; subst.
          case_match; eauto.
          my_case Heqnl (named_list_lookup_err c n); eauto.
          case_match; [|congruence].
          erewrite <- lookup_sort_forest_subrel; cycle 5;
          eauto.
        }
        {
          revert H4.
          case_match; [|congruence].
          erewrite <- map_lookup_term_forest_subrel; cycle 5; eauto.
          rewrite H2; case_match; eauto.
          my_case Hnl (named_list_lookup_err l n); auto.
          my_case Hr r; eauto.
          erewrite lookup_sort'_forest_subrel; eauto.
        }
      Qed.

      Lemma lookup_term_forest_subrel' f f' pc1 pc2 e
        : forest_subrel f' f ->
          uf_ok pc1.(id_equiv) f ->
          uf_ok pc2.(id_equiv) f' ->
          pc1.(hashcons) = pc2.(hashcons) ->
          forall i,
            Some i = lookup_term pc1 e ->
            exists j, equiv_by_forest f i j
                      /\ Some j = lookup_term pc2 e.
      Proof.
        intros Hsub Hokf Hokf';
          induction e;
          intros; simpl in *.
        {
          destruct pc1; destruct pc2; simpl in *; subst.
          (*
          now auto.
        revert H1;
          case_match;[| congruence].

        enough (Some l1 = list_Mmap (lookup_term pc2) l0) as H'.
        {
          rewrite<- H'.
          congruence.
        }
        revert dependent l1.
        revert dependent l0.
        induction l0;
          intros; simpl in *; auto.
        break.
        revert HeqH1.
        case_match;[| congruence].
        case_match;[| congruence].
        intro H'; safe_invert H'.
        specialize (H H0 p eq_refl).
        rewrite <- H.
        erewrite <- IHl0; eauto.
      Qed.*)
      Abort.

      Lemma find_ok pc f pc' (i i' : positive)
        : proof_context_valid pc f ->
          Some (i', pc') = find i pc ->
          equiv_by_forest f i i'
          /\ (exists f', forest_equiv f f' /\ proof_context_valid pc' f').
      Proof.
        unfold proof_context_valid.
        intros; break.
        revert H0; unfold find.
        destruct pc.
        simpl in *.
        case_match; try congruence.
        break.
        intro H'; safe_invert H'.
        eapply find_spec in HeqH0; eauto; break.
        intuition subst.
        eexists; intuition eauto.
        {
          eapply H1; eauto.
          erewrite lookup_sort_forest_equiv; eauto.
        }
        {
          eapply H2; eauto.
          -erewrite lookup_sort_forest_equiv; eauto.
          -erewrite lookup_term_and_sort_forest_equiv; eauto.
        }
      Qed.

      Definition union i1 i2 : pfM positive :=
        fun pc =>
          @! let (uf', i') <- union pc.(id_equiv) i1 i2 in
            ret (i',MkPC uf' pc.(hashcons)).

      Lemma points_to_tree_union_l x0 x1
        : points_to (tree_union_l x0 x1) = points_to x0.
      Proof.
        destruct x0; auto.
      Qed.
      Hint Rewrite points_to_tree_union_l : utils.

      Lemma points_to_in_same x0
        : In_tree (points_to x0) x0 <-> True.
      Proof.
        destruct x0; simpl; intuition auto.
      Qed.
      Hint Rewrite points_to_in_same : utils.

      Lemma union_ok pc f pc' i' (i1 i2 : positive)
        : proof_context_valid pc f ->
          Some (i', pc') = union i1 i2 pc ->
          exists f', forest_subrel f f'
                     /\ equiv_by_forest f' i1 i'
                     /\ equiv_by_forest f' i2 i'
                     /\ proof_context_valid pc' f'.
      Proof.
        unfold union.
        intro.
        destruct pc; simpl in *.
        case_match; try congruence.
        break.
        intro H'; safe_invert H'.
        revert HeqH0.
        intro.
        destruct H; simpl in *.
        pose proof HeqH0.
        eapply union_spec in HeqH0; eauto.
        break.
        destruct HeqH0.
        {
          break; subst.
          exists f; subst; intuition eauto;
              try exact (fun a b c => c);
              constructor; simpl; eauto.
        }
        break.
        exists (tree_union_l x0 x1 :: x).
        intuition subst.
        1:admit (*permutation x union -> subrel*).
        {
          rewrite points_to_tree_union_l.
          exists (tree_union_l x0 x1);
            basic_utils_crush.
          all: admit.
        }
        {
          rewrite points_to_tree_union_l.
          exists (tree_union_l x0 x1);
            basic_utils_crush.
          all: admit.
        }
        {
          constructor; intuition eauto.
          { eapply H0; eauto.
            eapply lookup_sort_forest_subrel; cycle 4; eauto.
            (*
            TODO: subrel wrong direction
            TODO: wrong uf
        {
          eapply H0.
          eapply lookup_sort_forest_subrel; cycle 4.
          1:eauto.
          all:simpl.
          2:eauto.
          2:eauto.
          2:eauto.
          TODO: need better spec for union;
          need to know it's the least rel that satisfies conditions
          TODO: subrel in the wrong direction
          TODO: uf_ok not true
          eapply lookup_term_and_sort_forest_subrel .
          TODO: need rewrite subrel
          erewrite lookup_sort_forest_equiv; eauto.
          admit (*lemma*).
        }
        {
          eapply H1.
          1: erewrite  lookup_sort_forest_equiv; eauto.
          1:admit (*lemma*).
          erewrite lookup_term_and_sort_forest_equiv; eauto.
          admit (*lemma*).
        }
        {

        }
        4: constructor; eauto.
        1:

        unfold UnionFind.union.
        simpl.
        destruct H.
        case_match; try congruence.
        break.
        eapply find_spec in HeqH1; eauto.
        case_match; try congruence.
        break.
        eapply find_spec in HeqH2; eauto.
        (*TODO: copied*)

        Ltac destruct_pos_eqb i j :=
          let Hneq := fresh "Hneq" in
          let Hneq' := fresh "Hneq" in
          destruct (Pos.eq_dec i j) as [? | Hneq];
          [ subst; rewrite Pos.eqb_refl
          | pose proof Hneq as Hneq'; apply Pos.eqb_neq in Hneq'; rewrite Hneq'].
        destruct_pos_eqb p0 p1.
        {
          intro H'; safe_invert H'.
          break.
          eexists; intuition eauto.
          1:admit (*lemma*).
          1:admit (*lemma *).
          constructor; simpl; eauto.
          1:admit (*lemma*).
          split.
          all: intros.
          {
            eapply H0.
            erewrite  lookup_sort_forest_equiv; eauto.
            admit (*lemma*).
          }
          {
            eapply H1.
            1: erewrite  lookup_sort_forest_equiv; eauto.
            1:admit (*lemma*).
            erewrite lookup_term_and_sort_forest_equiv; eauto.
            admit (*lemma*).
          }
        }
        {
          case_match;[| congruence].
          case_match;[| congruence].
          destruct (PeanoNat.Nat.compare_spec n0 n).
          all: intro H'; safe_invert H'.
          all: break.
          case_match;[| congruence].

        }
             *)
            Abort.

      End WithCtx.
  End WithLang.

End WithVar.


From stdpp Require Import gmap.
From iris.bi Require Import interface.
From iris.proofmode Require Import tactics.

(** This file constructs a simple non step-indexed linear separation logic as
predicates over heaps (modeled as maps from integer locations to integer values).
It shows that Iris's [bi] canonical structure can be inhabited, and the Iris
proof mode can be used to prove lemmas in this separation logic. *)
Definition loc := Z.
Definition val := Z.

Record heapProp := HeapProp {
  heapProp_holds :> gmap loc val → Prop;
}.
Arguments heapProp_holds : simpl never.
Add Printing Constructor heapProp.

Section ofe.
  Inductive heapProp_equiv' (P Q : heapProp) : Prop :=
    { heapProp_in_equiv : ∀ σ, P σ ↔ Q σ }.
  Instance heapProp_equiv : Equiv heapProp := heapProp_equiv'.
  Instance heapProp_equivalence : Equivalence (≡@{heapProp}).
  Proof. split; repeat destruct 1; constructor; naive_solver. Qed.
  Canonical Structure heapPropO := discreteO heapProp.
End ofe.

(** logical entailement *)
Inductive heapProp_entails (P Q : heapProp) : Prop :=
  { heapProp_in_entails : ∀ σ, P σ → Q σ }.

(** logical connectives *)
Definition heapProp_emp_def : heapProp :=
  {| heapProp_holds σ := σ = ∅ |}.
Definition heapProp_emp_aux : seal (@heapProp_emp_def). Proof. by eexists. Qed.
Definition heapProp_emp := unseal heapProp_emp_aux.
Definition heapProp_emp_eq :
  @heapProp_emp = @heapProp_emp_def := seal_eq heapProp_emp_aux.

Definition heapProp_pure_def (φ : Prop) : heapProp :=
  {| heapProp_holds _ := φ |}.
Definition heapProp_pure_aux : seal (@heapProp_pure_def). Proof. by eexists. Qed.
Definition heapProp_pure := unseal heapProp_pure_aux.
Definition heapProp_pure_eq :
  @heapProp_pure = @heapProp_pure_def := seal_eq heapProp_pure_aux.

Definition heapProp_and_def (P Q : heapProp) : heapProp :=
  {| heapProp_holds σ := P σ ∧ Q σ |}.
Definition heapProp_and_aux : seal (@heapProp_and_def). Proof. by eexists. Qed.
Definition heapProp_and := unseal heapProp_and_aux.
Definition heapProp_and_eq:
  @heapProp_and = @heapProp_and_def := seal_eq heapProp_and_aux.

Definition heapProp_or_def (P Q : heapProp) : heapProp :=
  {| heapProp_holds σ := P σ ∨ Q σ |}.
Definition heapProp_or_aux : seal (@heapProp_or_def). Proof. by eexists. Qed.
Definition heapProp_or := unseal heapProp_or_aux.
Definition heapProp_or_eq:
  @heapProp_or = @heapProp_or_def := seal_eq heapProp_or_aux.

Definition heapProp_impl_def (P Q : heapProp) : heapProp :=
  {| heapProp_holds σ := P σ → Q σ |}.
Definition heapProp_impl_aux : seal (@heapProp_impl_def). Proof. by eexists. Qed.
Definition heapProp_impl := unseal heapProp_impl_aux.
Definition heapProp_impl_eq :
  @heapProp_impl = @heapProp_impl_def := seal_eq heapProp_impl_aux.

Definition heapProp_forall_def {A} (Ψ : A → heapProp) : heapProp :=
  {| heapProp_holds σ := ∀ a, Ψ a σ |}.
Definition heapProp_forall_aux : seal (@heapProp_forall_def). Proof. by eexists. Qed.
Definition heapProp_forall {A} := unseal heapProp_forall_aux A.
Definition heapProp_forall_eq :
  @heapProp_forall = @heapProp_forall_def := seal_eq heapProp_forall_aux.

Definition heapProp_exist_def {A} (Ψ : A → heapProp) : heapProp :=
  {| heapProp_holds σ := ∃ a, Ψ a σ |}.
Definition heapProp_exist_aux : seal (@heapProp_exist_def). Proof. by eexists. Qed.
Definition heapProp_exist {A} := unseal heapProp_exist_aux A.
Definition heapProp_exist_eq :
  @heapProp_exist = @heapProp_exist_def := seal_eq heapProp_exist_aux.

Definition heapProp_sep_def (P Q : heapProp) : heapProp :=
  {| heapProp_holds σ := ∃ σ1 σ2, σ = σ1 ∪ σ2 ∧ σ1 ##ₘ σ2 ∧ P σ1 ∧ Q σ2 |}.
Definition heapProp_sep_aux : seal (@heapProp_sep_def). Proof. by eexists. Qed.
Definition heapProp_sep := unseal heapProp_sep_aux.
Definition heapProp_sep_eq:
  @heapProp_sep = @heapProp_sep_def := seal_eq heapProp_sep_aux.

Definition heapProp_wand_def (P Q : heapProp) : heapProp :=
  {| heapProp_holds σ := ∀ σ', σ ##ₘ σ' → P σ' → Q (σ ∪ σ') |}.
Definition heapProp_wand_aux : seal (@heapProp_wand_def). Proof. by eexists. Qed.
Definition heapProp_wand := unseal heapProp_wand_aux.
Definition heapProp_wand_eq:
  @heapProp_wand = @heapProp_wand_def := seal_eq heapProp_wand_aux.

Definition heapProp_persistently_def (P : heapProp) : heapProp :=
  {| heapProp_holds σ := P ∅ |}.
Definition heapProp_persistently_aux : seal (@heapProp_persistently_def).
Proof. by eexists. Qed.
Definition heapProp_persistently := unseal heapProp_persistently_aux.
Definition heapProp_persistently_eq:
  @heapProp_persistently = @heapProp_persistently_def := seal_eq heapProp_persistently_aux.

(** Iris's [bi] class requires the presence of a later modality, but for non
step-indexed logics, it can be defined as the identity. *)
Definition heapProp_later (P : heapProp) : heapProp := P.

Definition unseal_eqs :=
  (heapProp_emp_eq, heapProp_pure_eq, heapProp_and_eq, heapProp_or_eq,
   heapProp_impl_eq, heapProp_forall_eq, heapProp_exist_eq,
   heapProp_sep_eq, heapProp_wand_eq, heapProp_persistently_eq).
Ltac unseal := rewrite !unseal_eqs /=.

Section mixins.
  (** Enable [simpl] locally, which is useful for proofs in the model. *)
  Local Arguments heapProp_holds !_ _ /.

  Lemma heapProp_bi_mixin :
    BiMixin
      heapProp_entails heapProp_emp heapProp_pure heapProp_and heapProp_or
      heapProp_impl (@heapProp_forall) (@heapProp_exist)
      heapProp_sep heapProp_wand heapProp_persistently.
  Proof.
    split.
    - (* [PreOrder heapProp_entails] *)
      split; repeat destruct 1; constructor; naive_solver.
    - (* [P ≡ Q ↔ (P ⊢ Q) ∧ (Q ⊢ P)] *)
      intros P Q; split.
      + intros [HPQ]; split; split; naive_solver.
      + intros [[HPQ] [HQP]]; split; naive_solver.
    - (* [Proper (iff ==> dist n) bi_pure] *)
      unseal=> n φ1 φ2 Hφ; split; naive_solver.
    - (* [NonExpansive2 bi_and] *)
      unseal=> n P1 P2 [HP] Q1 Q2 [HQ]; split; naive_solver.
    - (* [NonExpansive2 bi_or] *)
      unseal=> n P1 P2 [HP] Q1 Q2 [HQ]; split; naive_solver.
    - (* [NonExpansive2 bi_impl] *)
      unseal=> n P1 P2 [HP] Q1 Q2 [HQ]; split; naive_solver.
    - (* [Proper (pointwise_relation _ (dist n) ==> dist n) (bi_forall A)] *)
      unseal=> A n Φ1 Φ2 HΦ; split=> σ /=; split=> ? x; by apply HΦ.
    - (* [Proper (pointwise_relation _ (dist n) ==> dist n) (bi_exist A)] *)
      unseal=> A n Φ1 Φ2 HΦ; split=> σ /=; split=> -[x ?]; exists x; by apply HΦ.
    - (* [NonExpansive2 bi_sep] *)
      unseal=> n P1 P2 [HP] Q1 Q2 [HQ]; split; naive_solver.
    - (* [NonExpansive2 bi_wand] *)
      unseal=> n P1 P2 [HP] Q1 Q2 [HQ]; split; naive_solver.
    - (* [NonExpansive2 bi_persistently] *)
      unseal=> n P1 P2 [HP]; split; naive_solver.
    - (* [φ → P ⊢ ⌜ φ ⌝] *)
      unseal=> φ P ?; by split.
    - (* [(φ → True ⊢ P) → ⌜ φ ⌝ ⊢ P] *)
      unseal=> φ P HP; split=> σ ?. by apply HP.
    - (* [P ∧ Q ⊢ P] *)
      unseal=> P Q; split=> σ [??]; done.
    - (* [P ∧ Q ⊢ Q] *)
      unseal=> P Q; split=> σ [??]; done.
    - (* [(P ⊢ Q) → (P ⊢ R) → P ⊢ Q ∧ R] *)
      unseal=> P Q R [HPQ] [HPR]; split=> σ; split; auto.
    - (* [P ⊢ P ∨ Q] *)
      unseal=> P Q; split=> σ; by left.
    - (* [Q ⊢ P ∨ Q] *)
      unseal=> P Q; split=> σ; by right.
    - (* [(P ⊢ R) → (Q ⊢ R) → P ∨ Q ⊢ R] *)
      unseal=> P Q R [HPQ] [HQR]; split=> σ [?|?]; auto.
    - (* [(P ∧ Q ⊢ R) → P ⊢ Q → R] *)
      unseal=> P Q R HPQR; split=> σ ??. by apply HPQR.
    - (* [(P ⊢ Q → R) → P ∧ Q ⊢ R] *)
      unseal=> P Q R HPQR; split=> σ [??]. by apply HPQR.
    - (* [(∀ a, P ⊢ Ψ a) → P ⊢ ∀ a, Ψ a] *)
      unseal=> A P Ψ HPΨ; split=> σ ? a. by apply HPΨ.
    - (* [(∀ a, Ψ a) ⊢ Ψ a] *)
      unseal=> A Ψ a; split=> σ ?; done.
    - (* [Ψ a ⊢ ∃ a, Ψ a] *)
      unseal=> A Ψ a; split=> σ ?. by exists a.
    - (* [(∀ a, Φ a ⊢ Q) → (∃ a, Φ a) ⊢ Q] *)
      unseal=> A Φ Q HΦQ; split=> σ [a ?]. by apply (HΦQ a).
    - (* [(P ⊢ Q) → (P' ⊢ Q') → P ∗ P' ⊢ Q ∗ Q'] *)
      unseal=> P P' Q Q' [HPQ] [HP'Q']; split; naive_solver.
    - (* [P ⊢ emp ∗ P] *)
      unseal=> P; split=> σ ? /=. eexists ∅, σ. rewrite left_id_L.
      split_and!; done || apply map_disjoint_empty_l.
    - (* [emp ∗ P ⊢ P] *)
      unseal=> P; split; intros ? (?&σ&->&?&->&?). by rewrite left_id_L.
    - (* [P ∗ Q ⊢ Q ∗ P] *)
      unseal=> P Q; split; intros ? (σ1&σ2&->&?&?&?).
      exists σ2, σ1. by rewrite map_union_comm.
    - (* [(P ∗ Q) ∗ R ⊢ P ∗ (Q ∗ R)] *)
      unseal=> P Q R; split; intros ? (?&σ3&->&?&(σ1&σ2&->&?&?&?)&?).
      exists σ1, (σ2 ∪ σ3). split_and!; [by rewrite assoc_L|solve_map_disjoint|done|].
      exists σ2, σ3; split_and!; [done|solve_map_disjoint|done..].
    - (* [(P ∗ Q ⊢ R) → P ⊢ Q -∗ R] *)
      unseal=> P Q R [HPQR]; split=> σ1 ? σ2 ??. apply HPQR. by exists σ1, σ2.
    - (* [(P ⊢ Q -∗ R) → P ∗ Q ⊢ R] *)
      unseal=> P Q R [HPQR]; split; intros ? (σ1&σ2&->&?&?&?). by apply HPQR.
    - (* [(P ⊢ Q) → <pers> P ⊢ <pers> Q] *)
      unseal=> P Q [HPQ]; split=> σ. apply HPQ.
    - (* [<pers> P ⊢ <pers> <pers> P] *)
      unseal=> P; split=> σ; done.
    - (* [emp ⊢ <pers> emp] *)
      unseal; split=> σ; done.
    - (* [(∀ a, <pers> (Ψ a)) ⊢ <pers> (∀ a, Ψ a)] *)
      unseal=> A Ψ; split=> σ; done.
    - (* [<pers> (∃ a, Ψ a) ⊢ ∃ a, <pers> (Ψ a)] *)
      unseal=> A Ψ; split=> σ; done.
    - (* [<pers> P ∗ Q ⊢ <pers> P] *)
      unseal=> P Q; split; intros ? (σ1&σ2&->&?&?&?); done.
    - (* [<pers> P ∧ Q ⊢ P ∗ Q] *)
      unseal=> P Q; split=> σ [??]. eexists ∅, σ. rewrite left_id_L.
      split_and!; done || apply map_disjoint_empty_l.
  Qed.

  Lemma heapProp_bi_later_mixin :
    BiLaterMixin
      heapProp_entails heapProp_pure heapProp_or heapProp_impl
      (@heapProp_forall) (@heapProp_exist)
      heapProp_sep heapProp_persistently heapProp_later.
  Proof. eapply bi_later_mixin_id; [done|apply heapProp_bi_mixin]. Qed.
End mixins.

Canonical Structure heapPropI : bi :=
  {| bi_ofe_mixin := ofe_mixin_of heapProp;
     bi_bi_mixin := heapProp_bi_mixin; bi_bi_later_mixin := heapProp_bi_later_mixin |}.

Instance heapProp_pure_forall : BiPureForall heapPropI.
Proof. intros A φ. rewrite /bi_forall /bi_pure /=. unseal. by split. Qed.

Lemma heapProp_proofmode_test {A} (P Q R : heapProp) (Φ Ψ : A → heapProp) :
  P ∗ Q -∗
  □ R -∗
  □ (R -∗ ∃ x, Φ x) -∗
  ∃ x, Φ x ∗ Φ x ∗ P ∗ Q.
Proof.
  iIntros "[HP HQ] #HR #HRΦ".
  iDestruct ("HRΦ" with "HR") as (x) "#HΦ".
  iExists x. iFrame. by iSplitL.
Qed.