Load "Pi2".
(******************************Protocol Pi2'' :**************************************************************************)

Definition t30 := msg (G (N 0)).
Definition t31 := msg (g (N 0)).
Definition phi30 := [t30; t31].
Definition mphi30 := (conv_mylist_listm phi30).
Definition msgt30 := (ostomsg t30).
Definition msgt31 := (ostomsg t31).
Definition grn31 := (exp msgt30 msgt31 (r (N 1))).
Definition qc0000:= (if_then_else_M (EQ_M (reveal (f mphi30)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi30)) (i 2) ) O (if_then_else_M ((EQ_M (to (f mphi30)) (i 1)) & (EQ_M (act (f mphi30)) new)) grn31 (if_then_else_M (EQ_M (to (f mphi30)) (i 1)) grn31 (if_then_else_M ((EQ_M (to (f mphi30)) (i 2)) & (EQ_M (act (f mphi30)) new)) grn31 (if_then_else_M (EQ_M (to (f mphi30)) (i 2)) grn31 O) ) )))).
Definition t32:= msg qc0000.

Definition phi31 := phi30 ++ [ t32 ].

 (***********************************************************)
Definition msgt32:= (ostomsg t32).
Definition mphi31 := (conv_mylist_listm phi31).
Definition mx31rn1 := (exp msgt30 (m (f mphi30 )) (r (N 1))).
Definition mx31rn2 := (exp msgt30 (m (f mphi30 )) (r (N 2))).
Definition grn32:= (exp msgt30 msgt31 (r (N 2))).

(**********qc0000 -> qc1000, qc0010, qc0100, qc0001*************************************************)

Definition qc1000 := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) acc (if_then_else_M ((EQ_M (to (f mphi31)) (i 2)) & (EQ_M (act (f mphi31)) new)) grn32 (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) grn32 O))))).

Definition qc0010:= (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi31)) (i 1) ) & (EQ_M (to (f mphi30)) (i 1))) mx31rn1 (if_then_else_M ((EQ_M (to (f mphi31)) (i 2)) & (EQ_M (act (f mphi31)) new)) grn32 (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) grn32 O) ) ) ).

Definition qc0100 := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) acc (if_then_else_M ((EQ_M (to (f mphi31)) (i 1)) & (EQ_M (act (f mphi31)) new)) grn31 (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) grn31 O))))).

Definition qc0001 :=(if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi31)) (i 1) ) & (EQ_M (to (f mphi30)) (i 1))) mx31rn1 (if_then_else_M ((EQ_M (to (f mphi31)) (i 1)) & (EQ_M (act (f mphi31)) new)) grn32 (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) grn32 O) ) ) ).

Definition t33 := msg (if_then_else_M (EQ_M (reveal (f mphi30)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi30)) (i 2) ) O (if_then_else_M ((EQ_M (to (f mphi30)) (i 1)) & (EQ_M (act (f mphi30)) new)) qc1000 (if_then_else_M (EQ_M (to (f mphi30)) (i 1)) qc0010 (if_then_else_M ((EQ_M (to (f mphi30)) (i 2)) & (EQ_M (act (f mphi30)) new)) qc0100 (if_then_else_M (EQ_M (to (f mphi30)) (i 2)) qc0001 O) ) )))).
Definition phi32:= phi31 ++ [t33].

(***************************************************************************)
Definition msgt33:= (ostomsg t33).
Definition mphi32 := (conv_mylist_listm phi32).

Definition mx32rn1 := (exp msgt30 (m (f mphi31 )) (r (N 1))).
Definition mx32rn2 := (exp msgt30 (m (f mphi31 )) (r (N 2))).
Definition grn33:= (exp msgt30 msgt31 (r (N 3))).

(************* qc1000 -> qc2000, qc1100, qc1001*******************************************************)

Definition qc2000 :=  (if_then_else_M (EQ_M (reveal (f mphi32)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 1) ) & (EQ_M (to (f mphi31)) (i 1)) &(EQ_M (to (f mphi30)) (i 1)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))   mx32rn1 (if_then_else_M ((EQ_M (to (f mphi32)) (i 2)) & (EQ_M (act (f mphi32)) new)) grn33 (if_then_else_M (EQ_M (to (f mphi32)) (i 2)) grn33 O) ) ) ).

Definition qc1100 := (if_then_else_M (EQ_M (reveal (f mphi32)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi32)) (i 2) ) O (if_then_else_M (EQ_M (to (f mphi32)) (i 1)) acc (if_then_else_M ((EQ_M (to (f mphi32)) (i 2)) ) acc O) ))).
Definition qc1001 := (if_then_else_M (EQ_M (reveal (f mphi32)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 2) ) & (EQ_M (to (f mphi30)) (i 2)))  mx31rn1 (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 2) ) & (EQ_M (to (f mphi31)) (i 2))) mx32rn2  (if_then_else_M (EQ_M (to (f mphi32)) (i 1)) acc O)))).
(************qc0010 -> qc0020, qc0110, qc0011*********************************************************)

Definition qc0110 := (if_then_else_M (EQ_M (reveal (f mphi32)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 1) ) & (EQ_M (to (f mphi30)) (i 1)))  mx31rn1 (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 1) ) & (EQ_M (to (f mphi31)) (i 1))) mx32rn2  (if_then_else_M (EQ_M (to (f mphi32)) (i 2)) acc O)))).

(*****************qc0100 -> qc0200, qc1100, qc0110****************************************************)

Definition qc0200 :=  (if_then_else_M (EQ_M (reveal (f mphi32)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 2) ) & (EQ_M (to (f mphi31)) (i 2)) &(EQ_M (to (f mphi30)) (i 2)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))   mx32rn1 (if_then_else_M ((EQ_M (to (f mphi32)) (i 1)) & (EQ_M (act (f mphi32)) new)) grn33 (if_then_else_M (EQ_M (to (f mphi32)) (i 1)) grn33 O) ) ) ).

(******************qc0001 -> qc0002, qc1001, qc0011****************************************************)

(*****************************************************************************************************)

Definition qc1000_s := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) qc2000 (if_then_else_M ((EQ_M (to (f mphi31)) (i 2)) & (EQ_M (act (f mphi31)) new)) qc1100 (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) qc1001 O))))).

Definition qc0010_s := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi31)) (i 1) ) & (EQ_M (to (f mphi30)) (i 1))) O (if_then_else_M ((EQ_M (to (f mphi31)) (i 2)) & (EQ_M (act (f mphi31)) new)) qc0110 (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) O O) ) ) ).

Definition qc0100_s := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) qc0200 (if_then_else_M ((EQ_M (to (f mphi31)) (i 1)) & (EQ_M (act (f mphi31)) new)) qc1100 (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) qc0110 O))))).

Definition qc0001_s := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi31)) (i 1) ) & (EQ_M (to (f mphi30)) (i 1))) O (if_then_else_M ((EQ_M (to (f mphi31)) (i 1)) & (EQ_M (act (f mphi31)) new)) qc1001 (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) O O) ) ) ).

Definition t34 := msg (if_then_else_M (EQ_M (reveal (f mphi30)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi30)) (i 2) ) O (if_then_else_M ((EQ_M (to (f mphi30)) (i 1)) & (EQ_M (act (f mphi30)) new)) qc1000_s (if_then_else_M (EQ_M (to (f mphi30)) (i 1)) qc0010_s (if_then_else_M ((EQ_M (to (f mphi30)) (i 2)) & (EQ_M (act (f mphi30)) new)) qc0100_s (if_then_else_M (EQ_M (to (f mphi30)) (i 2)) qc0001_s O) ) )))).

Definition phi33:= phi32 ++ [t34].
(***********************************************************************************************)
Definition mx33rn2 := (exp msgt30 (m (f mphi32 )) (r (N 2))).
Definition mx33rn1 := (exp msgt30 (m (f mphi32 )) (r (N 1))).
Definition mphi33 := (conv_mylist_listm phi33).

(********************qc2000 -> qc3000, qc2100, qc2001****************************************************)
Definition qc2100 := (if_then_else_M (EQ_M (reveal (f mphi33)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 1) ) & (EQ_M (to (f mphi31)) (i 1)) &(EQ_M (to (f mphi30)) (i 1)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))   mx32rn1 (if_then_else_M (EQ_M (to (f mphi33)) (i 2)) acc O ) )).
(**************************qc1100 -> qc2100, qc1200 *****************************************************)
Definition qc1200 := (if_then_else_M (EQ_M (reveal (f mphi33)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 2) ) & (EQ_M (to (f mphi31)) (i 2)) &(EQ_M (to (f mphi30)) (i 2)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))   mx32rn1 (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 2) ) & (EQ_M (to (f mphi32)) (i 2)) &(EQ_M (to (f mphi31)) (i 2)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi31)) new))   mx33rn2 (if_then_else_M (EQ_M (to (f mphi33)) (i 1)) acc O)) ) ).
(**********Changes to the states qc2001, qc0210 in protocol2**************************************************)
(**Definition grn34:= (exp msgt30 msgt31 (r (N 4))).**)
Definition qc2001 := (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 2) ) & (EQ_M (to (f mphi32)) (i 1)) &(EQ_M (to (f mphi31)) (i 2))&(EQ_M (to (f mphi30)) (i 1)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi30)) new) &(EQ_M (m (f mphi31)) grn31) &(EQ_M (m (f mphi32)) grn12))   mx32rn2 (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 1) ) & (EQ_M (to (f mphi32)) (i 1)) &(EQ_M (to (f mphi31)) (i 2))&(EQ_M (to (f mphi30)) (i 1)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi30)) new) &(EQ_M (m (f mphi31)) grn31) &(EQ_M (m (f mphi32)) grn12))   mx33rn1 (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 1) ) & (EQ_M (to (f mphi32)) (i 1)) &(EQ_M (to (f mphi31)) (i 1)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi31)) new))   mx33rn2 O ))).

Definition qc0210 :=  (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 1) ) & (EQ_M (to (f mphi32)) (i 2)) &(EQ_M (to (f mphi31)) (i 1))&(EQ_M (to (f mphi30)) (i 2)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi30)) new) &(EQ_M (m (f mphi31)) grn31) &(EQ_M (m (f mphi32)) grn12))   mx32rn2 (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 2) ) & (EQ_M (to (f mphi32)) (i 2)) &(EQ_M (to (f mphi31)) (i 1))&(EQ_M (to (f mphi30)) (i 2)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi30)) new) &(EQ_M (m (f mphi31)) grn31) &(EQ_M (m (f mphi32)) grn12))  mx33rn1 (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 2) ) & (EQ_M (to (f mphi31)) (i 2)) &(EQ_M (to (f mphi30)) (i 2)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))   mx32rn1 O ))).

(********************************************************************************************************)
Definition qc0120 := (if_then_else_M (EQ_M (reveal (f mphi33)) (i 1) ) O ( if_then_else_M (EQ_M (to (f mphi31)) (i 2)) grn33 O)).

(*****************************qc1001 -> qc1002, qc2001***************************************************)

Definition qc2000_s :=  (if_then_else_M (EQ_M (reveal (f mphi32)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 1) ) & (EQ_M (to (f mphi31)) (i 1)) &(EQ_M (to (f mphi30)) (i 1)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new)) O (if_then_else_M ((EQ_M (to (f mphi32)) (i 2)) & (EQ_M (act (f mphi32)) new)) qc2100 (if_then_else_M (EQ_M (to (f mphi32)) (i 2)) qc2001 O) ) ) ).

Definition qc1100_s := (if_then_else_M (EQ_M (reveal (f mphi32)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi32)) (i 2) ) O (if_then_else_M (EQ_M (to (f mphi32)) (i 1)) qc2100 (if_then_else_M ((EQ_M (to (f mphi32)) (i 2)) ) qc1200 O) ))).
Definition qc1001_s := (if_then_else_M (EQ_M (reveal (f mphi32)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 2) ) & (EQ_M (to (f mphi30)) (i 2)))  O (if_then_else_M (EQ_M (to (f mphi32)) (i 1)) qc2001 O))).

Definition qc0110_s := (if_then_else_M (EQ_M (reveal (f mphi32)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 1) ) & (EQ_M (to (f mphi30)) (i 1)))  qc0120 (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 1) ) & (EQ_M (to (f mphi31)) (i 1))) qc0120  (if_then_else_M (EQ_M (to (f mphi32)) (i 2)) qc0210 O)))).

Definition qc0200_s :=  (if_then_else_M (EQ_M (reveal (f mphi32)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 2) ) & (EQ_M (to (f mphi31)) (i 2)) &(EQ_M (to (f mphi30)) (i 2)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))   O (if_then_else_M ((EQ_M (to (f mphi32)) (i 1)) & (EQ_M (act (f mphi32)) new)) qc1200 (if_then_else_M (EQ_M (to (f mphi32)) (i 1)) qc0210 O) ) ) ).
(***********************************************************************************************************)

Definition qc1000_ss := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) qc2000_s (if_then_else_M ((EQ_M (to (f mphi31)) (i 2)) & (EQ_M (act (f mphi31)) new)) qc1100_s (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) qc1001_s O))))).

Definition qc0010_ss := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi31)) (i 1) ) & (EQ_M (to (f mphi30)) (i 1))) O (if_then_else_M ((EQ_M (to (f mphi31)) (i 2)) & (EQ_M (act (f mphi31)) new)) qc0110_s (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) O O) ) ) ).

Definition qc0100_ss := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) qc0200_s (if_then_else_M ((EQ_M (to (f mphi31)) (i 1)) & (EQ_M (act (f mphi31)) new)) qc1100_s (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) qc0110_s O))))).

Definition qc0001_ss := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi31)) (i 1) ) & (EQ_M (to (f mphi30)) (i 1))) O (if_then_else_M ((EQ_M (to (f mphi31)) (i 1)) & (EQ_M (act (f mphi31)) new)) qc1001_s (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) O O) ) ) ).

Definition t35 := msg (if_then_else_M (EQ_M (reveal (f mphi30)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi30)) (i 2) ) O (if_then_else_M ((EQ_M (to (f mphi30)) (i 1)) & (EQ_M (act (f mphi30)) new)) qc1000_ss (if_then_else_M (EQ_M (to (f mphi30)) (i 1)) qc0010_ss (if_then_else_M ((EQ_M (to (f mphi30)) (i 2)) & (EQ_M (act (f mphi30)) new)) qc0100_ss (if_then_else_M (EQ_M (to (f mphi30)) (i 2)) qc0001_ss O) ) )))).

Definition phi34 :=  phi33 ++ [ t35 ].

(***********************************************************************************************************)
Definition mx34rn3 := (exp msgt30 (m (f mphi33 )) (r (N 3))).
Definition mphi34 := (conv_mylist_listm phi34).

(********************qc2100 -> qc2200, qc3100************************************)

Definition qc2200 := (if_then_else_M ((EQ_M (reveal (f mphi34)) (i 1) ) & (EQ_M (to (f mphi31)) (i 1)) &(EQ_M (to (f mphi30)) (i 1)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))   mx32rn1 (if_then_else_M ((EQ_M (reveal (f mphi34)) (i 2) ) & (EQ_M (to (f mphi33)) (i 2)) &(EQ_M (to (f mphi32)) (i 2)) & (notb (EQ_M ( act(f mphi33)) new)) &(EQ_M (act (f mphi32)) new))   mx34rn3 O)).

Definition qc2100_s := (if_then_else_M (EQ_M (reveal (f mphi33)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 1) ) & (EQ_M (to (f mphi31)) (i 1)) &(EQ_M (to (f mphi30)) (i 1)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))   O (if_then_else_M (EQ_M (to (f mphi33)) (i 2)) qc2200 O ) )).

Definition qc1200_s := (if_then_else_M (EQ_M (reveal (f mphi33)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 2) ) & (EQ_M (to (f mphi31)) (i 2)) &(EQ_M (to (f mphi30)) (i 2)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))  O (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 2) ) & (EQ_M (to (f mphi32)) (i 2)) &(EQ_M (to (f mphi31)) (i 2)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi31)) new))  O (if_then_else_M (EQ_M (to (f mphi33)) (i 1)) qc2200 O)) ) ).
Definition qc2001_s :=  (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 1) ) & (EQ_M (to (f mphi31)) (i 1)) &(EQ_M (to (f mphi30)) (i 1)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))   O (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 1) ) & (EQ_M (to (f mphi32)) (i 1)) &(EQ_M (to (f mphi31)) (i 1)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi31)) new))   O O )).
(*****************************Changes in protocol2********************************)
Definition qc0210_s :=  (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 2) ) & (EQ_M (to (f mphi32)) (i 1)) &(EQ_M (to (f mphi31)) (i 2))&(EQ_M (to (f mphi30)) (i 1)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi30)) new) &(EQ_M (m (f mphi31)) grn31) &(EQ_M (m (f mphi32)) grn33))   O (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 1) ) & (EQ_M (to (f mphi32)) (i 1)) &(EQ_M (to (f mphi31)) (i 2))&(EQ_M (to (f mphi30)) (i 1)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi30)) new) &(EQ_M (m (f mphi31)) grn31) &(EQ_M (m (f mphi32)) grn33))   O (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 2) ) & (EQ_M (to (f mphi31)) (i 2)) &(EQ_M (to (f mphi30)) (i 2)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))  O O ))).
Definition qc0120_s := (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 1) ) & (EQ_M (to (f mphi32)) (i 2)) &(EQ_M (to (f mphi31)) (i 1))&(EQ_M (to (f mphi30)) (i 2)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi30)) new) &(EQ_M (m (f mphi31)) grn31) &(EQ_M (m (f mphi32)) grn33))   O (if_then_else_M ((EQ_M (reveal (f mphi33)) (i 2) ) & (EQ_M (to (f mphi32)) (i 2)) &(EQ_M (to (f mphi31)) (i 1))&(EQ_M (to (f mphi30)) (i 2)) & (notb (EQ_M ( act(f mphi32)) new)) &(EQ_M (act (f mphi30)) new) &(EQ_M (m (f mphi31)) grn31) &(EQ_M (m (f mphi32)) grn33))   O (if_then_else_M (EQ_M (reveal (f mphi33)) (i 1) ) O ( if_then_else_M (EQ_M (to (f mphi31)) (i 2)) O O)))).
(********************************************************************************)
Definition qc2000_ss :=  (if_then_else_M (EQ_M (reveal (f mphi32)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 1) ) & (EQ_M (to (f mphi31)) (i 1)) &(EQ_M (to (f mphi30)) (i 1)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new)) O (if_then_else_M ((EQ_M (to (f mphi32)) (i 2)) & (EQ_M (act (f mphi32)) new)) qc2100 (if_then_else_M (EQ_M (to (f mphi32)) (i 2)) qc2001 O) ) ) ).

Definition qc1100_ss := (if_then_else_M (EQ_M (reveal (f mphi32)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi32)) (i 2) ) O (if_then_else_M (EQ_M (to (f mphi32)) (i 1)) qc2100_s (if_then_else_M ((EQ_M (to (f mphi32)) (i 2)) ) qc1200_s O) ))).
Definition qc1001_ss := (if_then_else_M (EQ_M (reveal (f mphi32)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 2) ) & (EQ_M (to (f mphi30)) (i 2)))  O (if_then_else_M (EQ_M (to (f mphi32)) (i 1)) qc2001_s O))).

Definition qc0110_ss := (if_then_else_M (EQ_M (reveal (f mphi32)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 1) ) & (EQ_M (to (f mphi30)) (i 1)))  qc0120 (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 1) ) & (EQ_M (to (f mphi31)) (i 1))) qc0120_s  (if_then_else_M (EQ_M (to (f mphi32)) (i 2)) qc0210_s O)))).

Definition qc0200_ss :=  (if_then_else_M (EQ_M (reveal (f mphi32)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi32)) (i 2) ) & (EQ_M (to (f mphi31)) (i 2)) &(EQ_M (to (f mphi30)) (i 2)) & (notb (EQ_M ( act(f mphi31)) new)) &(EQ_M (act (f mphi30)) new))   O (if_then_else_M ((EQ_M (to (f mphi32)) (i 1)) & (EQ_M (act (f mphi32)) new)) qc1200_s (if_then_else_M (EQ_M (to (f mphi32)) (i 1)) qc0210_s O) ) ) ).
(**********************************************************************************************)

Definition qc1000_sss := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) qc2000_ss (if_then_else_M ((EQ_M (to (f mphi31)) (i 2)) & (EQ_M (act (f mphi31)) new)) qc1100_ss (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) qc1001_ss O))))).

Definition qc0010_sss := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M ((EQ_M (reveal (f mphi31)) (i 1) ) & (EQ_M (to (f mphi30)) (i 1))) O (if_then_else_M ((EQ_M (to (f mphi31)) (i 2)) & (EQ_M (act (f mphi31)) new)) qc0110_ss (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) O O) ) ) ).

Definition qc0100_sss := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi31)) (i 2) ) O (if_then_else_M (EQ_M (to (f mphi31)) (i 2)) qc0200_ss (if_then_else_M ((EQ_M (to (f mphi31)) (i 1)) & (EQ_M (act (f mphi31)) new)) qc1100_ss (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) qc0110_ss O))))).

Definition qc0001_sss := (if_then_else_M (EQ_M (reveal (f mphi31)) (i 1) ) O (if_then_else_M ((EQ_M (reveal (f mphi31)) (i 1) ) & (EQ_M (to (f mphi30)) (i 1))) O (if_then_else_M ((EQ_M (to (f mphi31)) (i 1)) & (EQ_M (act (f mphi31)) new)) qc1001_ss (if_then_else_M (EQ_M (to (f mphi31)) (i 1)) O O) ) ) ).

Definition t36 := msg (if_then_else_M (EQ_M (reveal (f mphi30)) (i 1) ) O (if_then_else_M (EQ_M (reveal (f mphi30)) (i 2) ) O (if_then_else_M ((EQ_M (to (f mphi30)) (i 1)) & (EQ_M (act (f mphi30)) new)) qc1000_sss (if_then_else_M (EQ_M (to (f mphi30)) (i 1)) qc0010_sss (if_then_else_M ((EQ_M (to (f mphi30)) (i 2)) & (EQ_M (act (f mphi30)) new)) qc0100_sss (if_then_else_M (EQ_M (to (f mphi30)) (i 2)) qc0001_sss O) ) )))).

Definition phi35  := phi34 ++ [ t36].

(**************************************************************************************************)
(***************************************************************************************************)

Theorem RRS1: phi11 ~ phi31.
Proof. reflexivity. Qed.

Theorem RRS2: phi12 ~ phi32.
Proof. reflexivity. Qed.

Theorem RRS3: phi13 ~ phi33.
Proof. reflexivity. Qed.
Theorem RRS4: t15 ### t35.
Proof.  repeat try unfold phi35, phi15, phi34, phi14, phi33, phi13, phi32, phi12 ,phi31, phi11, phi30, phi10.
repeat try unfold t30, t10, t31,t32, t11,t12, t33, t13, t34, t14, t35, t15, t36, t16.

repeat try unfold qa0000, qa1000 , qa0010,qa0100,qa0001 ,qa2000,qa1100 ,qa1001 ,qa0110,qa0200,qa1000_s,qa0010_s,qa0100_s,qa0001_s,qa2100,qa1200,qa2001,qa0210,
 qa0120,qa2000_s, qa1100_s, qa1001_s, qa0110_s,qa0200_s,qa1000_ss,qa0010_ss, qa0100_ss,qa0001_ss,qa2200,qa2100_s,qa1200_s,qa2001_s,qa0210_s,qa0120_s,qa2000_ss,qa1100_ss ,qa1001_ss,qa0110_ss,qa0200_ss,
 qa1000_sss,qa0010_sss,qa0100_sss,qa0001_sss.
simpl.
repeat try unfold qc0000, qc1000 , qc0010,qc0100,qc0001 ,qc2000,qc1100 ,qc1001 ,qc0110,qc0200,qc1000_s,qc0010_s,qc0100_s,qc0001_s,qc2100,qc1200,qc2001,qc0210,
qc0120,qc2000_s, qc1100_s, qc1001_s, qc0110_s,qc0200_s.

try unfold qc1000_ss,qc0010_ss, qc0100_ss,qc0001_ss,qc2200,qc2100_s,qc1200_s,qc2001_s,qc0210_s,qc0120_s,qc2000_ss,qc1100_ss ,qc1001_ss,qc0110_ss,qc0200_ss,
qc1000_sss,qc0010_sss,qc0100_sss,qc0001_sss.
rewrite IFSAME_M with (b:= (EQ_M (to (f mphi11)) (i 1))) (x:= O) .
rewrite IFSAME_M with (b:= (EQ_M (to (f mphi31)) (i 1))) (x:= O) .
repeat try unfold qa0000, qa1000 , qa0010,qa0100,qa0001 ,qa2000,qa1100 ,qa1001 ,qa0110,qa0200,qa1000_s,qa0010_s,qa0100_s,qa0001_s,qa2100,qa1200,qa2001,qa0210,
 qa0120,qa2000_s, qa1100_s, qa1001_s, qa0110_s,qa0200_s,qa1000_ss,qa0010_ss, qa0100_ss,qa0001_ss,qa2200,qa2100_s,qa1200_s,qa2001_s,qa0210_s,qa0120_s,qa2000_ss,qa1100_ss ,qa1001_ss,qa0110_ss,qa0200_ss,
 qa1000_sss,qa0010_sss,qa0100_sss,qa0001_sss.
simpl.
repeat try unfold qc0000, qc1000 , qc0010,qc0100,qc0001 ,qc2000,qc1100 ,qc1001 ,qc0110,qc0200,qc1000_s,qc0010_s,qc0100_s,qc0001_s,qc2100,qc1200,qc2001,qc0210,
qc0120,qc2000_s, qc1100_s, qc1001_s, qc0110_s,qc0200_s.

try unfold qc1000_ss,qc0010_ss, qc0100_ss,qc0001_ss,qc2200,qc2100_s,qc1200_s,qc2001_s,qc0210_s,qc0120_s,qc2000_ss,qc1100_ss ,qc1001_ss,qc0110_ss,qc0200_ss,
qc1000_sss,qc0010_sss,qc0100_sss,qc0001_sss.

Admitted.

Theorem RRS5: phi14 ~ phi34.
Proof.  repeat try unfold phi35, phi15, phi34, phi14, phi33, phi13, phi32, phi12 ,phi31, phi11, phi30, phi10.
repeat try unfold t30, t10, t31,t32, t11,t12, t33, t13, t34, t14, t35, t15, t36, t16.

repeat try unfold qa0000, qa1000 , qa0010,qa0100,qa0001 ,qa2000,qa1100 ,qa1001 ,qa0110,qa0200,qa1000_s,qa0010_s,qa0100_s,qa0001_s,qa2100,qa1200,qa2001,qa0210,
 qa0120,qa2000_s, qa1100_s, qa1001_s, qa0110_s,qa0200_s,qa1000_ss,qa0010_ss, qa0100_ss,qa0001_ss,qa2200,qa2100_s,qa1200_s,qa2001_s,qa0210_s,qa0120_s,qa2000_ss,qa1100_ss ,qa1001_ss,qa0110_ss,qa0200_ss,
 qa1000_sss,qa0010_sss,qa0100_sss,qa0001_sss.
simpl.
repeat try unfold qc0000, qc1000 , qc0010,qc0100,qc0001 ,qc2000,qc1100 ,qc1001 ,qc0110,qc0200,qc1000_s,qc0010_s,qc0100_s,qc0001_s,qc2100,qc1200,qc2001,qc0210,
qc0120,qc2000_s, qc1100_s, qc1001_s, qc0110_s,qc0200_s.

try unfold qc1000_ss,qc0010_ss, qc0100_ss,qc0001_ss,qc2200,qc2100_s,qc1200_s,qc2001_s,qc0210_s,qc0120_s,qc2000_ss,qc1100_ss ,qc1001_ss,qc0110_ss,qc0200_ss,
qc1000_sss,qc0010_sss,qc0100_sss,qc0001_sss.

pose proof(IFSAME_M).
rewrite IFSAME_M with (b:= (EQ_M (to (f mphi11)) (i 1))) (x:= O) .
rewrite IFSAME_M with (b:= (EQ_M (to (f mphi31)) (i 1))) (x:= O) .
repeat try unfold qc0000, qc1000 , qc0010,qc0100,qc0001 ,qc2000,qc1100 ,qc1001 ,qc0110,qc0200,qc1000_s,qc0010_s,qc0100_s,qc0001_s,qc2100,qc1200,qc2001,qc0210,
qc0120,qc2000_s, qc1100_s, qc1001_s, qc0110_s,qc0200_s.

try unfold qc1000_ss,qc0010_ss, qc0100_ss,qc0001_ss,qc2200,qc2100_s,qc1200_s,qc2001_s,qc0210_s,qc0120_s,qc2000_ss,qc1100_ss ,qc1001_ss,qc0110_ss,qc0200_ss,
qc1000_sss,qc0010_sss,qc0100_sss,qc0001_sss.

try unfold mphi25 , mphi24 , mphi23 , mphi22. try unfold mphi21, mphi20.
 try unfold mphi35 , mphi34 , mphi33 , mphi32. try unfold mphi31, mphi30. simpl.

 repeat try unfold phi35, phi15, phi34, phi14, phi33, phi13, phi32, phi12 ,phi31, phi11, phi30, phi10 .
repeat try unfold t30, t10, t31,t32, t11,t12, t33, t13, t34, t14, t35, t15, t36, t16.
 try unfold mphi15 , mphi14 , mphi13 , mphi12. try unfold mphi11, mphi10.
 try unfold mphi35 , mphi34 , mphi33 , mphi32. try unfold mphi31, mphi30. simpl.

repeat try unfold qa0000, qa1000 , qa0010,qa0100,qa0001 ,qa2000,qa1100 ,qa1001 ,qa0110,qa0200,qa1000_s,qa0010_s,qa0100_s,qa0001_s,qa2100,qa1200,qa2001,qa0210,
 qa0120,qa2000_s, qa1100_s, qa1001_s, qa0110_s,qa0200_s,qa1000_ss,qa0010_ss, qa0100_ss,qa0001_ss,qa2200,qa2100_s,qa1200_s,qa2001_s,qa0210_s,qa0120_s,qa2000_ss,qa1100_ss ,qa1001_ss,qa0110_ss,qa0200_ss,
 qa1000_sss,qa0010_sss,qa0100_sss,qa0001_sss.

repeat try unfold qc0000, qc1000 , qc0010,qc0100,qc0001 ,qc2000,qc1100 ,qc1001 ,qc0110,qc0200,qc1000_s,qc0010_s,qc0100_s,qc0001_s,qc2100,qc1200,qc2001,qc0210,
 qc0120,qc2000_s, qc1100_s, qc1001_s, qc0110_s,qc0200_s,qc1000_ss,qc0010_ss, qc0100_ss,qc0001_ss,qc2200,qc2100_s,qc1200_s,qc2001_s,qc0210_s,qc0120_s,qc2000_ss,qc1100_ss ,qc1001_ss,qc0110_ss,qc0200_ss,
 qc1000_sss,qc0010_sss,qc0100_sss,qc0001_sss.

 repeat try unfold phi35, phi15, phi34, phi14, phi33, phi13, phi32, phi12 ,phi31, phi11, phi30, phi10 .
Admitted.

Theorem RRS7: [t14] ~ [t34].
Proof. repeat try unfold t30, t10, t31,t32, t11,t12, t33, t13, t34, t14, t35, t15, t36, t16.
repeat try unfold qa0000, qa1000 , qa0010,qa0100,qa0001 ,qa2000,qa1100 ,qa1001 ,qa0110,qa0200,qa1000_s,qa0010_s,qa0100_s,qa0001_s,qa2100,qa1200,qa2001,qa0210,
 qa0120,qa2000_s, qa1100_s, qa1001_s, qa0110_s,qa0200_s,qa1000_ss,qa0010_ss, qa0100_ss,qa0001_ss,qa2200,qa2100_s,qa1200_s,qa2001_s,qa0210_s,qa0120_s,qa2000_ss,qa1100_ss ,qa1001_ss,qa0110_ss,qa0200_ss,
 qa1000_sss,qa0010_sss,qa0100_sss,qa0001_sss.

repeat try unfold qc0000, qc1000 , qc0010,qc0100,qc0001 ,qc2000,qc1100 ,qc1001 ,qc0110,qc0200,qc1000_s,qc0010_s,qc0100_s,qc0001_s,qc2100,qc1200,qc2001,qc0210,
 qc0120,qc2000_s, qc1100_s, qc1001_s, qc0110_s,qc0200_s,qc1000_ss,qc0010_ss, qc0100_ss,qc0001_ss,qc2200,qc2100_s,qc1200_s,qc2001_s,qc0210_s,qc0120_s,qc2000_ss,qc1100_ss ,qc1001_ss,qc0110_ss,qc0200_ss,
 qc1000_sss,qc0010_sss,qc0100_sss,qc0001_sss.
try unfold mphi15 , mphi14 , mphi13.  try unfold mphi12, mphi11, mphi10.
 try unfold mphi35 , mphi34 , mphi33 , mphi32. try unfold mphi31, mphi30. simpl.
try unfold mphi15 , mphi14 , mphi13 , mphi12. try unfold mphi11, mphi10.
 try unfold mphi35 , mphi34 , mphi33 , mphi32. try unfold mphi31, mphi30. simpl.
Admitted.


(** * Implementation of Section 4.8 *)
Require Import RL.Utilities.Rpos.
Require Import RL.Utilities.polynomials.
Require Import RL.Utilities.riesz_logic_Nat_more.
Require Import riesz_logic_List_more.
Require Import RL.hr.hr.
Require Import RL.hr.term.
Require Import RL.hr.semantic.
Require Import RL.hr.hseq.
Require Import RL.hr.p_hseq.
Require Import RL.hr.lambda_prop_tools.
Require Import RL.hr.invertibility.
Require Import RL.hr.can_elim.
Require Import RL.hr.M_elim.
Require Import RL.hr.tech_lemmas.

Require Import CMorphisms.
Require Import Lra.
Require Import Lia.
Require Import FunctionalExtensionality.
Require Import Program.

Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

Import EqNotations.

Local Open Scope R_scope.

(** ** Lambda property *)
Lemma hrr_fuse :
  forall G T A r1 r2,
    HR_T_M (((r1, A) :: (r2 , A) :: T) :: G) ->
    HR_T_M (((plus_pos r1 r2, A) :: T) :: G).
Proof.
  intros G T A r1 r2 pi.
  apply hrr_can_elim.
  unfold HR_full.
  change hr_frag_full with (hr_frag_add_CAN hr_frag_full).
  apply hrr_can_fuse.
  apply HR_le_frag with hr_frag_T_M; try assumption.
  repeat split.
Qed.

Lemma hrr_unfuse :
  forall G T A r1 r2,
    HR_T_M (((plus_pos r1 r2, A) :: T) :: G) ->
    HR_T_M (((r1, A) :: (r2 , A) :: T) :: G).
Proof.
  intros G T A r1 r2 pi.
  apply hrr_can_elim.
  unfold HR_full.
  change hr_frag_full with (hr_frag_add_CAN hr_frag_full).
  apply hrr_can_unfuse.
  apply HR_le_frag with hr_frag_T_M; try assumption.
  repeat split.
Qed.

Lemma hrr_unfuse_gen :
  forall G T D r1 r2,
    HR_T_M ((hseq.seq_mul (plus_pos r1 r2) D ++ T) :: G) ->
    HR_T_M ((hseq.seq_mul r1 D ++ hseq.seq_mul r2 D ++ T) :: G).
Proof.
  intros G T D r1 r2.
  revert T; induction D; intros T pi; try assumption.
  - destruct a as [a A]; simpl in *.
    apply hrr_ex_seq with ((time_pos r1 a, A) :: (time_pos r2 a, A) :: hseq.seq_mul r1 D ++ hseq.seq_mul r2 D ++ T); [ Permutation_Type_solve | ].
    apply hrr_unfuse.
    replace (plus_pos (time_pos r1 a) (time_pos r2 a)) with (time_pos (plus_pos r1 r2) a) by (destruct r1; destruct r2; destruct a; apply Rpos_eq; simpl; nra).
    apply hrr_ex_seq with (hseq.seq_mul r1 D ++ hseq.seq_mul r2 D ++ (time_pos (plus_pos r1 r2) a, A) :: T) ; [ Permutation_Type_solve | ].
    apply IHD.
    eapply hrr_ex_seq ; [ | apply pi].
    Permutation_Type_solve.
Qed.

Lemma hrr_fuse_gen :
  forall G T D r1 r2,
    HR_T_M ((hseq.seq_mul r1 D ++ hseq.seq_mul r2 D ++ T) :: G) ->
    HR_T_M ((hseq.seq_mul (plus_pos r1 r2) D ++ T) :: G).
Proof.
  intros G T D r1 r2.
  revert T; induction D; intros T pi; try assumption.
  - destruct a as [a A]; simpl in *.
    replace (time_pos (plus_pos r1 r2) a) with (plus_pos (time_pos r1 a) (time_pos r2 a)) by (destruct r1; destruct r2; destruct a; apply Rpos_eq; simpl; nra).
    apply hrr_fuse.
    apply hrr_ex_seq with (hseq.seq_mul (plus_pos r1 r2) D ++ (time_pos r1 a, A) :: (time_pos r2 a, A) :: T) ; [ Permutation_Type_solve | ].
    apply IHD.
    eapply hrr_ex_seq ; [ | apply pi].
    Permutation_Type_solve.
Qed.

(* begin hide *)
Lemma concat_with_coeff_mul_oadd_Rpos_list_fuse : forall G T H L1 L2,
    length L1 = length L2 ->
    HR_T_M ((concat_with_coeff_mul G L1 ++ concat_with_coeff_mul G L2 ++ T) :: H) ->
    HR_T_M ((concat_with_coeff_mul G (oadd_Rpos_list L1 L2) ++ T) :: H).
Proof.
  intros G T H L1; revert G T H; induction L1; intros G T H L2 Hlen pi; [ destruct L2; inversion Hlen; destruct G; apply pi | ].
  destruct L2; inversion Hlen.
  destruct G; [ apply pi | ].
  destruct a; destruct o; simpl in *.
  - rewrite<- app_assoc; apply hrr_fuse_gen.
    apply hrr_ex_seq with (concat_with_coeff_mul G (oadd_Rpos_list L1 L2) ++ (hseq.seq_mul r s ++ hseq.seq_mul r0 s ++ T)) ; [ Permutation_Type_solve | ].
    apply IHL1; try assumption.
    eapply hrr_ex_seq ; [ | apply pi].
    Permutation_Type_solve.
  - apply hrr_ex_seq with (concat_with_coeff_mul G (oadd_Rpos_list L1 L2) ++ (hseq.seq_mul r s ++ T)) ; [ Permutation_Type_solve | ].
    apply IHL1; try assumption.
    eapply hrr_ex_seq ; [ | apply pi].
    Permutation_Type_solve.
  - apply hrr_ex_seq with (concat_with_coeff_mul G (oadd_Rpos_list L1 L2) ++ (hseq.seq_mul r s ++ T)) ; [ Permutation_Type_solve | ].
    apply IHL1; try assumption.
    eapply hrr_ex_seq ; [ | apply pi].
    Permutation_Type_solve.
  - apply IHL1; try assumption.
Qed.
(* end hide *)

Lemma lambda_prop :
  forall G,
    hseq_is_atomic G ->
    HR_T_M G ->
    { L &
      prod (length L = length G)
           ((Exists_inf (fun x => x <> None) L) *
            (forall n, sum_weight_var_with_coeff n G L = 0))}.
Proof.
  intros G Ha pi.
  induction pi.
  - split with ((Some One) :: nil).
    repeat split; try reflexivity.
    + apply Exists_inf_cons_hd.
      intros H; inversion H.
    + intros n.
      simpl; nra.
  - inversion Ha; subst.
    destruct (IHpi X0) as [L [Hlen [Hex Hsum]]].
    split with (None :: L).
    repeat split; auto.
    simpl; rewrite Hlen; reflexivity.
  - inversion Ha; subst.
    destruct IHpi as [L [Hlen [Hex Hsum]]].
    { apply Forall_inf_cons ;[ | apply Forall_inf_cons]; try assumption. }
    destruct L; [ | destruct L]; try now inversion Hlen.
    split with ((oadd_Rpos o o0) :: L).
    repeat split; auto.
    + inversion Hex; subst.
      * apply Exists_inf_cons_hd.
        destruct o; [ | exfalso; apply H0; reflexivity].
        destruct o0; intros H; inversion H.
      * inversion X1; subst; auto.
        apply Exists_inf_cons_hd.
        destruct o; destruct o0; try (exfalso; apply H0; reflexivity); intro H; inversion H.
    + intros n.
      specialize (Hsum n).
      destruct o; destruct o0; try destruct r; try destruct r0; simpl; simpl in Hsum; nra.
  - inversion Ha; inversion X0; subst.
    destruct IHpi as [L [Hlen [Hex Hsum]]].
    { apply Forall_inf_cons; try assumption.
      apply seq_atomic_app; assumption. }
    destruct L; try now inversion Hlen.
    split with (o :: o :: L).
    repeat split; auto.
    + simpl in *; rewrite Hlen; reflexivity.
    + intro n.
      specialize (Hsum n).
      destruct o; auto.
      simpl in *.
      rewrite sum_weight_var_seq_app in Hsum.
      nra.
  - inversion Ha; subst.
    destruct IHpi1 as [L1 [Hlen1 [Hex1 Hsum1]]].
    { apply Forall_inf_cons ; [ apply seq_atomic_app_inv_l with T2 | ]; try assumption. }
    destruct L1; try now inversion Hlen1.
    destruct o.
    2:{ split with (None :: L1).
        repeat split; auto. }
    destruct IHpi2 as [L2 [Hlen2 [Hex2 Hsum2]]].
    { apply Forall_inf_cons ; [ apply seq_atomic_app_inv_r with T1 | ]; try assumption. }
    destruct L2; try now inversion Hlen2.
    destruct o.
    2:{ split with (None :: L2).
        repeat split; auto. }
    split with ((Some (time_pos r r0)) :: oadd_Rpos_list (map (mul_Rpos_oRpos r0) L1) (map (mul_Rpos_oRpos r) L2)).
    repeat split; auto.
    + simpl in Hlen1, Hlen2; simpl.
      rewrite oadd_Rpos_list_length ; [ rewrite map_length; assumption | ].
      rewrite 2 map_length.
      lia.
    + apply Exists_inf_cons_hd.
      intros H; inversion H.
    + intros n; specialize (Hsum1 n); specialize (Hsum2 n); simpl in Hsum1, Hsum2.
      simpl.
      rewrite sum_weight_var_seq_app.
      rewrite sum_weight_var_with_coeff_oadd_Rpos_list ; [ | simpl in Hlen1, Hlen2; simpl; rewrite 2 map_length; lia].
      rewrite 2 sum_weight_var_with_coeff_omul_Rpos_list.
      destruct r; destruct r0; simpl in *; nra.
  - inversion Ha; subst.
    destruct IHpi as [L [Hlen [Hex Hsum]]].
    { apply Forall_inf_cons; try assumption.
      apply seq_atomic_mul; apply X. }
    destruct L; try now inversion Hlen.
    destruct o.
    2:{ split with (None :: L).
        repeat split; auto. }
    split with (Some (time_pos r0 r) :: L).
    repeat split; auto.
    + apply Exists_inf_cons_hd; intros H; inversion H.
    + destruct r; destruct r0; simpl in *; intros n; specialize (Hsum n);rewrite sum_weight_var_seq_mul in Hsum; simpl in *.
      nra.
  - inversion Ha; subst.
    destruct IHpi as [L [Hlen [Hex Hsum]]].
    { apply Forall_inf_cons; try assumption.
      eapply seq_atomic_app_inv_r; eapply seq_atomic_app_inv_r; apply X. }
    split with L.
    repeat split; auto.
    + intros n0; specialize (Hsum n0).
      destruct L; try now inversion Hlen.
      simpl; rewrite ? sum_weight_seq_app.
      case (hr.term.V_eq n0 n); intros H.
      * subst.
        rewrite ? sum_weight_var_seq_app.
        rewrite sum_weight_var_seq_vec_covar_eq;rewrite sum_weight_var_seq_vec_var_eq.
        simpl in Hsum.
        destruct o; nra.
      * rewrite ? sum_weight_var_seq_app.
        rewrite ? sum_weight_var_seq_vec_neq; try (intros H'; inversion H'; contradiction).
        destruct o; simpl in Hsum; auto.
        nra.
  - destruct r; [ | inversion Ha; inversion X; inversion X1].
    destruct (IHpi Ha) as [L [Hlen [Hex Hsum]]].
    split with L.
    repeat split; try assumption.
  - destruct r; [ | inversion Ha; inversion X; inversion X1].
    destruct (IHpi Ha) as [L [Hlen [Hex Hsum]]].
    split with L.
    repeat split; try assumption.
  - destruct r; [ | inversion Ha; inversion X; inversion X1].
    destruct (IHpi Ha) as [L [Hlen [Hex Hsum]]].
    split with L.
    repeat split; try assumption.
  - destruct r; [ | inversion Ha; inversion X; inversion X1].
    destruct IHpi as [L [Hlen [Hex Hsum]]].
    { inversion Ha; subst.
      apply Forall_inf_cons ; [ | apply Forall_inf_cons ]; assumption. }
    destruct L ; [ | destruct L]; try now inversion Hlen.
    split with (oadd_Rpos o o0 :: L).
    repeat split; auto.
    + inversion Hex; subst.
      * apply Exists_inf_cons_hd.
        destruct o; destruct o0; try (exfalso; apply H0; reflexivity); intros H; inversion H.
      * inversion X; subst; auto.
        apply Exists_inf_cons_hd;
          destruct o; destruct o0; try (exfalso; apply H0; reflexivity); intros H; inversion H.
    + intros n.
      simpl.
      specialize (Hsum n).
      destruct o; destruct o0; try destruct r; try destruct r0; simpl in *; nra.
  - destruct r; [ | inversion Ha; inversion X; inversion X1].
    destruct (IHpi1 Ha) as [L [Hlen [Hex Hsum]]].
    split with L.
    repeat split; try assumption.
  - destruct IHpi as [L [Hlen [Hex Hsum]]].
    { inversion Ha; subst.
      apply Forall_inf_cons; try assumption.
      apply seq_atomic_perm with T2; [ Permutation_Type_solve | apply X]. }
    split with L.
    destruct L; try now inversion Hlen.
    repeat split; auto.
    + intro n; specialize (Hsum n).
      destruct o; simpl in *; auto.
      rewrite <- (sum_weight_var_seq_perm _ _ _ p); apply Hsum.
  - destruct IHpi as [L [Hlen [Hex Hsum]]].
    { apply hseq_atomic_perm with H; try assumption.
      symmetry; apply p. }
    destruct (sum_weight_var_with_coeff_perm_r G H L p Hlen) as [L' [Hperm' Hsum']].
    split with L'.
    repeat split.
    + apply Permutation_Type_length in p.
      apply Permutation_Type_length in Hperm'.
      etransitivity ; [ | apply p].
      etransitivity ; [ | apply Hlen].
      symmetry; apply Hperm'.
    + apply Exists_inf_Permutation_Type with L; assumption.
    + intros n.
      rewrite <- (Hsum' n); apply Hsum.
  - inversion f.
Qed.

Lemma lambda_prop_inv :
  forall G,
    hseq_is_atomic G ->
    { L &
      prod (length L = length G)
           ((Exists_inf (fun x => x <> None) L) *
            (forall n, sum_weight_var_with_coeff n G L = 0))} ->
    HR_T_M G.
Proof.
  enough (forall G H,
             hseq_is_atomic G ->
             hseq_is_atomic H ->
             { L &
               prod (length L = length G)
                    ((Exists_inf (fun x => x <> None) L) *
                     (forall n, sum_weight_var n H + sum_weight_var_with_coeff n G L = 0))} + HR_T_M H ->
             HR_T_M (H ++  G)).
  { intros G Hat [L [Hlen [Hex Hsum]]].
    change G with (nil ++ G).
    refine (X G nil Hat _ _).
    - apply Forall_inf_nil.
    - left.
      split with L.
      repeat split; auto.
      + intros n; simpl; specialize (Hsum n); nra. }
  intros G.
  remember (length G) as n.
  revert G Heqn.
  induction n; intros G Heqn H HatG HatH [[L [Hlen [Hex Hsum]]] | pi].
  - destruct L; inversion Hlen; inversion Hex.
  - destruct G; inversion Heqn; rewrite app_nil_r; apply pi.
  - destruct (Exists_inf_split _ _ _ Hex) as [[[r La] Lb] [Hp HeqL]].
    assert (Permutation_Type L (r :: La ++ Lb)) as Hperm by (rewrite HeqL ; Permutation_Type_solve).
    destruct (sum_weight_var_with_coeff_perm_l G _ _ Hperm) as [G' [HpermG Hsum']].
    { lia. }
    destruct G' as [ | T G'].
    { symmetry in HpermG; apply Permutation_Type_nil in HpermG.
      subst; inversion Heqn. }
    apply hrr_ex_hseq with (T :: H ++ G') ; [ Permutation_Type_solve | ].
    destruct r ; [ | exfalso; apply Hp; reflexivity].
    apply hrr_T with r; try reflexivity.
    change (hseq.seq_mul r T :: H ++ G')
      with
        ((hseq.seq_mul r T :: H) ++ G').
    assert (hseq_is_atomic (T :: G')) as HatG'.
    { apply Forall_inf_Permutation_Type with G; try assumption. }
    apply IHn.
    + apply Permutation_Type_length in HpermG.
      rewrite HpermG in Heqn; simpl in Heqn; inversion Heqn; auto.
    + inversion HatG'; auto.
    + apply Forall_inf_cons; auto.
      apply seq_atomic_mul; now inversion HatG'.
    + destruct (Forall_inf_Exists_inf_dec (fun x : option Rpos => x = None)) with (La ++ Lb).
      { intros x.
        destruct x ; [ right; intros H'; inversion H' | left; reflexivity]. }
      * right.
        apply atomic_proof_all_eq.
        -- apply seq_atomic_mul.
           apply hseq_atomic_perm with _ (T :: G') in HatG; try assumption.
           inversion HatG; assumption.
        -- apply HatH.
        -- intros n0.
           specialize (Hsum' n0); specialize (Hsum n0).
           simpl in *.
           rewrite (sum_weight_var_with_coeff_all_0 _ (La ++ Lb)) in Hsum'; try assumption.
           rewrite sum_weight_var_seq_mul; simpl.
           nra.
      * left; split with (La ++ Lb).
        repeat split.
        -- rewrite HeqL in Hlen.
           rewrite ? app_length.
           rewrite ? app_length in Hlen; simpl in Hlen.
           lia.
        -- apply e.
        -- intros n0.
           specialize (Hsum' n0); specialize (Hsum n0).
           simpl in *.
           rewrite sum_weight_var_seq_mul; simpl.
           nra.
  - eapply hrr_ex_hseq; [ apply Permutation_Type_app_comm | ].
    apply hrr_W_gen.
    apply pi.
Qed.

(** ** Decidablity *)
(* begin hide *)
(* Preliminary work necessary for the decidability result *)

(* get a real number x and convert |x| to oRpos *)
Definition R_to_oRpos x :=
  match R_order_dec x with
              | R_is_gt H => Some (existT (fun x => 0 <? x = true) x H)
              | R_is_lt H => Some (existT (fun x => 0 <? x = true) (- x) H)
              | R_is_null _ => None
  end.

Definition eval_to_oRpos val f := R_to_oRpos (eval_Poly val f).

Definition oRpos_to_R (o : option Rpos) :=
  match o with
  | None => 0
  | Some r => projT1 r
  end.

Lemma R_to_oRpos_oRpos_to_R :
  forall o,
    R_to_oRpos (oRpos_to_R o) = o.
Proof.
  destruct o; unfold R_to_oRpos; simpl;
    [ | case (R_order_dec 0); intros e; simpl; try reflexivity; exfalso; apply R_blt_lt in e; lra].
  destruct r as [r Hr]; simpl.
  case (R_order_dec r); intros e;
    try (replace e with Hr by (apply Eqdep_dec.UIP_dec; apply Bool.bool_dec); reflexivity);
    exfalso; apply R_blt_lt in Hr; try apply R_blt_lt in e; lra.
Qed.

Lemma oRpos_to_R_to_Rpos : forall r (Hr : 0 <? projT1 r = true),
    existT _ (oRpos_to_R (Some r)) Hr = r.
Proof.
  intros [r Hr] H.
  apply Rpos_eq; reflexivity.
Qed.

Lemma map_oRpos_to_R_all_pos:
  forall L val i, Forall_inf (fun x => 0 <= eval_Poly (upd_val_vec val (seq i (length L)) (map oRpos_to_R L)) x) (map Poly_var (seq i (length L))).
Proof.
  induction L; intros val i; [ apply Forall_inf_nil | ].
  simpl.
  apply Forall_inf_cons; [ | apply IHL].
  rewrite eval_Poly_upd_val_vec_not_in.
  2:{ apply not_In_inf_seq; lia. }
  rewrite upd_val_eq.
  clear.
  destruct a; simpl; try (destruct r as [r Hr]; simpl; apply R_blt_lt in Hr); lra.
Qed.

Lemma eval_to_oRpos_eq :
  forall val vr k,
    map (eval_to_oRpos (upd_val_vec val (seq k (length vr)) vr)) (map Poly_var (seq k (length vr))) = map R_to_oRpos vr.
Proof.
  intros val vr; revert val; induction vr; intros val k; auto.
  simpl.
  rewrite (IHvr _ (S k)).
  unfold eval_to_oRpos.
  rewrite eval_Poly_upd_val_vec_not_in.
  2:{ apply not_In_inf_seq; lia. }
  unfold upd_val.
  rewrite Nat.eqb_refl.
  reflexivity.
Qed.

Fixpoint p_sum_weight_var_with_coeff n G L :=
  match G, L with
  | _, nil => Poly_cst 0
  | nil, _ => Poly_cst 0
  | T :: G , r :: L => (r *R sum_weight_var_p_seq n T) +R p_sum_weight_var_with_coeff n G L
  end.
(*
Lemma p_sum_weight_var_with_coeff_lt_max_var : forall n G L val,
    (max_var_p_hseq G < n)%nat ->
    eval_Poly val (p_sum_weight_var_with_coeff n G L) = 0.
Proof.
  intros n; induction G; intros L val Hlt; destruct L; auto.
  simpl in *.
  simpl; try rewrite sum_weight_var_p_seq_lt_max_var; try lia;
    rewrite IHG; try lia;
      lra.
Qed. *)

Lemma p_sum_weight_var_with_coeff_app1 : forall n G1 G2 L,
    (length L <= length G1)%nat ->
    p_sum_weight_var_with_coeff n (G1 ++ G2) L = p_sum_weight_var_with_coeff n G1 L.
Proof.
  intros n; induction G1; intros G2 L Hlen; destruct L; try (now inversion Hlen); [destruct G2 | ]; auto.
  simpl; rewrite IHG1; auto.
  simpl in Hlen; lia.
Qed.

Lemma p_sum_weight_var_with_coeff_app2 : forall val n G1 G2 L1 L2,
    (length L1 = length G1) ->
    eval_Poly val (p_sum_weight_var_with_coeff n (G1 ++ G2) (L1 ++ L2)) = eval_Poly val (p_sum_weight_var_with_coeff n G1 L1 +R p_sum_weight_var_with_coeff n G2 L2).
Proof.
  intros n; induction G1; intros G2 L1 L2 Hlen; destruct L1; try (now inversion Hlen); [destruct L2 ; destruct G2 | ]; simpl; try lra.
  simpl in *; rewrite IHG1; auto.
  lra.
Qed.

Lemma p_sum_weight_var_with_coeff_app3 : forall n G L1 L2,
    (length G <= length L1)%nat ->
    p_sum_weight_var_with_coeff n G (L1 ++ L2) = p_sum_weight_var_with_coeff n G L1.
Proof.
  intros n; induction G; intros L1 L2 Hlen; destruct L1; try (now inversion Hlen); [now destruct L2 | ].
  simpl; rewrite IHG; auto.
  simpl in Hlen; lia.
Qed.

Lemma eval_to_oRpos_to_R_eq : forall L val i,
    Forall_inf (fun x => 0 <= eval_Poly (upd_val_vec val (seq i (length L)) (map oRpos_to_R L)) x) (map Poly_var (seq i (length L))) ->
    map (eval_to_oRpos (upd_val_vec val (seq i (length L)) (map oRpos_to_R L))) (map Poly_var (seq i (length L))) = L.
Proof.
  induction L; intros val i Hall.
  - reflexivity.
  - inversion Hall; subst.
    simpl.
    rewrite IHL; auto.
    unfold eval_to_oRpos.
    rewrite eval_Poly_upd_val_vec_not_in.
    2:{ apply not_In_inf_seq; lia. }
    clear - H0.
    simpl in H0.
    rewrite upd_val_vec_not_in in H0.
    2:{ apply not_In_inf_seq; lia. }
    rewrite upd_val_eq in H0 |-*.
    case_eq (R_order_dec (oRpos_to_R a));
      intros e He;
      [ | exfalso; clear - H0 e; apply R_blt_lt in e | ]; try lra.
    + destruct a;
        simpl in H0;
        [ | exfalso; clear - e; apply R_blt_lt in e; simpl in e; lra].
      rewrite R_to_oRpos_oRpos_to_R; reflexivity.
    + rewrite R_to_oRpos_oRpos_to_R; reflexivity.
Qed.

Fixpoint p_concat_with_coeff_mul G L :=
  match G, L with
  | _, nil => nil
  | nil, _ => nil
  | T :: G , r :: L => seq_mul r T ++ p_concat_with_coeff_mul G L
  end.

Lemma eval_Poly_eval_p_sequent : forall val n T,
    eval_Poly val (sum_weight_var_p_seq n T) = sum_weight_var_seq n (eval_p_sequent val T).
Proof.
  intros val n; induction T; simpl; try lra.
  destruct a as [a A].
  case_eq (R_order_dec (eval_Poly val a)); intros e He; simpl;
    destruct A; simpl; try case (hr.term.V_eq n v); simpl; try rewrite IHT; try lra.
Qed.

Lemma eval_Poly_eval_p_hseq : forall val n G L,
    Forall_inf (fun x => 0 <= eval_Poly val x) L ->
    eval_Poly val (p_sum_weight_var_with_coeff n G L) = sum_weight_var_with_coeff n (map (eval_p_sequent val) G) (map (eval_to_oRpos val) L).
Proof.
  intros val n; induction G; intros L Hall; destruct Hall; simpl; try reflexivity.
  specialize (IHG l Hall).
  unfold eval_to_oRpos; unfold R_to_oRpos.
  case_eq (R_order_dec (eval_Poly val x)); intros e' He'; simpl ; [ | exfalso; clear - r e'; apply R_blt_lt in e' |  ]; try lra.
  - rewrite IHG; rewrite eval_Poly_eval_p_sequent.
    unfold eval_to_oRpos; unfold R_to_oRpos.
    lra.
  - rewrite e'.
    unfold eval_to_oRpos in IHG; unfold R_to_oRpos in IHG.
    lra.
Qed.

Lemma eval_Poly_upd_val_vec_lt : forall val a vx vr,
    Forall_inf (fun x => max_var_Poly a < x)%nat vx ->
    eval_Poly (upd_val_vec val vx vr) a = eval_Poly val a.
Proof.
  intros val; induction a; intros vx vr Hall.
  - simpl.
    apply upd_val_vec_not_in.
    intros Hin.
    apply (Forall_inf_forall Hall) in Hin.
    simpl in Hin; lia.
  - reflexivity.
  - simpl; rewrite IHa1; [ rewrite IHa2 | ]; try reflexivity; refine (Forall_inf_arrow _ _ Hall);
      intros a Hlt; simpl in Hlt; lia.
  - simpl; rewrite IHa1; [ rewrite IHa2 | ]; try reflexivity; refine (Forall_inf_arrow _ _ Hall);
      intros a Hlt; simpl in Hlt; lia.
Qed.

Lemma eval_p_hseq_upd_val_vec_lt : forall val G vx vr,
    Forall_inf (fun x => max_var_weight_p_hseq G < x)%nat vx ->
    map (eval_p_sequent (upd_val_vec val vx vr)) G = map (eval_p_sequent val) G.
Proof.
  intros val; induction G; intros vx vr Hall; simpl; try reflexivity.
  rewrite eval_p_sequent_upd_val_vec_lt_max_var ; [ | refine (Forall_inf_arrow _ _ Hall); intros a' Hlt'; simpl in Hlt'; lia].
  rewrite IHG ; [ | refine (Forall_inf_arrow _ _ Hall); intros a' Hlt'; simpl in Hlt'; lia].
  reflexivity.
Qed.

Lemma sum_weight_var_with_coeff_eval_eq : forall val n G L,
    sum_weight_var_with_coeff n (map (eval_p_sequent val) G) L = eval_Poly (upd_val_vec val (seq (S (max_var_weight_p_hseq G)) (length L)) (map oRpos_to_R L)) (p_sum_weight_var_with_coeff n G (map Poly_var (seq (S (max_var_weight_p_hseq G)) (length L)))).
Proof.
  intros val n G L.
  rewrite eval_Poly_eval_p_hseq; auto.
  2:{ apply map_oRpos_to_R_all_pos. }
  rewrite eval_to_oRpos_to_R_eq.
  2:{ apply map_oRpos_to_R_all_pos. }
  rewrite eval_p_hseq_upd_val_vec_lt; try reflexivity.
  apply forall_Forall_inf.
  intros x Hin.
  case_eq (max_var_weight_p_hseq G <? x)%nat; intros H; [ apply Nat.ltb_lt in H | apply Nat.ltb_nlt in H]; auto.
  exfalso.
  apply not_In_inf_seq with (S (max_var_weight_p_hseq G)) (length L) x; try lia.
  apply Hin.
Qed.

(* Put non atomic formula first, i.e., G in the form H | |- T, r.A with A non atomic. *)

Fixpoint p_seq_fst_non_atomic_term (T : p_sequent) : (Poly * term) :=
  match T with
  | nil => (Poly_cst 0, RS_zero)
  | (a, A) :: T => if (0 <? RS_outer_complexity_term A)%nat
                   then (a , A)
                   else (p_seq_fst_non_atomic_term T)
  end.

Lemma p_seq_fst_non_atomic_term_correct :
  forall T,
    (p_seq_is_atomic T -> False) ->
    (is_atom (snd (p_seq_fst_non_atomic_term T)) -> False).
Proof.
  induction T; intros Hnbs Hbt; [ apply Hnbs; apply Forall_inf_nil | ].
  destruct a as [a A]; simpl in *.
  case_eq (0 <? RS_outer_complexity_term A)%nat; intros H1; rewrite H1 in Hbt;
    (apply Nat.ltb_lt in H1 + apply Nat.ltb_nlt in H1).
  - apply is_atom_outer_complexity_0 in Hbt.
    simpl in Hbt.
    lia.
  - apply IHT; auto.
    intros H2.
    apply Hnbs.
    apply Forall_inf_cons; auto.
    apply is_atom_outer_complexity_0_inv.
    lia.
Qed.

Lemma p_seq_fst_non_atomic_term_well_defined :
  forall val T,
    (0 < HR_outer_complexity_p_seq T)%nat ->
    p_seq_well_defined val T ->
    0 <= eval_Poly val (fst (p_seq_fst_non_atomic_term T)).
Proof.
  intros val; induction T; intros Hlt; [ simpl in Hlt; exfalso; try lia | ].
  intros Hwd.
  destruct a as [a A].
  simpl.
  case_eq (0 <? RS_outer_complexity_term A)%nat; intros H; auto; inversion Hwd; subst; auto.
  apply IHT; auto.
  apply Nat.ltb_nlt in H.
  simpl in *.
  lia.
Qed.

Fixpoint p_seq_without_fst_non_atomic_term (T : p_sequent) : p_sequent :=
  match T with
  | nil => nil
  | (a, A) :: T => if (0 <? RS_outer_complexity_term A)%nat
                   then T
                   else (a , A) :: (p_seq_without_fst_non_atomic_term T)
  end.

Lemma p_seq_put_non_atomic_fst : forall T,
    (p_seq_is_atomic T -> False) ->
    Permutation_Type T (p_seq_fst_non_atomic_term T :: p_seq_without_fst_non_atomic_term T).
Proof.
  induction T; intros Hnb; [ exfalso; apply Hnb; apply Forall_inf_nil | ].
  destruct a as [a A]; simpl.
  case_eq (0 <? RS_outer_complexity_term A)%nat; intros H1;
    apply Nat.ltb_lt in H1 + apply Nat.ltb_nlt in H1; auto.
  assert (p_seq_is_atomic T -> False).
  { intros H; apply Hnb; apply Forall_inf_cons; auto.
    apply is_atom_outer_complexity_0_inv.
    lia. }
  specialize (IHT H).
  transitivity ((a , A) :: p_seq_fst_non_atomic_term T :: p_seq_without_fst_non_atomic_term T);
    Permutation_Type_solve.
Qed.

Lemma p_seq_without_fst_non_atomic_term_well_defined :
  forall val T,
    p_seq_well_defined val T ->
    p_seq_well_defined val (p_seq_without_fst_non_atomic_term T).
Proof.
  intros val; induction T; intros Hwd; [apply Forall_inf_nil |].
  destruct a as [a A]; inversion Hwd; subst.
  simpl.
  case_eq (0 <? RS_outer_complexity_term A)%nat; intros H; try apply Forall_inf_cons; try apply IHT; auto.
Qed.

Fixpoint p_hseq_p_seq_max_complexity (G : p_hypersequent) : p_sequent :=
  match G with
  | nil => nil
  | T :: G => if (fst (HR_outer_complexity_p_hseq G) <=? HR_outer_complexity_p_seq T)
              then T
              else p_hseq_p_seq_max_complexity G
  end.

Lemma p_hseq_p_seq_max_complexity_well_defined :
  forall val G,
    p_hseq_well_defined val G ->
    p_seq_well_defined val (p_hseq_p_seq_max_complexity G).
Proof.
  intros val; induction G; intros Hwd; [ apply Forall_inf_nil | ].
  inversion Hwd; specialize (IHG X0); subst.
  simpl; case (fst (HR_outer_complexity_p_hseq G) <=? HR_outer_complexity_p_seq a); auto.
Qed.

Lemma p_hseq_p_seq_max_complexity_correct :
  forall G,
    HR_outer_complexity_p_seq (p_hseq_p_seq_max_complexity G) = fst (HR_outer_complexity_p_hseq G).
Proof.
  induction G; auto.
  simpl.
  case_eq (fst (HR_outer_complexity_p_hseq G) <=? HR_outer_complexity_p_seq a); intros H1;
    case_eq (HR_outer_complexity_p_seq a =? fst (HR_outer_complexity_p_hseq G)); intros H2;
      case_eq (HR_outer_complexity_p_seq a <? fst (HR_outer_complexity_p_hseq G))%nat; intros H3;
        simpl;
        apply Nat.leb_le in H1 + apply Nat.leb_nle in H1;
        apply Nat.eqb_eq in H2 + apply Nat.eqb_neq in H2;
        apply Nat.ltb_lt in H3 + apply Nat.ltb_nlt in H3;
        try lia.
Qed.

Fixpoint p_hseq_without_max_complexity (G : p_hypersequent) : p_hypersequent :=
  match G with
  | nil => nil
  | T :: G => if (fst (HR_outer_complexity_p_hseq G) <=? HR_outer_complexity_p_seq T)
              then G
              else T :: p_hseq_without_max_complexity G
  end.

Lemma p_hseq_without_max_complexity_well_defined :
  forall val G,
    p_hseq_well_defined val G ->
    p_hseq_well_defined val (p_hseq_without_max_complexity G).
Proof.
  intros val; induction G; intros Hwd; [apply Forall_inf_nil | ].
  inversion Hwd; subst; specialize (IHG X0).
  simpl; case (fst (HR_outer_complexity_p_hseq G) <=? HR_outer_complexity_p_seq a); try apply Forall_inf_cons; auto.
Qed.

Lemma p_hseq_put_max_complexity_fst : forall G,
    G <> nil ->
    Permutation_Type G (p_hseq_p_seq_max_complexity G :: p_hseq_without_max_complexity G).
Proof.
  induction G; intros Hnnil; [ exfalso; auto | ].
  simpl.
  case_eq (fst (HR_outer_complexity_p_hseq G) <=? HR_outer_complexity_p_seq a); intros H1;
    apply Nat.leb_le in H1 + apply Nat.leb_nle in H1; auto.
  destruct G.
  { exfalso; simpl in H1; lia. }
  assert (p :: G <> nil) as Hnnil'.
  { intros H; inversion H. }
  specialize (IHG Hnnil').
  transitivity (a :: p_hseq_p_seq_max_complexity (p :: G) :: p_hseq_without_max_complexity (p :: G)); Permutation_Type_solve.
Qed.

Definition p_hseq_put_non_atomic_fst G :=
  ((p_seq_fst_non_atomic_term (p_hseq_p_seq_max_complexity G) :: p_seq_without_fst_non_atomic_term (p_hseq_p_seq_max_complexity G)) :: p_hseq_without_max_complexity G).

Lemma p_hseq_put_non_atomic_fst_HR_complexity :
  forall G,
    (p_hseq_is_atomic G -> False) ->
    HR_outer_complexity_p_hseq (p_hseq_put_non_atomic_fst G) = HR_outer_complexity_p_hseq G.
Proof.
  intros G Hnb.
  unfold p_hseq_put_non_atomic_fst.
  rewrite HR_outer_complexity_perm_fst_seq with _ _ (p_hseq_p_seq_max_complexity G).
  2:{ symmetry; apply p_seq_put_non_atomic_fst.
      intros H.
      apply Hnb.
      apply p_hseq_is_atomic_outer_complexity_0_inv.
      rewrite <- p_hseq_p_seq_max_complexity_correct.
      apply p_seq_is_atomic_complexity_0.
      apply H. }
  rewrite outer_complexity_p_hseq_perm with _ G; auto.
  symmetry; apply p_hseq_put_max_complexity_fst.
  intros H; apply Hnb; rewrite H.
  apply Forall_inf_nil.
Qed.

Lemma p_hseq_put_non_atomic_fst_correct :
  forall G a A T H,
    (p_hseq_is_atomic G -> False) ->
    p_hseq_put_non_atomic_fst G = ((a, A) :: T) :: H ->
    is_atom A -> False.
Proof.
  intros G a A T H Hnb Heq Hb.
  unfold p_hseq_put_non_atomic_fst in Heq.
  inversion Heq; subst.
  apply p_seq_fst_non_atomic_term_correct with (p_hseq_p_seq_max_complexity G).
  - intros Hb'.
    apply Hnb.
    apply p_hseq_is_atomic_outer_complexity_0_inv.
    apply p_seq_is_atomic_complexity_0 in Hb'.
    rewrite p_hseq_p_seq_max_complexity_correct in Hb'.
    apply Hb'.
  - rewrite H1.
    apply Hb.
Qed.

Lemma p_hseq_put_non_atomic_fst_well_defined :
  forall val G,
    (0 < fst (HR_outer_complexity_p_hseq G))%nat ->
    p_hseq_well_defined val G ->
    p_hseq_well_defined val (p_hseq_put_non_atomic_fst G).
Proof.
  intros val G Hn0 Hwd.
  apply Forall_inf_cons; (destruct G; [ exfalso; simpl in *; lia | ]).
  - apply Forall_inf_cons.
    + apply p_seq_fst_non_atomic_term_well_defined; [ | apply p_hseq_p_seq_max_complexity_well_defined; auto].
      rewrite p_hseq_p_seq_max_complexity_correct.
      apply Hn0.
    + apply p_seq_without_fst_non_atomic_term_well_defined.
      apply p_hseq_p_seq_max_complexity_well_defined.
      apply Hwd.
  - apply p_hseq_without_max_complexity_well_defined; apply Hwd.
Qed.

Lemma p_hseq_put_non_atomic_fst_HR :
  forall val G,
    (p_hseq_is_atomic G -> False) ->
    HR_T_M (map (eval_p_sequent val) (p_hseq_put_non_atomic_fst G)) ->
    HR_T_M (map (eval_p_sequent val) G).
Proof.
  intros val G Hnatomic Hpi.
  apply hrr_ex_hseq with (map (eval_p_sequent val) (p_hseq_p_seq_max_complexity G :: p_hseq_without_max_complexity G)).
  { apply Permutation_Type_map.
    symmetry; apply p_hseq_put_max_complexity_fst.
    intros Hnil.
    subst.
    apply Hnatomic; apply Forall_inf_nil. }
  simpl.
  apply hrr_ex_seq with (eval_p_sequent val (p_seq_fst_non_atomic_term (p_hseq_p_seq_max_complexity G) :: p_seq_without_fst_non_atomic_term (p_hseq_p_seq_max_complexity G))).
  { apply Permutation_Type_eval_p_sequent.
    symmetry; apply p_seq_put_non_atomic_fst.
    intros H.
    apply p_seq_is_atomic_complexity_0 in H.
    rewrite p_hseq_p_seq_max_complexity_correct in H.
    apply Hnatomic.
    apply p_hseq_is_atomic_outer_complexity_0_inv.
    apply H. }
  apply Hpi.
Qed.

Lemma p_hseq_put_non_atomic_fst_HR_inv :
  forall val G,
    (p_hseq_is_atomic G -> False) ->
    HR_T_M (map (eval_p_sequent val) G) ->
    HR_T_M (map (eval_p_sequent val) (p_hseq_put_non_atomic_fst G)).
Proof.
  intros val G Hnatomic Hpi.
  unfold p_hseq_put_non_atomic_fst.
  unfold map.
  apply hrr_ex_seq with (eval_p_sequent val (p_hseq_p_seq_max_complexity G)).
  { apply Permutation_Type_eval_p_sequent.
    apply p_seq_put_non_atomic_fst.
    intros H.
    apply p_seq_is_atomic_complexity_0 in H.
    rewrite p_hseq_p_seq_max_complexity_correct in H.
    apply Hnatomic.
    apply p_hseq_is_atomic_outer_complexity_0_inv.
    apply H. }
  eapply hrr_ex_hseq; [ | apply Hpi].
  transitivity (map (eval_p_sequent val) (p_hseq_p_seq_max_complexity G :: p_hseq_without_max_complexity G)); [ | reflexivity ].
  apply Permutation_Type_map.
  apply p_hseq_put_max_complexity_fst.
  intros Hnil.
  subst.
  apply Hnatomic; apply Forall_inf_nil.
Qed.

Definition apply_logical_rule_on_p_hypersequent G : (p_hypersequent + (p_hypersequent * p_hypersequent)) :=
  match G with
  | nil => inl nil
  | T :: G => match T with
              | nil => inl (nil :: G)
              | (a, A) :: T => match A with
                               | A1 +S A2 => inl (((a, A1) :: (a, A2) :: T) :: G)
                               | A1 /\S A2 => inr ((((a, A1) :: T) :: G) , (((a, A2) :: T) :: G))
                               | A1 \/S A2 => inl (((a, A2) :: T) :: ( (a, A1) :: T) :: G)
                               | r0 *S A => inl (((Poly_cst (projT1 r0) *R a, A) :: T) :: G)
                               | RS_zero => inl (T :: G)
                               | _ => inl (((a, A) :: T) :: G)
                               end
              end
  end.

Lemma apply_logical_rule_on_p_hypersequent_inl_well_defined :
  forall val G G1,
    apply_logical_rule_on_p_hypersequent G = inl G1 ->
    p_hseq_well_defined val G ->
    p_hseq_well_defined val G1.
Proof.
  intros val G G1 Heq Hwd.
  destruct G ; [inversion Heq; apply Forall_inf_nil | ].
  destruct l; [inversion Heq; apply Hwd | ].
  destruct p as [a A].
  destruct A; inversion Heq; subst; auto;
    inversion Hwd; subst;
      inversion X; subst; simpl in *;
        (apply Forall_inf_cons; [ | try apply Forall_inf_cons]); auto;
          apply Forall_inf_cons; auto.
  destruct r as [r Hr].
  clear - H0 Hr.
  simpl; apply R_blt_lt in Hr.
  nra.
Qed.

Lemma apply_logical_rule_on_p_hypersequent_inr_l_well_defined :
  forall val G G1 G2,
    apply_logical_rule_on_p_hypersequent G = inr (G1, G2) ->
    p_hseq_well_defined val G ->
    p_hseq_well_defined val G1.
Proof.
  intros val G G1 G2 Heq Hwd.
  destruct G ; [inversion Heq | ].
  destruct l; [inversion Heq | ].
  destruct p as [a A].
  destruct A; inversion Heq; subst; auto.
  inversion Hwd; subst.
  inversion X; subst.
  apply Forall_inf_cons ; [ apply Forall_inf_cons | ]; auto.
Qed.

Lemma apply_logical_rule_on_p_hypersequent_inr_r_well_defined :
  forall val G G1 G2,
    apply_logical_rule_on_p_hypersequent G = inr (G1, G2) ->
    p_hseq_well_defined val G ->
    p_hseq_well_defined val G2.
Proof.
  intros val G G1 G2 Heq Hwd.
  destruct G ; [inversion Heq | ].
  destruct l; [inversion Heq | ].
  destruct p as [a A].
  destruct A; inversion Heq; subst; auto.
  inversion Hwd; subst.
  inversion X; subst.
  apply Forall_inf_cons ; [ apply Forall_inf_cons | ]; auto.
Qed.

Lemma apply_logical_rule_on_p_hypersequent_inl_HR :
  forall val G G1,
    apply_logical_rule_on_p_hypersequent G = inl G1 ->
    p_hseq_well_defined val G ->
    HR_T_M (map (eval_p_sequent val) G) ->
    HR_T_M (map (eval_p_sequent val) G1).
Proof.
  intros val G G1 Heq Hwd pi.
  destruct G; [ exfalso; apply (HR_not_empty _ nil pi); auto | ].
  destruct l; [ inversion Heq; apply pi | ].
  destruct p as [a A].
  destruct A; inversion Heq; subst; auto.
  - inversion Hwd; inversion X; subst.
    simpl in pi.
    case_eq (R_order_dec (eval_Poly val a)); intros e He;
      try (exfalso; clear - e H2;
           try (apply R_blt_lt in e); simpl in *; lra);
      rewrite He in pi; simpl.
    2:{ apply pi. }
    apply hrr_Z_inv with ((existT _ (eval_Poly val a) e) :: nil).
    apply pi.
  - inversion Hwd; inversion X; subst.
    simpl in pi |- *.
    case_eq (R_order_dec (eval_Poly val a)); intros e He;
      try (exfalso; clear - e H2;
           try (apply R_blt_lt in e); simpl in *; lra);
      rewrite He in pi.
    2:{ apply pi. }
    revert pi;set (r := (existT (fun x : R => (0 <? x) = true) (eval_Poly val a) e)); intros pi.
    change ((r, A1) :: (r, A2) :: eval_p_sequent val l) with
        (hseq.vec (r :: nil) A1 ++ hseq.vec (r :: nil) A2 ++ eval_p_sequent val l).
    apply hrr_plus_inv.
    apply pi.
  - inversion Hwd; inversion X; subst.
    simpl in *.
    case_eq (R_order_dec (eval_Poly val a)); intros e He;
      try (exfalso; clear - e H2;
           try (apply R_blt_lt in e); simpl in *; lra);
      case (R_order_dec (projT1 r * eval_Poly val a)); intros e';
        try (exfalso; destruct r as [r Hr]; clear - e e' H2;
             simpl in *;
             apply R_blt_lt in Hr; apply R_blt_lt in e; try (apply R_blt_lt in e');
             nra);
        try (exfalso; rewrite e in e'; apply R_blt_lt in e'; lra);
        rewrite He in pi.
    + replace ((existT (fun x : R => (0 <? x) = true) (projT1 r * eval_Poly val a) e', A)
                 :: eval_p_sequent val l) with
          (hseq.vec (hseq.mul_vec r ((existT (fun x => (0 <? x) = true) (eval_Poly val a) e) :: nil)) A ++ eval_p_sequent val l).
      2:{ simpl.
          replace (time_pos r (existT (fun x : R => (0 <? x) = true) (eval_Poly val a) e))
            with (existT (fun x : R => (0 <? x) = true) (projT1 r * eval_Poly val a) e') by (destruct r; apply Rpos_eq; clear; simpl; nra); auto. }
      apply hrr_mul_inv.
      apply pi.
    + apply pi.
  - inversion Hwd; inversion X; subst.
    simpl in pi |- *.
    case_eq (R_order_dec (eval_Poly val a)); intros e He;
      try (exfalso; clear - e H2;
           try (apply R_blt_lt in e); simpl in *; lra);
      rewrite He in pi.
    2:{ apply hrr_W; apply pi. }
    revert pi;set (r := (existT (fun x : R => (0 <? x) = true) (eval_Poly val a) e)); intros pi.
    change ((r, A1) :: eval_p_sequent val l) with
        (hseq.vec (r :: nil) A1 ++ eval_p_sequent val l).
    change ((r, A2) :: eval_p_sequent val l) with
        (hseq.vec (r :: nil) A2 ++ eval_p_sequent val l).
    apply hrr_max_inv.
    apply pi.
Qed.

Lemma apply_logical_rule_on_p_hypersequent_inl_HR_inv :
  forall val G G1,
    apply_logical_rule_on_p_hypersequent G = inl G1 ->
    p_hseq_well_defined val G ->
    HR_T_M (map (eval_p_sequent val) G1) ->
    HR_T_M (map (eval_p_sequent val) G).
Proof.
  intros val G G1 Heq Hwd pi.
  destruct G; [ exfalso; apply (HR_not_empty _ _ pi); inversion Heq; auto | ].
  destruct l; [ inversion Heq; subst; apply pi | ].
  destruct p as [a A].
  destruct A; inversion Heq; subst; auto.
  - inversion Hwd; inversion X; subst.
    simpl in *.
    case_eq (R_order_dec (eval_Poly val a)); intros e He;
      try (exfalso; clear - e H2;
           try (apply R_blt_lt in e); simpl in *; lra).
    2:{ apply pi. }
    revert pi;set (r := (existT (fun x : R => (0 <? x) = true) (eval_Poly val a) e)); intros pi.
    change ((r, RS_zero) :: eval_p_sequent val l) with
        (hseq.vec (r :: nil) RS_zero ++ eval_p_sequent val l).
    apply hrr_Z.
    apply pi.
  - inversion Hwd; inversion X; subst.
    simpl in pi |- *.
    case_eq (R_order_dec (eval_Poly val a)); intros e He;
      try (exfalso; clear - e H2;
           try (apply R_blt_lt in e); simpl in *; lra).
    2:{ rewrite He in pi; apply pi. }
    rewrite He in pi.
    revert pi;set (r := (existT (fun x : R => (0 <? x) = true) (eval_Poly val a) e)); intros pi.
    change ((r, A1 +S A2) :: eval_p_sequent val l) with
        (hseq.vec (r :: nil) (A1 +S A2) ++ eval_p_sequent val l).
    apply hrr_plus.
    apply pi.
  - inversion Hwd; inversion X; subst.
    simpl in *.
    case_eq (R_order_dec (eval_Poly val a)); intros e He;
      try (exfalso; clear - e H2;
           try (apply R_blt_lt in e); simpl in *; lra);
    case_eq (R_order_dec (projT1 r * eval_Poly val a)); intros e' He';
      try (exfalso; destruct r as [r Hr]; clear - e e' H2;
           simpl in *;
           apply R_blt_lt in Hr; apply R_blt_lt in e; try (apply R_blt_lt in e');
           nra);
      try (exfalso; clear - e e'; rewrite e in e'; apply R_blt_lt in e'; lra);
      rewrite He' in pi.
    2:{ apply pi. }
    replace ((existT (fun x : R => (0 <? x) = true) (projT1 r * eval_Poly val a) e', A)
              :: eval_p_sequent val l) with
        (hseq.vec (hseq.mul_vec r ((existT (fun x => (0 <? x) = true) (eval_Poly val a) e) :: nil)) A ++ eval_p_sequent val l) in pi.
    2:{ simpl.
        replace (time_pos r (existT (fun x : R => (0 <? x) = true) (eval_Poly val a) e))
          with (existT (fun x : R => (0 <? x) = true) (projT1 r * eval_Poly val a) e') by (destruct r; apply Rpos_eq; clear; simpl; nra); auto. }
    revert pi;set (r' := (existT (fun x : R => (0 <? x) = true) (eval_Poly val a) e)); intros pi.
    change ((r', r *S A) :: eval_p_sequent val l)
      with (hseq.vec (r' :: nil) (r *S A) ++ eval_p_sequent val l).
    apply hrr_mul.
    apply pi.
  - inversion Hwd; inversion X; subst.
    simpl in pi |- *.
    case_eq (R_order_dec (eval_Poly val a)); intros e He;
      try (exfalso; clear - e H2;
           try (apply R_blt_lt in e); simpl in *; lra);
      rewrite He in pi.
    2:{ apply hrr_C.
        apply pi. }
    revert pi;set (r := (existT (fun x : R => (0 <? x) = true) (eval_Poly val a) e)); intros pi.
    change ((r, A1 \/S A2) :: eval_p_sequent val l) with
        (hseq.vec (r :: nil) (A1 \/S A2) ++ eval_p_sequent val l).
    apply hrr_max.
    apply pi.
Qed.

Lemma apply_logical_rule_on_p_hypersequent_inr_l_HR :
  forall val G G1 G2,
    apply_logical_rule_on_p_hypersequent G = inr (G1 , G2) ->
    p_hseq_well_defined val G ->
    HR_T_M (map (eval_p_sequent val) G) ->
    HR_T_M (map (eval_p_sequent val) G1).
Proof.
  intros val G G1 G2 Heq Hwd pi.
  destruct G; [ exfalso; apply (HR_not_empty _ nil pi); auto | ].
  destruct l; [ inversion Heq; apply pi | ].
  destruct p as [a A].
  destruct A; inversion Heq; subst; auto.
  inversion Hwd; inversion X; subst.
  simpl in pi |- *.
  case_eq (R_order_dec (eval_Poly val a)); intros e He;
    try (exfalso; clear - e H2;
         try (apply R_blt_lt in e); simpl in *; lra);
    rewrite He in pi.
  2:{ apply pi. }
  revert pi;set (r := (existT (fun x : R => (0 <? x) = true) (eval_Poly val a) e)); intros pi.
  change ((r, A1) :: eval_p_sequent val l) with
      (hseq.vec (r :: nil) A1 ++ eval_p_sequent val l).
  apply hrr_min_inv_l with A2.
  apply pi.
Qed.

Lemma apply_logical_rule_on_p_hypersequent_inr_r_HR :
  forall val G G1 G2,
    apply_logical_rule_on_p_hypersequent G = inr (G1 , G2) ->
    p_hseq_well_defined val G ->
    HR_T_M (map (eval_p_sequent val) G) ->
    HR_T_M (map (eval_p_sequent val) G2).
Proof.
  intros val G G1 G2 Heq Hwd pi.
  destruct G; [ exfalso; apply (HR_not_empty _ nil pi); auto | ].
  destruct l; [ inversion Heq; apply pi | ].
  destruct p as [a A].
  destruct A; inversion Heq; subst; auto.
  inversion Hwd; inversion X; subst.
  simpl in pi |- *.
  case_eq (R_order_dec (eval_Poly val a)); intros e He;
    try (exfalso; clear - e H2;
         try (apply R_blt_lt in e); simpl in *; lra);
    rewrite He in pi.
  2:{ apply pi. }
  revert pi;set (r := (existT (fun x : R => (0 <? x) = true) (eval_Poly val a) e)); intros pi.
  change ((r, A2) :: eval_p_sequent val l) with
      (hseq.vec (r :: nil) A2 ++ eval_p_sequent val l).
  apply hrr_min_inv_r with A1.
  apply pi.
Qed.

Lemma apply_logical_rule_on_p_hypersequent_inr_HR_inv :
  forall val G G1 G2,
    apply_logical_rule_on_p_hypersequent G = inr (G1 , G2) ->
    p_hseq_well_defined val G ->
    HR_T_M (map (eval_p_sequent val) G1) ->
    HR_T_M (map (eval_p_sequent val) G2) ->
    HR_T_M (map (eval_p_sequent val) G).
Proof.
  intros val G G1 G2 Heq Hwd pi1 pi2.
  destruct G; [ exfalso; inversion Heq | ].
  destruct l; [ inversion Heq | ].
  destruct p as [a A].
  destruct A; inversion Heq; subst; auto.
  inversion Hwd; inversion X; subst.
  simpl in pi1,pi2 |- *.
  case_eq (R_order_dec (eval_Poly val a)); intros e He;
    try (exfalso; clear - e H2;
         try (apply R_blt_lt in e); simpl in *; lra);
    rewrite He in pi1; rewrite He in pi2.
  2:{ apply pi1. }
  revert pi1 pi2;set (r := (existT (fun x : R => (0 <? x) = true) (eval_Poly val a) e)); intros pi1 pi2.
  change ((r, A1 /\S A2) :: eval_p_sequent val l) with
      (hseq.vec (r :: nil) (A1 /\S A2) ++ eval_p_sequent val l).
  apply hrr_min; auto.
Qed.

Lemma apply_logical_rule_on_p_hypersequent_correct_inl :
  forall G G1 n,
    fst (HR_outer_complexity_p_hseq G) = S n ->
    apply_logical_rule_on_p_hypersequent (p_hseq_put_non_atomic_fst G) = inl G1 ->
    HR_outer_complexity_p_hseq G1 <2 HR_outer_complexity_p_hseq G.
Proof.
  intros G G1 n H1 H2.
  simpl in H1.
  remember (p_hseq_put_non_atomic_fst G) as H.
  destruct H.
  { exfalso.
    rewrite <- p_hseq_put_non_atomic_fst_HR_complexity in H1 ; [ rewrite <- HeqH in H1; inversion H1 |].
    intros Hnb.
    simpl in H1.
    apply p_hseq_is_atomic_outer_complexity_0 in Hnb; lia. }
  destruct l.
  { unfold p_hseq_put_non_atomic_fst in HeqH.
    inversion HeqH. }
  destruct p as [a A].
  assert (is_atom A -> False).
  { apply p_hseq_put_non_atomic_fst_correct with G a l H; auto.
    intros Hb.
    apply p_hseq_is_atomic_outer_complexity_0 in Hb.
    lia. }
  destruct A; simpl in H2; inversion H2; subst; try (exfalso; now apply H0).
  - rewrite <- (p_hseq_put_non_atomic_fst_HR_complexity G).
    2:{ intros Hnb.
        apply p_hseq_is_atomic_outer_complexity_0 in Hnb; lia. }
    rewrite <- HeqH.
    change ((a, RS_zero) :: l) with (vec (a :: nil) RS_zero ++ l).
    apply hrr_Z_decrease_complexity ; [ intros H'; inversion H' | ].
    simpl vec; simpl app.
    rewrite HeqH.
    unfold p_hseq_put_non_atomic_fst in *.
    rewrite HR_outer_complexity_perm_fst_seq with _ _ (p_hseq_p_seq_max_complexity G).
    2:{ symmetry; apply p_seq_put_non_atomic_fst.
        intros Hb.
        apply p_seq_is_atomic_complexity_0 in Hb.
        rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
    rewrite outer_complexity_p_hseq_perm with _ G.
    2:{ symmetry; apply p_hseq_put_max_complexity_fst.
        intros Heq; rewrite Heq in H1; inversion H1. }
    rewrite <-p_hseq_p_seq_max_complexity_correct.
    rewrite outer_complexity_p_seq_perm with (p_hseq_p_seq_max_complexity G) (p_seq_fst_non_atomic_term (p_hseq_p_seq_max_complexity G) :: p_seq_without_fst_non_atomic_term (p_hseq_p_seq_max_complexity G)).
    2:{ apply p_seq_put_non_atomic_fst.
        intros Hb.
        apply p_seq_is_atomic_complexity_0 in Hb.
        rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
    inversion HeqH; subst; reflexivity.
  - rewrite <- (p_hseq_put_non_atomic_fst_HR_complexity G).
    2:{ intros Hnb.
        apply p_hseq_is_atomic_outer_complexity_0 in Hnb; lia. }
    rewrite <- HeqH.
    change ((a, A1 +S A2) :: l) with (vec (a :: nil) (A1 +S A2) ++ l).
    change ((a, A1) :: (a, A2) :: l) with (vec (a :: nil) A1 ++ vec (a :: nil) A2 ++ l).
    apply hrr_plus_decrease_complexity ; [ intros H'; inversion H' | ].
    simpl vec; simpl app.
    rewrite HeqH.
    unfold p_hseq_put_non_atomic_fst in *.
    rewrite HR_outer_complexity_perm_fst_seq with _ _ (p_hseq_p_seq_max_complexity G).
    2:{ symmetry; apply p_seq_put_non_atomic_fst.
        intros Hb.
        apply p_seq_is_atomic_complexity_0 in Hb.
        rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
    rewrite outer_complexity_p_hseq_perm with _ G.
    2:{ symmetry; apply p_hseq_put_max_complexity_fst.
        intros Heq; rewrite Heq in H1; inversion H1. }
    rewrite <-p_hseq_p_seq_max_complexity_correct.
    rewrite outer_complexity_p_seq_perm with (p_hseq_p_seq_max_complexity G) (p_seq_fst_non_atomic_term (p_hseq_p_seq_max_complexity G) :: p_seq_without_fst_non_atomic_term (p_hseq_p_seq_max_complexity G)).
    2:{ apply p_seq_put_non_atomic_fst.
        intros Hb.
        apply p_seq_is_atomic_complexity_0 in Hb.
        rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
    inversion HeqH; subst; reflexivity.
  - rewrite <- (p_hseq_put_non_atomic_fst_HR_complexity G).
    2:{ intros Hnb.
        apply p_hseq_is_atomic_outer_complexity_0 in Hnb; lia. }
    rewrite <- HeqH.
    change ((a, r *S A) :: l) with (vec (a :: nil) (r *S A) ++ l).
    change ((Poly_cst (projT1 r) *R a, A) :: l) with (vec (mul_vec (Poly_cst (projT1 r)) (a :: nil)) A ++ l).
    apply hrr_mul_decrease_complexity ; [ intros H'; inversion H' | ].
    simpl vec; simpl app.
    rewrite HeqH.
    unfold p_hseq_put_non_atomic_fst in *.
    rewrite HR_outer_complexity_perm_fst_seq with _ _ (p_hseq_p_seq_max_complexity G).
    2:{ symmetry; apply p_seq_put_non_atomic_fst.
        intros Hb.
        apply p_seq_is_atomic_complexity_0 in Hb.
        rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
    rewrite outer_complexity_p_hseq_perm with _ G.
    2:{ symmetry; apply p_hseq_put_max_complexity_fst.
        intros Heq; rewrite Heq in H1; inversion H1. }
    rewrite <-p_hseq_p_seq_max_complexity_correct.
    rewrite outer_complexity_p_seq_perm with (p_hseq_p_seq_max_complexity G) (p_seq_fst_non_atomic_term (p_hseq_p_seq_max_complexity G) :: p_seq_without_fst_non_atomic_term (p_hseq_p_seq_max_complexity G)).
    2:{ apply p_seq_put_non_atomic_fst.
        intros Hb.
        apply p_seq_is_atomic_complexity_0 in Hb.
        rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
    inversion HeqH; subst; reflexivity.
  - rewrite <- (p_hseq_put_non_atomic_fst_HR_complexity G).
    2:{ intros Hnb.
        apply p_hseq_is_atomic_outer_complexity_0 in Hnb; lia. }
    rewrite <- HeqH.
    change ((a, A1 \/S A2) :: l) with (vec (a :: nil) (A1 \/S A2) ++ l).
    change ((a, A1) :: l) with (vec (a :: nil) A1 ++ l).
    change ((a, A2) :: l) with (vec (a :: nil) A2 ++ l).
    apply hrr_max_decrease_complexity ; [ intros H'; inversion H' | ].
    simpl vec; simpl app.
    rewrite HeqH.
    unfold p_hseq_put_non_atomic_fst in *.
    rewrite HR_outer_complexity_perm_fst_seq with _ _ (p_hseq_p_seq_max_complexity G).
    2:{ symmetry; apply p_seq_put_non_atomic_fst.
        intros Hb.
        apply p_seq_is_atomic_complexity_0 in Hb.
        rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
    rewrite outer_complexity_p_hseq_perm with _ G.
    2:{ symmetry; apply p_hseq_put_max_complexity_fst.
        intros Heq; rewrite Heq in H1; inversion H1. }
    rewrite <-p_hseq_p_seq_max_complexity_correct.
    rewrite outer_complexity_p_seq_perm with (p_hseq_p_seq_max_complexity G) (p_seq_fst_non_atomic_term (p_hseq_p_seq_max_complexity G) :: p_seq_without_fst_non_atomic_term (p_hseq_p_seq_max_complexity G)).
    2:{ apply p_seq_put_non_atomic_fst.
        intros Hb.
        apply p_seq_is_atomic_complexity_0 in Hb.
        rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
    inversion HeqH; subst; reflexivity.
Qed.

Lemma apply_logical_rule_on_p_hypersequent_correct_inr_l :
  forall G G1 G2 n,
    fst (HR_outer_complexity_p_hseq G) = S n ->
    apply_logical_rule_on_p_hypersequent (p_hseq_put_non_atomic_fst G) = inr (G1 , G2) ->
    HR_outer_complexity_p_hseq G1 <2 HR_outer_complexity_p_hseq G.
Proof.
  intros G G1 G2 n H1 H2.
  simpl in H1.
  remember (p_hseq_put_non_atomic_fst G) as H.
  destruct H.
  { exfalso.
    rewrite <- p_hseq_put_non_atomic_fst_HR_complexity in H1 ; [ rewrite <- HeqH in H1; inversion H1 |].
    intros Hnb.
    apply p_hseq_is_atomic_outer_complexity_0 in Hnb; lia. }
  destruct l.
  { unfold p_hseq_put_non_atomic_fst in HeqH.
    inversion HeqH. }
  destruct p as [a A].
  assert (is_atom A -> False).
  { apply p_hseq_put_non_atomic_fst_correct with G a l H; auto.
    intros Hb.
    apply p_hseq_is_atomic_outer_complexity_0 in Hb.
    lia. }
  destruct A; simpl in H2; inversion H2; subst; try (exfalso; now apply H0).
  rewrite <- (p_hseq_put_non_atomic_fst_HR_complexity G).
  2:{ intros Hnb.
      apply p_hseq_is_atomic_outer_complexity_0 in Hnb; lia. }
  rewrite <- HeqH.
  change ((a, A1 /\S A2) :: l) with (vec (a :: nil) (A1 /\S A2) ++ l).
  change ((a, A1) :: l) with (vec (a :: nil) A1 ++ l).
  apply hrr_min_r_decrease_complexity ; [ intros H'; inversion H' | ].
  simpl vec; simpl app.
  rewrite HeqH.
  unfold p_hseq_put_non_atomic_fst in *.
  rewrite HR_outer_complexity_perm_fst_seq with _ _ (p_hseq_p_seq_max_complexity G).
  2:{ symmetry; apply p_seq_put_non_atomic_fst.
      intros Hb.
      apply p_seq_is_atomic_complexity_0 in Hb.
      rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
  rewrite outer_complexity_p_hseq_perm with _ G.
  2:{ symmetry; apply p_hseq_put_max_complexity_fst.
      intros Heq; rewrite Heq in H1; inversion H1. }
  rewrite <-p_hseq_p_seq_max_complexity_correct.
  rewrite outer_complexity_p_seq_perm with (p_hseq_p_seq_max_complexity G) (p_seq_fst_non_atomic_term (p_hseq_p_seq_max_complexity G) :: p_seq_without_fst_non_atomic_term (p_hseq_p_seq_max_complexity G)).
  2:{ apply p_seq_put_non_atomic_fst.
      intros Hb.
      apply p_seq_is_atomic_complexity_0 in Hb.
      rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
  inversion HeqH; subst; reflexivity.
Qed.

Lemma apply_logical_rule_on_p_hypersequent_correct_inr_r :
  forall G G1 G2 n,
    fst (HR_outer_complexity_p_hseq G) = S n ->
    apply_logical_rule_on_p_hypersequent (p_hseq_put_non_atomic_fst G) = inr (G1 , G2) ->
    HR_outer_complexity_p_hseq G2 <2 HR_outer_complexity_p_hseq G.
Proof.
  intros G G1 G2 n H1 H2.
  simpl in H1.
  remember (p_hseq_put_non_atomic_fst G) as H.
  destruct H.
  { exfalso.
    rewrite <- p_hseq_put_non_atomic_fst_HR_complexity in H1 ; [ rewrite <- HeqH in H1; inversion H1 |].
    intros Hnb.
    apply p_hseq_is_atomic_outer_complexity_0 in Hnb; lia. }
  destruct l.
  { unfold p_hseq_put_non_atomic_fst in HeqH.
    inversion HeqH. }
  destruct p as [a A].
  assert (is_atom A -> False).
  { apply p_hseq_put_non_atomic_fst_correct with G a l H; auto.
    intros Hb.
    apply p_hseq_is_atomic_outer_complexity_0 in Hb.
    lia. }
  destruct A; simpl in H2; inversion H2; subst; try (exfalso; now apply H0).
  rewrite <- (p_hseq_put_non_atomic_fst_HR_complexity G).
  2:{ intros Hnb.
      apply p_hseq_is_atomic_outer_complexity_0 in Hnb; lia. }
  rewrite <- HeqH.
  change ((a, A1 /\S A2) :: l) with (vec (a :: nil) (A1 /\S A2) ++ l).
  change ((a, A2) :: l) with (vec (a :: nil) A2 ++ l).
  apply hrr_min_l_decrease_complexity ; [ intros H'; inversion H' | ].
  simpl vec; simpl app.
  rewrite HeqH.
  unfold p_hseq_put_non_atomic_fst in *.
  rewrite HR_outer_complexity_perm_fst_seq with _ _ (p_hseq_p_seq_max_complexity G).
  2:{ symmetry; apply p_seq_put_non_atomic_fst.
      intros Hb.
      apply p_seq_is_atomic_complexity_0 in Hb.
      rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
  rewrite outer_complexity_p_hseq_perm with _ G.
  2:{ symmetry; apply p_hseq_put_max_complexity_fst.
      intros Heq; rewrite Heq in H1; inversion H1. }
  rewrite <-p_hseq_p_seq_max_complexity_correct.
  rewrite outer_complexity_p_seq_perm with (p_hseq_p_seq_max_complexity G) (p_seq_fst_non_atomic_term (p_hseq_p_seq_max_complexity G) :: p_seq_without_fst_non_atomic_term (p_hseq_p_seq_max_complexity G)).
  2:{ apply p_seq_put_non_atomic_fst.
      intros Hb.
      apply p_seq_is_atomic_complexity_0 in Hb.
      rewrite p_hseq_p_seq_max_complexity_correct in Hb; lia. }
  inversion HeqH; subst; reflexivity.
Qed.

(* end hide *)


From Mtac2 Require Import Mtac2.
Require Import Bool.Bool.

Example hyp_well_formed : True.
MProof.
  (\nu x := I,
   l <- M.hyps;
   oeq <- M.unify l [m: ahyp x (mSome I)] UniCoq;
   match oeq with
   | mNone => M.raise exception
   | _ => M.ret I
   end)%MC.
Qed.

Example env_well_formed : True.
MProof.
  (\nu x := I,
   oeq <- M.unify x I UniCoq;
   match oeq with
   | mNone => M.raise exception
   | _ => M.ret I
   end)%MC.
Qed.

Example fail_returning_var : True.
MProof.
  (mtry
    (\nu x := I, M.ret x);; M.raise exception
  with VarAppearsInValue => M.ret I
  end)%MC.
Qed.


(* * Jasmin semantics with “partial values”. *)

(* ** Imports and settings *)
From mathcomp Require Import all_ssreflect all_algebra.
Require Import ZArith Psatz.
Require Export utils syscall wsize word type low_memory sem_type values.
Import Utf8.

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

Local Open Scope Z_scope.

Section Section.

Context {pd: PointerData} {syscall_state : Type} {sc_sem : syscall_sem syscall_state}.

Definition exec_getrandom_s_core (scs : syscall_state_t) (m : mem) (p:pointer) (len:pointer) : exec (syscall_state_t * mem * pointer) :=
  let len := wunsigned len in
  let sd := syscall.get_random scs len in
  Let m := fill_mem m p sd.2 in
  ok (sd.1, m, p).

Lemma exec_getrandom_s_core_stable scs m p len rscs rm rp :
  exec_getrandom_s_core scs m p len = ok (rscs, rm, rp) →
  stack_stable m rm.
Proof. by rewrite /exec_getrandom_s_core; t_xrbindP => rm' /fill_mem_stack_stable hf ? <- ?. Qed.

Lemma exec_getrandom_s_core_validw scs m p len rscs rm rp :
  exec_getrandom_s_core scs m p len = ok (rscs, rm, rp) →
  validw m =2 validw rm.
Proof. by rewrite /exec_getrandom_s_core; t_xrbindP => rm' /fill_mem_validw_eq hf ? <- ?. Qed.

Definition sem_syscall (o:syscall_t) :
     syscall_state_t -> mem -> sem_prod (syscall_sig_s o).(scs_tin) (exec (syscall_state_t * mem * sem_tuple (syscall_sig_s o).(scs_tout))) :=
  match o with
  | RandomBytes _ => exec_getrandom_s_core
  end.

Definition exec_syscall_s (scs : syscall_state_t) (m : mem) (o:syscall_t) vs : exec (syscall_state_t * mem * values) :=
  let semi := sem_syscall o in
  Let: (scs', m', t) := app_sopn _ (semi scs m) vs in
  ok (scs', m', list_ltuple t).

Lemma syscall_sig_s_noarr o : all is_not_sarr (syscall_sig_s o).(scs_tin).
Proof. by case: o. Qed.

Lemma exec_syscallPs_eq scs m o vargs vargs' rscs rm vres :
  exec_syscall_s scs m o vargs = ok (rscs, rm, vres) →
  List.Forall2 value_uincl vargs vargs' →
  exec_syscall_s scs m o vargs' = ok (rscs, rm, vres).
Proof.
  rewrite /exec_syscall_s; t_xrbindP => -[[scs' m'] t] happ [<- <- <-] hu.
  by have -> := vuincl_sopn (syscall_sig_s_noarr o ) hu happ.
Qed.

Lemma exec_syscallPs scs m o vargs vargs' rscs rm vres :
  exec_syscall_s scs m o vargs = ok (rscs, rm, vres) →
  List.Forall2 value_uincl vargs vargs' →
  exists2 vres' : values,
    exec_syscall_s scs m o vargs' = ok (rscs, rm, vres') & List.Forall2 value_uincl vres vres'.
Proof.
  move=> h1 h2; rewrite (exec_syscallPs_eq h1 h2).
  by exists vres=> //; apply List_Forall2_refl.
Qed.

Definition mem_equiv m1 m2 := stack_stable m1 m2 /\ validw m1 =2 validw m2.

Lemma sem_syscall_equiv o scs m :
  mk_forall (fun (rm: (syscall_state_t * mem * _)) => mem_equiv m rm.1.2)
            (sem_syscall o scs m).
Proof.
  case: o => _len /= p len [[scs' rm] t] /= hex; split.
  + by apply: exec_getrandom_s_core_stable hex.
  by apply: exec_getrandom_s_core_validw hex.
Qed.

Lemma exec_syscallSs scs m o vargs rscs rm vres :
  exec_syscall_s scs m o vargs = ok (rscs, rm, vres) →
  mem_equiv m rm.
Proof.
  rewrite /exec_syscall_s; t_xrbindP => -[[scs' m'] t] happ [_ <- _].
  apply (mk_forallP (sem_syscall_equiv o scs m) happ).
Qed.

End Section.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import msl.base.
Open Local Scope nat_scope.

Require Import msl.ageable.
Require Import msl.functors.
Require Import msl.sepalg.
Require Import msl.sepalg_functors.
Require Import msl.sepalg_generators.
Require Import msl.predicates_hered.
Require Import msl.knot_hered.
Require Import msl.knot_lemmas.
Require Import msl.age_sepalg.

Module Type TY_FUNCTOR_SA_PROP.
  Declare Module TF:TY_FUNCTOR_PROP.
  Import TF.

  Parameter Join_F: forall A, Join (F A). Existing Instance Join_F.
(*   Parameter Perm_F: forall A, Perm_alg (F A). EXisting Instance Perm_F. *)
  Parameter paf_F : pafunctor f_F.        Existing Instance paf_F.
  Parameter Perm_F: Perm_paf f_F Join_F.
  Parameter Sep_F: Sep_paf f_F Join_F.
  Parameter Canc_F: Canc_paf f_F Join_F.
  Parameter Disj_F: Disj_paf f_F Join_F.
End TY_FUNCTOR_SA_PROP.

Module Type KNOT_HERED_SA.
  Declare Module TFSA:TY_FUNCTOR_SA_PROP.
  Declare Module K:KNOT_HERED with Module TF:=TFSA.TF.

  Import TFSA.TF.
  Import TFSA.
  Import K.

  Parameter Join_knot: Join knot.  Existing Instance Join_knot.
  Parameter Perm_knot : Perm_alg knot.  Existing Instance Perm_knot.
  Parameter Sep_knot : (forall A, Sep_alg (F A)) -> Sep_alg knot.  Existing Instance Sep_knot.
  Parameter Canc_knot : (forall A, Canc_alg (F A)) -> Canc_alg knot.  Existing Instance Canc_knot.
  Parameter Disj_knot : (forall A, Disj_alg (F A)) -> Disj_alg knot.  Existing Instance Disj_knot.

  Instance Join_nat_F: Join (nat * F predicate) :=
       Join_prod nat  (Join_equiv nat) (F predicate) _.

 Instance Perm_nat_F : Perm_alg (nat * F predicate) :=
    @Perm_prod nat _ _ _ (Perm_equiv _) (Perm_F predicate _ (Perm_equiv _)).
 Instance Sep_nat_F (Sep_F: forall A, Sep_alg (F A)): Sep_alg (nat * F predicate) :=
    @Sep_prod nat _ _ _ (Sep_equiv _) (Sep_F predicate).
 Instance Canc_nat_F (Canc_F: forall A, Canc_alg (F A)): Canc_alg (nat * F predicate) :=
    @Canc_prod nat _ _ _ (Canc_equiv _) (Canc_F predicate).
 Instance Disj_nat_F (Disj_F: forall A, Disj_alg (F A)): Disj_alg (nat * F predicate) :=
    @Disj_prod nat _ _ _ (Disj_equiv _) (Disj_F predicate).

  Axiom join_unsquash : forall x1 x2 x3 : knot,
    join x1 x2 x3 = join (unsquash x1) (unsquash x2) (unsquash x3).

  Axiom asa_knot : Age_alg knot.

End KNOT_HERED_SA.

Module KnotHeredSa (TFSA':TY_FUNCTOR_SA_PROP) (K':KNOT_HERED with Module TF:=TFSA'.TF)
  : KNOT_HERED_SA with Module TFSA:=TFSA' with Module K:=K'.

  Module TFSA:=TFSA'.
  Module K:=K'.

  Module KL := KnotHered_Lemmas(K).

  Import TFSA.TF.
  Import TFSA.
  Import K.
  Import KL.

  Instance Join_nat_F: Join (nat * F predicate) :=
       Join_prod nat  (Join_equiv nat) (F predicate) _.

 Instance Perm_nat_F : Perm_alg (nat * F predicate) :=
    @Perm_prod nat _ _ _ (Perm_equiv _) (Perm_F predicate _ (Perm_equiv _)).
 Instance Sep_nat_F (Sep_F: forall A, Sep_alg (F A)): Sep_alg (nat * F predicate) :=
    @Sep_prod nat _ _ _ (Sep_equiv _) (Sep_F predicate).
 Instance Canc_nat_F (Canc_F: forall A, Canc_alg (F A)): Canc_alg (nat * F predicate) :=
    @Canc_prod nat _ _ _ (Canc_equiv _) (Canc_F predicate).
 Instance Disj_nat_F (Disj_F: forall A, Disj_alg (F A)): Disj_alg (nat * F predicate) :=
    @Disj_prod nat _ _ _ (Disj_equiv _) (Disj_F predicate).

  Lemma unsquash_squash_join_hom : join_hom (unsquash oo squash).
  Proof.
    unfold compose.
    intros [x1 x2] [y1 y2] [z1 z2] ?.
    do 3 rewrite (unsquash_squash).
    firstorder.
    simpl in *.
    subst y1.
    subst z1.
    apply paf_join_hom. auto.
  Qed.

  Instance Join_knot : Join knot :=
           Join_preimage knot (nat * F predicate) Join_nat_F unsquash.

  Instance Perm_knot : Perm_alg knot :=
    Perm_preimage _ _ _ _ unsquash squash squash_unsquash unsquash_squash_join_hom.

  Instance Sep_knot(Sep_F: forall A, Sep_alg (F A)) : Sep_alg knot :=
    Sep_preimage _ _ _  unsquash squash squash_unsquash unsquash_squash_join_hom.

  Lemma join_unsquash : forall x1 x2 x3,
    join x1 x2 x3 =
    join (unsquash x1) (unsquash x2) (unsquash x3).
  Proof.
    intuition.
  Qed.

  Instance Canc_knot(Canc_F: forall A, Canc_alg (F A)) : Canc_alg knot.
  Proof. repeat intro.
            do 3 red in H, H0.
            apply unsquash_inj.
            apply (join_canc H H0).
  Qed.

  Instance Disj_knot(Disj_F: forall A, Disj_alg (F A)) : Disj_alg knot.
  Proof.
   repeat intro.
   do 3 red in H.
   apply join_self in H.
   apply unsquash_inj; auto.
  Qed.

  Lemma age_join1 :
    forall x y z x' : K'.knot,
      join x y z ->
      age x x' ->
      exists y' : K'.knot,
        exists z' : K'.knot, join x' y' z' /\ age y y' /\ age z z'.
  Proof.
    intros.
    unfold age in *; simpl in *.
    rewrite knot_age1 in H0.
    repeat rewrite knot_age1.
    do 3 red in H.
    destruct (unsquash x).
    destruct (unsquash y).
    destruct (unsquash z).
    destruct n; try discriminate.
    inv H0.
   simpl in H; destruct H.
    simpl in H; destruct H.
    subst n0 n1.
    exists (squash (n,f0)).
    exists (squash (n,f1)).
    simpl in H0.
    split; intuition. do 3  red.
    repeat rewrite unsquash_squash.
    split; auto. simpl snd.
    apply paf_join_hom; auto.
  Qed.
  Lemma age_join2 :
    forall x y z z' : K'.knot,
      join x y z ->
      age z z' ->
      exists x' : K'.knot,
        exists y' : K'.knot, join x' y' z' /\ age x x' /\ age y y'.
  Proof.
    intros.
    unfold age in *; simpl in *.
    rewrite knot_age1 in H0.
    repeat rewrite knot_age1.
    do 3 red in H.
    destruct (unsquash x).
    destruct (unsquash y).
    destruct (unsquash z).
    destruct n1; try discriminate.
    inv H0.
    destruct H; simpl in *.
    destruct H; subst.
    exists (squash (n1,f)).
    exists (squash (n1,f0)).
    split; intuition. do 3  red.
    repeat rewrite unsquash_squash.
    split; auto. simpl snd.
    apply paf_join_hom; auto.
  Qed.

  Lemma unage_join1 : forall x x' y' z', join x' y' z' -> age x x' ->
    exists y, exists z, join x y z /\ age y y' /\ age z z'.
  Proof.
    intros.
    unfold join, Join_knot, Join_preimage, age in *; simpl in *.
    revert H0; rewrite knot_age1; case_eq (unsquash x); intros.
    destruct n; inv H1.
    hnf in H. rewrite unsquash_squash in H. simpl in H.
    revert H.
    case_eq (unsquash y');
    case_eq (unsquash z'); intros.
    destruct H2; simpl in *.
    destruct H2; subst.
    rename n0 into n.
    destruct (paf_preserves_unmap_right (approx n) f f1 f0)
      as [q [w [? [? ?]]]].
    rewrite <- (unsquash_approx H1); auto.
    exists (squash (S n,q)).
    exists (squash (S n,w)). split. hnf.
    repeat rewrite unsquash_squash.
    split; simpl; auto.
    generalize (paf_join_hom (approx (S n)) _ _ _ H2).
    rewrite <- (unsquash_approx H0); auto.

    split; hnf.
    rewrite knot_age1.
    rewrite unsquash_squash. f_equal.
    replace y' with (squash (n,fmap (approx (S n)) q)); auto.
    apply unsquash_inj.
    rewrite unsquash_squash, H1.
    apply injective_projections; simpl; auto.
    rewrite (unsquash_approx H1).
    rewrite <- H4.
    rewrite fmap_app.
    replace (approx n oo approx (S n)) with (approx n); auto.
    extensionality a.
    replace (S n) with (1 + n)%nat by trivial.
    rewrite <- (approx_approx1 1 n).
    trivial.

    rewrite knot_age1.
    rewrite unsquash_squash. f_equal.
    replace z' with  (squash (n,fmap (approx (S n)) w)); auto.
    apply unsquash_inj.
    rewrite unsquash_squash, H.
    apply injective_projections; simpl; auto.
    rewrite <- H5.
    rewrite fmap_app.
    replace (approx n oo approx (S n)) with (approx n); auto.
    extensionality a.
    replace (S n) with (1 + n)%nat by trivial.
    rewrite <- (approx_approx1 1 n).
    trivial.
  Qed.

  Lemma unage_join2 :
    forall z x' y' z', join x' y' z' -> age z z' ->
      exists x, exists y, join x y z /\ age x x' /\ age y y'.
  Proof.
    intros.
    rewrite join_unsquash in H.
    revert H H0.
    unfold join, Join_knot, Join_preimage, age in *; simpl in *.
    repeat rewrite knot_age1.

    case_eq (unsquash x');
    case_eq (unsquash y');
    case_eq (unsquash z');
    case_eq (unsquash z); intros.
    destruct n;  inv H4.
    destruct H3. hnf in H3. simpl in *. destruct H3; subst.
    rewrite unsquash_squash in H0.
    inv H0.
    rename n0 into n.

    destruct (paf_preserves_unmap_left
      (approx n) f2 f1 f)
      as [wx [wy [? [? ?]]]]; auto.
    rewrite <- (unsquash_approx H1); auto.
    exists (squash (S n, wx)).
    exists (squash (S n, wy)).
    split. unfold join, Join_nat_F, Join_prod; simpl.
    (* unfold Join_knot; simpl. unfold Join_preimage; simpl. *)
    repeat rewrite unsquash_squash.  simpl.  split; auto.

    rewrite (unsquash_approx H).
    apply paf_join_hom; auto.
    split; rewrite knot_age1; rewrite unsquash_squash; f_equal; hnf.
    apply unsquash_inj.
    rewrite unsquash_squash, H2.
    apply injective_projections; simpl; auto.
    rewrite fmap_app.
    replace (approx n oo approx (S n)) with (approx n); auto.
    extensionality x.
    unfold compose.
    change (approx n (approx (S n) x)) with ((approx n oo approx (1 + n)) x).
    rewrite <- (approx_approx1 1 n).
    trivial.
    apply unsquash_inj.
    rewrite unsquash_squash, H1.
    apply injective_projections; simpl; auto.
    rewrite fmap_app.
    replace (approx n oo approx (S n)) with (approx n); auto.
    rewrite H5.
    rewrite <- (unsquash_approx H1); auto.
    extensionality x.
    unfold compose.
    change (approx n (approx (S n) x)) with ((approx n oo approx (1 + n)) x).
    rewrite <- (approx_approx1 1 n).
    trivial.
  Qed.

  Theorem asa_knot : @Age_alg knot _ K.ag_knot.
  Proof.
    constructor.
    exact age_join1.
    exact age_join2.
    exact unage_join1.
    exact unage_join2.
  Qed.

End KnotHeredSa.