(*-----------------------------------------------------*)
(* semantics_CDLPattern_V1_0.v   *)
(* Author : Housseim Hachmaoui, Philippe Dhaussy *)
(* ENSTA Bretagne, Lab-STICC / MOCS *)
(* philippe.dhaussy@ensta-bretagne.fr *)
(* May 2015 *)
(*-----------------------------------------------------*)

Require Import List EqNat.
Export ListNotations.

(*###########*)
(*# Horloge #*)
(*###########*)

(* Nous definissons l'horloge comme parametre car celle-ci est geree
par le systeme *)

Parameter clock:nat.

(* Types des operations a effectuer sur l'horloge *)
Inductive opHorloge : Type :=
|NoOp (* Rien *)
|ReInit (* Reinitialisation de l'horloge *)
.
(* Nous attribuons cette notation a la reinitialisation de l'horloge *)
Notation "clock:=-1" := ReInit.

(* Posons ce type pour les conditions relatives a l'horloge *)
Inductive condHorloge : Type :=
|NoCond (* Absence de condition *)
|cond : Prop -> condHorloge.

(* Nous attribuons cette notation a une condition *)
Notation "[| x |]"  := (cond x).

(* Format des contrainte temporelle *)
Definition inCond (x y:nat):= ((clock > y) /\ (clock < x)).
Definition outCond (x y:nat) := ((clock <= y) /\ (clock >= x)).

(*#######*)
(*# LTS #*)
(*#######*)

(*########### Les etats ##############################################*)

(* Nous avons certains etats fixes, d'autres intermediaires *)
Inductive state := Init|Inter|Reject|Success|state_: nat -> state.

(* Cette fonction retourne true si deux etats sont egaux, false sinon *)
Fixpoint beq_state (s1 s2 : state): bool:= match s1 , s2 with
|Init , Init => true
|Inter , Inter => true
|Reject , Reject => true
|Success, Success => true
|state_ id1 , state_ id2 => beq_nat id1 id2
|_,_ => false
end.

(* Notation infixee de la fonction beq_state *)
Infix "s=s" := beq_state (at level 50).

(* Exemples pour tester si la fonction est fonctionne correctement *)
Example test_beq_state_1: Inter s=s Inter = true.
trivial.
Qed.

Example test_beq_state_2: Inter s=s Reject = false.
trivial.
Qed.
Example test_beq_state_3: state_ 1 s=s state_ 2 = false.
trivial.
Qed.
Example test_beq_state_4: state_ 1 s=s state_ 1 = true.
trivial.
Qed.
(*####################################################################*)

(*########### Les evenements #########################################*)

(* Nous avons l'evenement nul, l'evenement de type signal gamma ou un evenement
qu'on identifiera avec un id naturel *)
Inductive event := NoEvent|Gamma|e: nat -> event.

(* Cette fonction retourne true si deux evenements sont egaux, false sinon *)
Fixpoint beq_event (e1 e2 : event): bool:= match e1 , e2 with
|NoEvent,NoEvent => true
|Gamma , Gamma => true
|e id1 , e id2 => beq_nat id1 id2
|_, _ => false
end.

(* Notation infixee de la fonction beq_event *)
Infix "e=e" := beq_event (at level 50).

(* Exemples pour tester si la fonction est fonctionne correctement *)
Example test_beq_event_1: e 1 e=e Gamma = false.
trivial.
Qed.

Example test_beq_event_2: e 2 e=e e 2 = true.
trivial.
Qed.

Example test_beq_event_3: NoEvent e=e NoEvent = true.
trivial.
Qed.

(*####################################################################*)

(*########### Les etiquettes #########################################*)

(* Format general d'un label *)
Inductive label :Type := lab (condition:condHorloge) (ev:event) (op:opHorloge).

(* Attribution de plusieurs notations selon la presence ou l'absence d'un element
du label *)

Notation "( x // y / clock:=-1 )" := (lab x y ReInit) (at level 0). (* Condition, evenement et operation *)
Notation "( x  // y /)"  := (lab x y NoOp) (at level 0). (* Condition et evenement *)
Notation "( x /// clock:=-1)"  := (lab x NoEvent ReInit) (at level 0). (* Condition et operation *)
Notation "(// x / clock:=-1)"  := (lab NoCond x ReInit) (at level 0). (* Evenement et operation *)
Notation "(// x /)"  := (lab NoCond x NoOp) (at level 0). (* Evenement uniquement *)
Notation "( x ///)"  := (lab x NoEvent NoOp) (at level 0). (* Condition uniquement *)
Notation "(/// clock:=-1)"  := (lab NoCond NoEvent ReInit) (at level 0). (* Operation uniquement *)
Notation "(///)" := (lab NoCond NoEvent NoOp) (at level 0). (* Label vide *)
(*Notation "(// Gamma / clock:=-1)"  := (lab NoCond Gamma ReInit) (at level 0). (* Evt Gamma et operation *)*)

(* Quelques tests *)
Compute lab NoCond NoEvent NoOp.
Compute lab [|inCond 2 3|] NoEvent NoOp.
Compute lab NoCond (e 1) NoOp.
Compute lab NoCond NoEvent ReInit.
Compute lab [|2=2|] (e 1) NoOp.
Compute lab NoCond (e 1) ReInit.
Compute lab [|2=2|] NoEvent ReInit.
Compute lab [|2=2|] (e 1) ReInit.
Compute (// e 0 /).

(* Fonctions permettant de recuperer les elements de la structure label *)
Definition getLabCond (l:label):condHorloge := match l with
|lab x y z => x
end.

Definition getLabEvent (l:label):event := match l with
|lab x y z => y
end.

Definition getLabOp (l:label) := match l with
|lab x y z => z
end.

(* Cette fonction retourne true si deux operations sont egales, false sinon *)
Fixpoint beq_op (o1 o2 : opHorloge): bool:= match o1 , o2 with
|NoOp , NoOp => true
|ReInit,ReInit => true
|_, _ => false
end.

(* Notation infixee de la fonction beq_op *)
Infix "op=op" := beq_op (at level 50).

(* Cette fonction retourne true si deux conditions sont egales, false sinon *)
Fixpoint beq_cond (c1 c2 : condHorloge): bool:= match c1 , c2 with
|NoCond , NoCond => true
(*Ajouter d'autres egalites*)
|_, _ => false
end.
(* Traiter cette fonction *)

(* Notation infixee de la fonction beq_cond *)
Infix "c=c" := beq_cond (at level 50).

(* Cette fonction retourne true si deux labels sont egaux, false sinon *)
Definition beq_lab (a b:label):bool := match getLabCond(a) c=c getLabCond(b),
getLabEvent(a) e=e getLabEvent(b), getLabOp(a) op=op getLabOp(b) with
|true,true,true =>true
|_,_,_ => false
end.

(* Notation infixee de la fonction beq_lab *)
Infix "l=l" := beq_lab (at level 50).

(*####################################################################*)

(*########### Les transitions #########################################*)

(* Format general d'une transition *)
Inductive transition:Type := trans (src:state) (e:label) (trg:state).

(* Attribution d'une notation aux transtions *)
Notation "( x , y , z )"  := (trans x y z) .

(* Test des transitions *)
Compute trans Init ([|inCond 0 5|]///) Inter.

Compute trans Init ([| 0 = 5 |] ///) Inter.

Compute ( Init ,(//e 1/), Inter).
Eval compute in  (Init, (//e 1/) , Inter) .
Check trans Init (//e 3/)Inter.

(* Fonctions permettant de recuperer les elements de la structure transition *)
Definition getTransSrc (t:transition):state := match t with
|trans x y z => x
end.

Definition getTransTrg (t:transition):state := match t with
|trans x y z => z
end.

Definition getTransLab (t:transition):label := match t with
|trans x y z => y
end.

(* Cette fonction retourne true si deux transitions sont egales, false sinon *)
Definition beq_trans (t1 t2:transition):bool := match getTransSrc(t1) s=s getTransSrc(t2),
getTransTrg(t1) s=s getTransTrg(t2), getTransLab(t1) l=l getTransLab(t2) with
|true,true,true =>true
|_,_,_ => false
end.

(* Petite preuve sur la bonne définition des gets de transitions *)
Lemma sem_trans: forall (s1 s2: state) (l:label) (t:transition) , t = trans (s1) (l) (s2) -> getTransSrc(t)= s1 /\
getTransLab (t) = l /\ getTransTrg(t)= s2 .
intros.
rewrite H.
split; now repeat constructor.
Qed.

(*=========================================================*)
(*=  Definitions des elements syntaxiques des patrons CDL =*)
(*=========================================================*)

Inductive occurrence : Type :=
|Exactly_one: event -> occurrence
|One_or_more: event -> occurrence
.

Definition getEvtOfOccu (oc:occurrence) : event:=
match oc with
| Exactly_one x => x
| One_or_more x => x
end.

Fixpoint beq_occurrence (e1 e2 : occurrence): bool:= match e1 , e2 with
|Exactly_one x1 , Exactly_one x2 => beq_event x1 x2
|One_or_more x1 , One_or_more x2 => beq_event x1 x2
|_,_ => false
end.

Check Exactly_one (e 1).
Check One_or_more (e 2).
Check [(Exactly_one (e 1));(One_or_more (e 2))].

Inductive occurrence_expression :Type:=
an: list occurrence -> occurrence_expression
|all_ordered:list occurrence -> occurrence_expression
|all_combined:list occurrence -> occurrence_expression
.

Inductive repeatability :Type :=
|trueRep
|falseRep
.

Inductive immediacy :Type :=
|immediately
|eventually
.
Definition immediately_sem (x:list transition) := (Inter,(lab NoCond Gamma ReInit),Reject)::x.
Definition eventually_sem (x:list transition) := x.

(* Définition de la contrainte de temps leads_to et de son sens *)
Definition leads_to (x y :nat):list transition := (trans Inter (lab [|inCond x y|] NoEvent ReInit) Reject)::nil.

(* Défintion des éléments de Precedency et de leur sens *)

Inductive precedency :Type :=
|Cannot_occur
|May_occur.

(*Cannot occur before*)
Fixpoint Cannot_sem (l: list event) (e: event) : list transition := match l with
|nil => nil
|x::l' =>  (Init,(lab NoCond x ReInit),Reject)::(Cannot_sem(l') (e))
end.
(*Notation pour Cannot occur before*)
Infix "Cannot_occur_before" := Cannot_sem (at level 50).
(*Test de Cannot occur before*)
Compute ((e 2)::(e 3)::nil)  Cannot_occur_before (e 1).

(*May occur before*)
Definition May_sem (l:list event) (e:event) : list transition := nil.
(*Notation pour May occur before*)
Infix "May_occur_before" := May_sem (at level 50).
(*-----*)

(* Fonctions permettant de résoudre le problème des transitions en doublon
générées par différentes options *)

Fixpoint atLeastOne {X : Type} (f : X -> bool) (l : list X) : bool :=
  match l with
  | nil => false
  | h::t => if f h then true else atLeastOne f t
  end.

Definition atLeastOneElement {X : Type}
  (eqb : X -> X -> bool) (e : X) (l : list X) : bool :=
     atLeastOne (eqb e) l.

Definition clearDoublons {X : Type}
  (eqb : X -> X -> bool) (l : list X) : list X :=
    let fix intern (input : list X) (output : list X) : list X :=
                    match input with
                    | nil => output
                    | h::t => if (atLeastOneElement eqb h output)
                              then intern t output
                              else intern t (output++(h::nil))
                    end
    in intern l nil.

(*-----*)

(* Absence pattern *)

(* Définition de la contrainte de temps occurs et de son sens *)
Definition occurs_never:list transition := nil.

Fixpoint An_absence (lo:list occurrence) : list transition :=
match lo with
|nil => nil
|(Exactly_one ev)::l' => (Init,(//ev/),Reject)::An_absence(l')
|(One_or_more ev)::l' => (Init,(//ev/),Reject)::(Reject,(//ev/),Reject)::An_absence(l')
end.

Definition All_ordered_absence (num: nat) (l : list occurrence) : list transition :=
  let nextState := fun (s : state) => match s with
                               | Init => state_ num
                               | state_ n => state_ (S n)
                               | _ => s
                               end
  in let endState := Reject
  in let fix intern (s : state) (l : list occurrence) : list transition :=
               match l with
               | [] => []
               | o::[] => match o with
                         |(Exactly_one ev) => [(s, (//getEvtOfOccu o/), endState)]
                         |(One_or_more ev) => [(s, (//getEvtOfOccu o/), endState);(endState, (//getEvtOfOccu o/), endState)]
                         end
               | (Exactly_one ev)::t =>
                   let next := nextState s
                   in (s, (//ev/), next)::(intern next t)
               | (One_or_more ev)::t =>
                   let next := nextState s
                   in (s, (//ev/), next)::(next,(//ev/),next)::(intern next t)
               end
  in intern Init l.

(*===============================All_combined==================================*)

Fixpoint getSubLists {X : Type} (l : list X) : list (list X) :=
  match l with
  |  [] => [nil]
  |  h::t =>
       let rest : list (list X) := getSubLists t
       in (map (app [h]) rest) ++ rest
  end.

Definition stateAndListAbsence (l': list occurrence)  :list (state*(list occurrence)):=
(Init,l')::(let fix intern0 (l: list (list occurrence)):list (state*(list occurrence)):=
match l with
|[] => []
|h::t =>  let endState:=Reject in let nextState := fun (s : state) => match s with
                               | Init => state_ 1
                               | state_ n => state_ (S n)
                               | _ => s
                               end
                        in
                           let fix intern1 (l2: list (list occurrence)) (ss:state) :
                             list (state*(list occurrence)):=
                            match l2 with
                              | nil => nil
                              |[nil] => [(endState,[])]
                              | h2::t2 =>
                                      match t2 with
                                     |nil => [(ss,h2)]
                                     |_ => [(ss,h2)]++(intern1 t2 (nextState ss))
                                     end
                              end
                            in intern1 t (state_ 1)
  end
in intern0 (getSubLists l')).

Fixpoint isIn {X : Type} (eq_X : X -> X -> bool)
  (x : X) (e : list X) : bool :=
    match e with
    | [] => false
    | h::t => if eq_X h x then true else isIn eq_X x t
    end.

Fixpoint minusList {X : Type} (eq_X : X -> X -> bool)
  (e e' : list X) : list X :=
    match e with
    | [] => []
    | h::t => let rest := minusList eq_X t e'
              in if isIn eq_X h e' then rest else h::rest
    end.

Definition absCombTrans (a b : state*(list occurrence)): list transition :=
match a , b with
|(x1,y1) , (x2,y2) => let occu := minusList (beq_occurrence) (y1) (y2)
                      in match occu with
                      |[Exactly_one e1] =>  if beq_nat (length y1) (S(length y2))
                              then [(x1,(//e1/),x2)] else nil
                      |[One_or_more e1] => if beq_nat (length y1) (S(length y2))
                              then [(x1,(//e1/),x2);(x2,(//e1/),x2)] else nil
                      | _ => nil
                         end
end.

Definition All_combined_absence (l:list occurrence):list transition:=
let fix intern (l':list (state*(list occurrence))):list transition :=
match l' with
  |  [] => []
  |  h::t =>
       (let rest := intern t
       in (flat_map (absCombTrans h) t) ++ rest)
  end
in intern (stateAndListAbsence l).

(*==============================================================================*)
Fixpoint property_absence (arity_type:occurrence_expression) (occur:list transition): list transition :=
match arity_type with
|an lo => clearDoublons beq_trans (An_absence(lo)++occur)
|all_ordered lo => clearDoublons beq_trans (All_ordered_absence 1(lo)++occur)
|all_combined lo =>  clearDoublons beq_trans (All_combined_absence (lo)++occur)
end.

(*Existence pattern*)

(* Définition de la contrainte de temps occurs et de son sens *)
Definition occurs (x y :nat):list transition := (trans Inter ([|clock>y|]///clock:=-1) Reject)(*::(Tt Inter (notConst x y) Success)*)::nil.

Fixpoint An_existence (lo:list occurrence) (occurF:nat-> nat-> list transition) (x:nat) (y:nat) : list transition :=
match lo,occurF with
|nil, occurs => nil
|(Exactly_one ev)::l', occurs => ( Inter ,(lab [|clock>= x|] ev ReInit) , Success )::An_existence(l')(occurF)(x)(y)
|(One_or_more ev)::l', occurs => (Inter,(lab [|clock>= x|] ev ReInit),Success)::(Success,(lab [|clock>= x|] ev ReInit),Success)::An_existence(l')(occurF)(x)(y)
end.

Definition All_ordered_existence(num: nat) (l : list occurrence) (occurF:nat-> nat-> list transition) (x:nat) (y:nat) : list transition :=
  let nextState := fun (s : state) => match s with
                               | Inter => state_ num
                               | state_ n => state_ (S n)
                               | _ => s
                               end
  in let endState := Success
  in let fix intern (s : state) (l : list occurrence) : list transition :=
               match l,occurF with
               | [],occurs => []
               | o::[],occurs => match o with
                         |(Exactly_one ev) => [(s, (lab [|clock>=x|] (getEvtOfOccu o) ReInit), endState)]
                         |(One_or_more ev) => [(s, (lab [|clock>=x|] (getEvtOfOccu o) ReInit), endState);(endState,  (lab [|clock>=x|] (getEvtOfOccu o) ReInit), endState)]
                         end
               | (Exactly_one ev)::t,occurs =>
                   let next := nextState s
                   in (s, (//ev/), next)::(next,([|clock>y|]///clock:=-1),Reject)::(intern next t)
               | (One_or_more ev)::t,occurs =>
                   let next := nextState s
                   in (s, (//ev/), next)::(next,([|clock>y|]///clock:=-1),Reject)::(next,(//ev/),next)::(intern next t)
               end
  in intern Inter l.

(*===============================All_combined==================================*)

Definition stateAndListExistence (l': list occurrence)  :list (state*(list occurrence)):=
(Inter,l')::(let fix intern0 (l: list (list occurrence)):list (state*(list occurrence)):=
match l with
|[] => []
|h::t =>  let endState:=Success in let nextState := fun (s : state) => match s with
                               | Inter => state_ 1
                               | state_ n => state_ (S n)
                               | _ => s
                               end
                        in
                           let fix intern1 (l2: list (list occurrence)) (ss:state) :
                             list (state*(list occurrence)):=
                            match l2 with
                              | nil => nil
                              |[nil] => [(endState,[])]
                              | h2::t2 =>
                                      match t2 with
                                     |nil => [(ss,h2)]
                                     |_ => [(ss,h2)]++(intern1 t2 (nextState ss))
                                     end
                              end
                            in intern1 t (state_ 1)
  end
in intern0 (getSubLists l')).

Definition existCombTrans (occurF:nat-> nat-> list transition) (x:nat) (y:nat) (a b : state*(list occurrence)): list transition :=
match a , b with
|(x1,y1) , (Success,y2) => let occu := minusList (beq_occurrence) (y1) (y2)
                      in match occu with
                      |[Exactly_one e1] =>  if beq_nat (length y1) (S(length y2))
                              then [(x1,(lab [|clock>= x|] e1 ReInit),Success)] else nil
                      |[One_or_more e1] => if beq_nat (length y1) (S(length y2))
                              then [(x1,(lab [|clock>= x|] e1 ReInit),Success);(Success,(lab [|clock>= x|] e1 ReInit),Success)] else nil
                      | _ => nil
                         end
|(x1,y1) , (x2,y2) => let occu := minusList (beq_occurrence) (y1) (y2)
                      in match occu with
                      |[Exactly_one e1] =>  if beq_nat (length y1) (S(length y2))
                              then [(x1,(//e1/),x2);(x2,(lab [|clock< y|] NoEvent ReInit),Reject)] else nil
                      |[One_or_more e1] => if beq_nat (length y1) (S(length y2))
                              then [(x1,(//e1/),x2);(x2,(//e1/),x2);(x2,(lab [|clock< y|] NoEvent ReInit),Reject)] else nil
                      | _ => nil
                         end

end.

Definition All_combined_existence (l:list occurrence) (occurF:nat-> nat-> list transition) (x:nat) (y:nat):list transition:=
[(Init, (///clock:=-1),Inter)]++(let fix intern (l':list (state*(list occurrence))):list transition :=
match l' with
  |  [] => []
  |  h::t =>
       (let rest := intern t
       in (flat_map (existCombTrans occurF x y h) t ) ++ rest)
  end
in intern (stateAndListExistence l)).

(*==============================================================================*)

Fixpoint property_existence (arity_type:occurrence_expression) (occur:nat->nat->list transition) (x: nat) (y: nat): list transition :=
match arity_type with
|an lo => clearDoublons beq_trans ([(trans Init (///clock:=-1) Inter)]++(An_existence lo occur x y) ++(occur x y))
|all_ordered lo => clearDoublons beq_trans ([(trans Init (///clock:=-1) Inter)]++(All_ordered_existence 1 lo occur x y)++(occur x y))
|all_combined lo => clearDoublons beq_trans ((All_combined_existence lo occur x y)++(occur x y))
end.

Fixpoint An_pre (lo:list occurrence) : list transition :=
match lo with
|nil => nil
|(Exactly_one ev)::l' => (Init,(//ev/),Inter)::(Inter, (lab NoCond ev  ReInit),Reject)::An_pre(l')
|(One_or_more ev)::l' => (Init,(//ev/),Inter)::(Inter,(//ev/),Inter)::An_pre(l')
end.

Fixpoint An_post (lo:list occurrence) : list transition :=
match lo with
|nil => nil
|x::l' => (Inter,(//getEvtOfOccu(x)/),Init)::An_post(l')
end.

Definition All_ordered_pre (num: nat) (l : list occurrence) : list transition :=
  let nextState := fun (s : state) => match s with
                               | Init => state_ num
                               | state_ n => state_ (S n)
                               | _ => s
                               end
  in let endState := Inter
  in let fix intern (s : state) (l : list occurrence) : list transition :=
               match l with
               | [] => []
               | o::[] => match o with
                         |(Exactly_one ev) => [(s, (//getEvtOfOccu o/), endState)]
                         |(One_or_more ev) => [(s, (//getEvtOfOccu o/), endState);(endState, (//getEvtOfOccu o/), endState)]
                         end
               | (Exactly_one ev)::t =>
                   let next := nextState s
                   in (s, (//ev/), next)::(intern next t)
               | (One_or_more ev)::t =>
                   let next := nextState s
                   in (s, (//ev/), next)::(next,(//ev/),next)::(intern next t)
               end
  in intern Init l.

Definition All_ordered_post  (num: nat) (l : list occurrence) : list transition :=
  let nextState := fun (s : state) => match s with
                               | Inter => state_ num
                               | state_ n => state_ (S n)
                               | _ => s
                               end
  in let endState := Init
  in let fix intern (s : state) (l : list occurrence) : list transition :=
               match l with
               | [] => []
               | o::[] => match o with
                         |(Exactly_one ev) => [(s, (//getEvtOfOccu o/), endState)]
                         |(One_or_more ev) => [(s, (//getEvtOfOccu o/), endState);(endState, (//getEvtOfOccu o/), endState)]
                         end
               | (Exactly_one ev)::t =>
                   let next := nextState s
                   in (s, (//ev/), next)::(intern next t)
               | (One_or_more ev)::t =>
                   let next := nextState s
                   in (s, (//ev/), next)::(next,(//ev/),next)::(intern next t)
               end
  in intern Inter l.

(*===============================All_combined==================================*)

Definition stateAndListPre (l': list occurrence)  :list (state*(list occurrence)):=
(Init,l')::(let fix intern0 (l: list (list occurrence)):list (state*(list occurrence)):=
match l with
|[] => []
|h::t =>  let endState:=Inter in let nextState := fun (s : state) => match s with
                               | Init => state_ 1
                               | state_ n => state_ (S n)
                               | _ => s
                               end
                        in
                           let fix intern1 (l2: list (list occurrence)) (ss:state) :
                             list (state*(list occurrence)):=
                            match l2 with
                              | nil => nil
                              |[nil] => [(endState,[])]
                              | h2::t2 =>
                                      match t2 with
                                     |nil => [(ss,h2)]
                                     |_ => [(ss,h2)]++(intern1 t2 (nextState ss))
                                     end
                              end
                            in intern1 t (state_ 1)
  end
in intern0 (getSubLists l')).

Definition stateAndListPost (num: nat) (l': list occurrence)  :list (state*(list occurrence)):=
(Inter,l')::(let fix intern0 (l: list (list occurrence)):list (state*(list occurrence)):=
match l with
|[] => []
|h::t =>  let endState:=Init in let nextState := fun (s : state) => match s with
                               | Inter => state_ num
                               | state_ n => state_ (S n)
                               | _ => s
                               end
                        in
                           let fix intern1 (l2: list (list occurrence)) (ss:state) :
                             list (state*(list occurrence)):=
                            match l2 with
                              | nil => nil
                              |[nil] => [(endState,[])]
                              | h2::t2 => [(ss,h2)]++(intern1 t2) (nextState ss)
                              end
                            in intern1 t (state_ num)
  end
in intern0 (getSubLists l')).

Definition preCombTrans (a b : state*(list occurrence)): list transition :=
match a , b with
|(x1,y1) , (x2,y2) => let occu := minusList (beq_occurrence) (y1) (y2)
                      in match occu with
                      |[Exactly_one e1] =>  if beq_nat (length y1) (S(length y2))
                              then [(x1,(//e1/),x2)] else nil
                      |[One_or_more e1] => if beq_nat (length y1) (S(length y2))
                              then [(x1,(//e1/),x2);(x2,(//e1/),x2)] else nil
                      | _ => nil
                         end
end.

Definition postCombTrans (a b : state*(list occurrence)): list transition :=
match a , b with
|(x1,y1) , (Init,y2) => let occu := minusList (beq_occurrence) (y1) (y2)
                      in match occu with
                      |[Exactly_one e1] =>  if beq_nat (length y1) (S(length y2))
                              then [(x1,lab ([|clock>=0|]) (e1) (ReInit),Init)] else nil
                      |[One_or_more e1] => if beq_nat (length y1) (S(length y2))
                              then [(x1,lab ([|clock>=0|]) (e1) (ReInit),Init);(Init,lab ([|clock>=0|]) (e1) (ReInit),Init)] else nil
                      | _ => nil
                         end
|(x1,y1) , (x2,y2) => let occu := minusList(beq_occurrence)(y1) (y2)
                      in match occu with
                      |[Exactly_one e1] => if beq_nat (length y1) (S(length y2))
                       then [(x1,(//e1/),x2)] else nil
                      |[One_or_more e1] => if beq_nat (length y1) (S(length y2))
                       then [(x1,(//e1/),x2);(x2,(//e1/),x2)] else nil
                      | _ => nil
                         end
end.

Definition All_combined_pre (l:list occurrence):list transition:=
let fix intern (l':list (state*(list occurrence))):list transition :=
match l' with
  |  [] => []
  |  h::t =>
       (let rest := intern t
       in (flat_map (preCombTrans h) t) ++ rest)
  end
in intern (stateAndListPre l).

Definition All_combined_post  (num: nat) (l:list occurrence):list transition:=
let fix intern (l:list (state*(list occurrence))):list transition :=
 match l with
  |  [] => []
  |  h::t =>
       (let rest := intern t
       in (flat_map (postCombTrans h) t) ++ rest)
  end
in intern (stateAndListPost num l).

(*==============================================================================*)

Fixpoint property_response (pre:occurrence_expression) (Imm:immediacy) (tps:list transition) (post:occurrence_expression) (l_ev: list event) (preced:precedency) (ev: event): list transition :=
match pre, post with
|an lo1 ,an lo2 => (match Imm,preced with
                   |immediately,May_occur =>  clearDoublons beq_trans (An_pre(lo1)++immediately_sem(tps)++An_post(lo2))
                   |eventually,May_occur =>  clearDoublons beq_trans (An_pre(lo1)++eventually_sem(tps)++An_post(lo2))
                   |immediately,Cannot_occur => clearDoublons beq_trans (An_pre(lo1)++immediately_sem(tps)++An_post(lo2)++Cannot_sem (l_ev) (ev))
                   |eventually,Cannot_occur => clearDoublons beq_trans (An_pre(lo1)++eventually_sem(tps)++An_post(lo2)++Cannot_sem (l_ev) (ev))
                   end)
|all_ordered lo1 ,an lo2 => (match Imm,preced with
                   |immediately,May_occur =>  clearDoublons beq_trans ((All_ordered_pre 1 lo1)++immediately_sem(tps)++An_post(lo2))
                   |eventually,May_occur =>  clearDoublons beq_trans ((All_ordered_pre 1 lo1)++eventually_sem(tps)++An_post(lo2))
                   |immediately,Cannot_occur => clearDoublons beq_trans ((All_ordered_pre 1 lo1)++immediately_sem(tps)++An_post(lo2)++Cannot_sem (l_ev) (ev))
                   |eventually,Cannot_occur => clearDoublons beq_trans ((All_ordered_pre 1 lo1)++eventually_sem(tps)++An_post(lo2)++Cannot_sem (l_ev) (ev))
                   end)
|an lo1 ,all_ordered lo2 => (match Imm,preced with
                   |immediately,May_occur =>  clearDoublons beq_trans (An_pre(lo1)++immediately_sem(tps)++(All_ordered_post 1 lo2))
                   |eventually,May_occur =>  clearDoublons beq_trans (An_pre(lo1)++eventually_sem(tps)++(All_ordered_post 1 lo2))
                   |immediately,Cannot_occur => clearDoublons beq_trans (An_pre(lo1)++immediately_sem(tps)++(All_ordered_post 1 lo2)++Cannot_sem (l_ev) (ev))
                   |eventually,Cannot_occur => clearDoublons beq_trans (An_pre(lo1)++eventually_sem(tps)++(All_ordered_post 1 lo2)++Cannot_sem (l_ev) (ev))
                   end)
|all_ordered lo1 ,all_ordered lo2 => (match Imm,preced with
                   |immediately,May_occur =>  clearDoublons beq_trans ((All_ordered_pre 1 lo1)++immediately_sem(tps)++(All_ordered_post (length lo1) lo2))
                   |eventually,May_occur =>  clearDoublons beq_trans ((All_ordered_pre 1 lo1)++eventually_sem(tps)++(All_ordered_post (length lo1) lo2))
                   |immediately,Cannot_occur => clearDoublons beq_trans ((All_ordered_pre 1 lo1)++immediately_sem(tps)++(All_ordered_post (length lo1) lo2)++Cannot_sem (l_ev) (ev))
                   |eventually,Cannot_occur => clearDoublons beq_trans ((All_ordered_pre 1 lo1)++eventually_sem(tps)++(All_ordered_post (length lo1) lo2)++Cannot_sem (l_ev) (ev))
                   end)
|all_combined lo1 ,an lo2=> (match Imm,preced with
                   |immediately,May_occur =>  clearDoublons beq_trans ((All_combined_pre lo1)++immediately_sem(tps)++An_post(lo2))
                   |eventually,May_occur =>  clearDoublons beq_trans ((All_combined_pre lo1)++eventually_sem(tps)++An_post(lo2))
                   |immediately,Cannot_occur => clearDoublons beq_trans ((All_combined_pre lo1)++immediately_sem(tps)++An_post(lo2)++Cannot_sem (l_ev) (ev))
                   |eventually,Cannot_occur => clearDoublons beq_trans ((All_combined_pre lo1)++eventually_sem(tps)++An_post(lo2)++Cannot_sem (l_ev) (ev))
                   end)

|all_combined lo1 ,all_ordered lo2=> (match Imm,preced with
                   |immediately,May_occur =>  clearDoublons beq_trans ((All_combined_pre lo1)++immediately_sem(tps)++(All_ordered_post (S (length lo1)) lo2))
                   |eventually,May_occur =>  clearDoublons beq_trans ((All_combined_pre lo1)++eventually_sem(tps)++(All_ordered_post (S (length lo1)) lo2))
                   |immediately,Cannot_occur => clearDoublons beq_trans ((All_combined_pre lo1)++immediately_sem(tps)++(All_ordered_post (S (length lo1)) lo2)++Cannot_sem (l_ev) (ev))
                   |eventually,Cannot_occur => clearDoublons beq_trans ((All_combined_pre lo1)++eventually_sem(tps)++(All_ordered_post (S (length lo1)) lo2)++Cannot_sem (l_ev) (ev))
                   end)

|an lo1 ,all_combined lo2=> (match Imm,preced with
                   |immediately,May_occur =>  clearDoublons beq_trans (An_pre(lo1)++immediately_sem(tps)++(All_combined_post 1 lo2))
                   |eventually,May_occur =>  clearDoublons beq_trans (An_pre(lo1)++eventually_sem(tps)++(All_combined_post 1 lo2))
                   |immediately,Cannot_occur => clearDoublons beq_trans (An_pre(lo1)++immediately_sem(tps)++(All_combined_post 1 lo2)++Cannot_sem (l_ev) (ev))
                   |eventually,Cannot_occur => clearDoublons beq_trans (An_pre(lo1)++eventually_sem(tps)++(All_combined_post 1 lo2)++Cannot_sem (l_ev) (ev))
                   end)

|all_ordered lo1 ,all_combined lo2=>  (match Imm,preced with
                   |immediately,May_occur =>  clearDoublons beq_trans ((All_ordered_pre 1 lo1)++immediately_sem(tps)++(All_combined_post (length lo1) lo2))
                   |eventually,May_occur =>  clearDoublons beq_trans ((All_ordered_pre 1 lo1)++eventually_sem(tps)++(All_combined_post (length lo1) lo2))
                   |immediately,Cannot_occur => clearDoublons beq_trans ((All_ordered_pre 1 lo1)++immediately_sem(tps)++(All_combined_post (length lo1) lo2)++Cannot_sem (l_ev) (ev))
                   |eventually,Cannot_occur => clearDoublons beq_trans ((All_ordered_pre 1 lo1)++eventually_sem(tps)++(All_combined_post (length lo1) lo2)++Cannot_sem (l_ev) (ev))
                   end)

|all_combined lo1 ,all_combined lo2=>  (match Imm,preced with
                   |immediately,May_occur =>  clearDoublons beq_trans ((All_combined_pre lo1)++immediately_sem(tps)++(All_combined_post (S(length lo1)) lo2))
                   |eventually,May_occur =>  clearDoublons beq_trans ((All_combined_pre lo1)++eventually_sem(tps)++(All_combined_post (S(length lo1)) lo2))
                   |immediately,Cannot_occur => clearDoublons beq_trans ((All_combined_pre lo1)++immediately_sem(tps)++(All_combined_post (S(length lo1)) lo2)++Cannot_sem (l_ev) (ev))
                   |eventually,Cannot_occur => clearDoublons beq_trans ((All_combined_pre lo1)++eventually_sem(tps)++(All_combined_post (S(length lo1)) lo2)++Cannot_sem (l_ev) (ev))
                   end)
end.

(*============*)
(*= Exemples =*)
(*============*)

(*=====Absence=====*)

Compute property_absence
(an
    [Exactly_one (e 1)]
)
occurs_never.

Compute property_absence
(an
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
occurs_never.

Compute property_absence
(an
    [One_or_more (e 1)]
)
occurs_never.

Compute property_absence
(an
    [One_or_more (e 1);
    One_or_more (e 2)]
)
occurs_never.

Compute property_absence
(all_ordered
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
occurs_never.

Compute property_absence
(all_ordered
    [One_or_more (e 1);
     One_or_more (e 2)]
)
occurs_never.

Compute property_absence (
all_combined
   [Exactly_one (e 1);
    Exactly_one (e 2)])
occurs_never.

Compute property_absence (
all_combined
   [One_or_more (e 1);
    One_or_more (e 2)])
occurs_never.

(*=====Existence=====*)

Compute property_existence
(an
    [Exactly_one (e 1)]
)
occurs 1 5.

Compute property_existence
(an
    [Exactly_one (e 1);
     Exactly_one (e 2)]
)
occurs 1 5.

Compute property_existence
(an
    [One_or_more (e 1)]
)
occurs 1 5.

Compute property_existence
(an
    [One_or_more (e 1);
    One_or_more (e 2)]
)
occurs 1 5.

Compute property_existence
(all_ordered
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
occurs 1 5.

Compute property_existence
(all_ordered
    [One_or_more (e 1);
     One_or_more (e 2)]
)
occurs 1 5.

Compute property_existence
(all_combined
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
occurs 1 5.

Compute property_existence
(all_combined
    [One_or_more (e 1);
     One_or_more (e 2)]
)
occurs 1 5.

(*=====Response=====*)

Compute property_response
(an
    [Exactly_one (e 1)]
)
immediately (leads_to 0 5)
(an
    [Exactly_one (e 2)]
)
[e 2] Cannot_occur (e 1) .

Compute property_response
(an
    [One_or_more (e 1)]
)
immediately (leads_to 0 5)
(an
    [One_or_more (e 2)]
)
[e 2] Cannot_occur (e 1) .

Compute property_response
(an
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
immediately (leads_to 0 5)
(an
    [Exactly_one (e 3);
    Exactly_one (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(an
    [One_or_more (e 1);
    One_or_more (e 2)]
)
immediately (leads_to 0 5)
(an
    [One_or_more (e 3);
    One_or_more (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_combined
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
immediately (leads_to 0 5)
(an
    [Exactly_one (e 3);
    Exactly_one (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_combined
    [One_or_more (e 1);
    One_or_more (e 2)]
)
immediately (leads_to 0 5)
(an
    [One_or_more (e 3);
    One_or_more (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_ordered
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
immediately (leads_to 0 5)
(an
    [Exactly_one (e 3);
    Exactly_one (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_ordered
    [One_or_more (e 1);
    One_or_more (e 2)]
)
immediately (leads_to 0 5)
(an
    [One_or_more (e 3);
    One_or_more (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(an
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
immediately (leads_to 0 5)
(all_combined
    [Exactly_one (e 3);
    Exactly_one (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(an
    [One_or_more (e 1);
    One_or_more (e 2)]
)
immediately (leads_to 0 5)
(all_combined
    [One_or_more (e 3);
    One_or_more (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(an
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
immediately (leads_to 0 5)
(all_ordered
    [Exactly_one (e 3);
    Exactly_one (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(an
    [One_or_more (e 1);
    One_or_more (e 2)]
)
immediately (leads_to 0 5)
(all_ordered
    [One_or_more (e 3);
    One_or_more (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_combined
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
immediately (leads_to 0 5)
(all_combined
    [Exactly_one (e 3);
    Exactly_one (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_combined
    [One_or_more (e 1);
    One_or_more (e 2)]
)
immediately (leads_to 0 5)
(all_combined
    [One_or_more (e 3);
    One_or_more (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_ordered
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
immediately (leads_to 0 5)
(all_ordered
    [Exactly_one (e 3);
    Exactly_one (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_ordered
    [One_or_more (e 1);
    One_or_more (e 2)]
)
immediately (leads_to 0 5)
(all_ordered
    [One_or_more (e 3);
    One_or_more (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_combined
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
immediately (leads_to 0 5)
(all_ordered
    [Exactly_one (e 3);
    Exactly_one (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_combined
    [One_or_more (e 1);
    One_or_more (e 2)]
)
immediately (leads_to 0 5)
(all_ordered
    [One_or_more (e 3);
    One_or_more (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_ordered
    [Exactly_one (e 1);
    Exactly_one (e 2)]
)
immediately (leads_to 0 5)
(all_combined
    [Exactly_one (e 3);
    Exactly_one (e 4)]
)
[e 3] Cannot_occur (e 1) .

Compute property_response
(all_ordered
    [One_or_more (e 1);
    One_or_more (e 2)]
)
immediately (leads_to 0 5)
(all_combined
    [One_or_more (e 3);
    One_or_more (e 4)]
)
[e 3] Cannot_occur (e 1) .

(*========================================================================*)

Compute property_response
(an
    [Exactly_one (e 1);
    One_or_more (e 2);
    Exactly_one (e 3);
    One_or_more (e 4)]
)
immediately (leads_to 0 5)
(an
    [Exactly_one (e 5);
    One_or_more (e 6);
    Exactly_one (e 7);
    One_or_more (e 8)]
)
[e 2] Cannot_occur (e 1) .

Compute property_response
(all_ordered
    [Exactly_one (e 1);
    One_or_more (e 2);
    Exactly_one (e 3);
    One_or_more (e 4)]
)
immediately (leads_to 0 5)
(an
    [Exactly_one (e 5);
    One_or_more (e 6);
    Exactly_one (e 7);
    One_or_more (e 8)]
)
[e 2] Cannot_occur (e 1) .

Compute property_response
(an
    [Exactly_one (e 1);
    One_or_more (e 2);
    Exactly_one (e 3);
    One_or_more (e 4)]
)
immediately (leads_to 0 5)
(all_ordered
    [Exactly_one (e 5);
    One_or_more (e 6);
    Exactly_one (e 7);
    One_or_more (e 8)]
)
[e 2] Cannot_occur (e 1) .

Compute property_response
(all_ordered
    [Exactly_one (e 1);
    One_or_more (e 2);
    Exactly_one (e 3);
    One_or_more (e 4)]
)
immediately (leads_to 0 5)
(all_ordered
    [Exactly_one (e 5);
    One_or_more (e 6);
    Exactly_one (e 7);
    One_or_more (e 8)]
)
[e 2] Cannot_occur (e 1) .

Compute property_response
(all_ordered
    [One_or_more (e 1);
     One_or_more (e 2);
     One_or_more (e 3);
     One_or_more (e 4)]
)
immediately (leads_to 0 5)
(all_ordered
    [One_or_more (e 5);
    One_or_more (e 6);
    One_or_more (e 7);
    One_or_more (e 8)]
)
[e 2] Cannot_occur (e 1) .


(** * Contract examples  *)

(** We develop some blockchain infrastructure relevant for the contract execution (a fragment of the standard library and an execution context). With that, we develop a deep embedding of a crowdfunding contract and prove some of its properties using the corresponding shallow embedding *)

Require Import String.
Require Import Polymorphic.Ast Lib.CustomTactics.
Require Import List.
Require Import PeanoNat.
Require Import Coq.ssr.ssrbool.
Import ListNotations.
From Template Require Import All.

Import MonadNotation.
Import BaseTypes.
Import StdLib.
Open Scope list.

(** Our approximation for finite maps. Eventually, will be replaced with the Oak's standard library implementation. We assume that the standard library is available for a contract developer. *)

Section Maps.
  Open Scope nat.

  Inductive addr_map : Set :=
  | mnil | mcons : nat -> nat -> addr_map -> addr_map.

  Inductive Maybe_map :=
  | Just_map : nat -> Maybe_map | Nothing_map.

  Definition Maybe := "Maybe_map".

  Fixpoint lookup_map (m : addr_map) (key : nat) : Maybe_map :=
    match m with
    | mnil => Nothing_map
    | mcons k v m' =>
      if (Nat.eqb key k) then Just_map v else lookup_map m' key
    end.

  (* Ported from FMapWeaklist of StdLib *)
  Function add_map (k : nat) (x : nat) (s : addr_map) : addr_map :=
  match s with
   | mnil => mcons k x mnil
   | mcons k' y l => if Nat.eqb k k' then mcons k x l else mcons k' y (add_map k x l)
  end.

  Definition inmap_map k m := match lookup_map m k with
                              | Just_map _ => true
                              | Nothing => false
                              end.

  Lemma lookup_map_add k v m : lookup_map (add_map k v m) k = Just_map v.
  Proof.
    induction m.
    + simpl. now rewrite PeanoNat.Nat.eqb_refl.
    + simpl. destruct (k =? n) eqn:Heq.
      * simpl. now rewrite PeanoNat.Nat.eqb_refl.
      * simpl. now rewrite Heq.
  Qed.

End Maps.

Notation "a ∈ m" := (inmap_map a m = true) (at level 50).
Notation "a ∉ m" := (inmap_map a m = false) (at level 50).

(** Generation of string constants using MetaCoq *)
Fixpoint mkNames (ns : list string) (postfix : string) :=
  match ns with
  | [] => tmPrint "Done."
  | n :: ns' => n' <- tmEval all (n ++ postfix)%string ;;
                  str <- tmQuote n';;
                  tmMkDefinition n str;;
                  mkNames ns' postfix
  end.

(** Notations for functions on finite maps *)

Definition Map := "addr_map".

Notation "'mfind' a b" :=  [| {eConst "lookup_map"} {a} {b} |]
        (in custom expr at level 0,
            a custom expr at level 1,
            b custom expr at level 1).

Notation "'madd' a b c" :=  [| {eConst "add_map"} {a} {b} {c} |]
        (in custom expr at level 0,
            a custom expr at level 1,
            b custom expr at level 1,
            c custom expr at level 1).

Notation "'mem' a b" :=  [| {eConst "inmap_map"} {a} {b} |]
        (in custom expr at level 0,
            a custom expr at level 1,
            b custom expr at level 1).

(** * Contract execution context  *)

(** The contract execution context is a part of the blockchain infrastructure, not specific to this particular example. We assume that these structures reflect the actual implementation.  *)

Record ctx := mkctx { _ctx_from : nat;
                      _ctx_contract_address : nat ;
                      _amount : nat;
                      _cur_time : nat}.

Definition ctx_from_name := "ExampleContracts._ctx_from".
Definition Ctx := "ExampleContracts.ctx".
Notation "'ctx_from' a" := [| {eConst ctx_from_name} {a} |]
                             (in custom expr at level 0).
Notation "'ctx_contract_address' a" :=
  [| {eConst "ExampleContracts._ctx_contract_address"} {a} |]
    (in custom expr at level 0).
Notation "'amount' a" := [| {eConst "_amount"} {a} |]
                             (in custom expr at level 0).
Notation "'cur_time' a" := [| {eConst "_cur_time"} {a} |]
                             (in custom expr at level 0).

(** ** The crowdfunding contract *)

Module CrowdfundingContract.

  (** Note that we define the deep embedding (abstract syntax trees) of the data structures and programs using notations. These notations are defined in  [Ast.v] and make use of the "custom entries" feature. The idea is that the corresponding ASTs will be produced from the real Oak programs by means of printing the fully annotated abstract syntax trees build from constructors of the inductive type [Ast.expr] *)

   (** Brackets like [[\ \]] delimit the scope of global definitions and like [[| |]] the scope of programs *)

  (** We model types of addresses and currency by [nat] type of Coq *)
  Notation Address := Nat.
  Definition Money := Nat.

  (** Generating names for the data structures  *)
  Run TemplateProgram
      (mkNames ["State" ; "balance" ; "donations" ; "owner"; "deadline"; "goal"; "done";
                "Result" ; "Res" ; "Error";
                "Msg"; "Donate"; "GetFunds"; "Claim";
                "Action"; "Transfer"; "Empty" ] "_coq").

  Import ListNotations.

  (** *** Definitions of data structures for the contract *)

  (** The internal state of the contract *)
  Definition state_syn : global_dec :=
    [\ record State :=
       { balance : Money ;
         donations : Map;
         owner : Money;
         deadline : Nat;
         done : Bool;
         goal : Money } \].

  (** We can print actual AST by switching off the notations *)

  Unset Printing Notations.

  Print state_syn.
  (* state_syn =
      gdInd State O
        (cons
           (rec_constr State
              (cons (pair (nNamed balance) (tyInd Money))
                 (cons (pair (nNamed donations) (tyInd Map))
                    (cons (pair (nNamed owner) (tyInd Money))
                       (cons (pair (nNamed deadline) (tyInd Nat))
                          (cons (pair (nNamed goal) (tyInd Money)) nil)))))) nil) true
           : global_dec *)

  Set Printing Notations.

  (** Unquoting the definition of a record *)
  Make Inductive (trans_global_dec state_syn).

  (** As a result, we get a new Coq record [State_coq] *)
  Print State_coq.

  (** AST of action that our contract can produce *)
  Definition action_syn :=
    [\ data Action :=
         Transfer : Address -> Money -> Action
    | Empty : Action; \].

  Make Inductive (trans_global_dec action_syn).

  (** AST for the type of results *)
  Definition result_syn :=
    [\ data Result :=
         Res : State -> Action -> Result
       | Error : Result; \].

  Make Inductive (trans_global_dec result_syn).

  Definition msg_syn :=
    [\ data Msg :=
       Donate : Msg
       | GetFunds : Msg
       | Claim : Msg; \].

  Make Inductive (trans_global_dec msg_syn).

  (** Custom notations for patterns, projections and constructors *)
  Module Notations.

    (** Patterns *)
    Notation "'Donate'" :=
      (pConstr Donate []) (in custom pat at level 0).
    Notation "'GetFunds'" :=
      (pConstr GetFunds []) ( in custom pat at level 0).

    Notation "'Claim'" :=
      (pConstr Claim []) ( in custom pat at level 0).

    Notation "'Just' x" :=
      (pConstr "Just" [x]) (in custom pat at level 0,
                               x constr at level 4).
    Notation "'Nothing'" := (pConstr "Nothing" [])
                              (in custom pat at level 0).

    (** Projections *)
    Notation "'balance' a" :=
      [| {eConst balance} {a} |]
        (in custom expr at level 0).
    Notation "'donations' a" :=
      [| {eConst donations} {a} |]
        (in custom expr at level 0).
    Notation "'owner' a" :=
      [| {eConst owner} {a} |]
        (in custom expr at level 0).
    Notation "'deadline' a" :=
      [| {eConst deadline} {a} |]
        (in custom expr at level 0).
    Notation "'goal' a" :=
      [| {eConst goal} {a} |]
        (in custom expr at level 0).
    Notation "'done' a" :=
      [| {eConst done} {a} |]
        (in custom expr at level 0).

    (** Constructors *)
    Notation "'Res' a b" :=
      [| {eConstr Result Res} {a} {b} |]
        (in custom expr at level 0,
            a custom expr at level 1,
            b custom expr at level 1).

    Notation "'Error'" := (eConstr Result Error)
                        (in custom expr at level 0).

    Notation "'mkState' a b" :=
      [| {eConstr State "mkState_coq"} {a} {b} |]
        (in custom expr at level 0,
            a custom expr at level 1,
            b custom expr at level 1).

    Notation "'Transfer' a b" :=
      [| {eConstr Action Transfer} {a} {b} |]
        (in custom expr at level 0,
            a custom expr at level 1,
            b custom expr at level 1).

    Notation "'Empty'" := (eConstr Action Empty)
                        (in custom expr at level 0).

    (** New global context with the constants defined above (in addition to the ones defined in the Oak's "StdLib") *)

    Definition Σ' :=
      Σ ++ [gdInd Ctx 0 [("ExampleContracts.mkctx",
                        [(nAnon,tyInd Address); (nAnon,tyInd Address)])] false;
              gdInd Maybe 0 [("Just", [(nAnon,tyInd Nat)]);
                             ("Nothing", [])] false;
            state_syn;
            result_syn;
            msg_syn;
            action_syn].

    End Notations.

  Import Notations.

  (** Generating string constants for variable names *)

  Run TemplateProgram (mkNames ["c";"s";"e";"m";"v";
                                "tx_amount"; "bal"; "sender"; "own"; "isdone" ;
                                "accs"; "now";
                                 "newstate"; "newmap"; "cond"] "").
  (** A shortcut for [if .. then .. else ..]  *)
  Notation "'if' cond 'then' b1 'else' b2 : ty" :=
    (eCase (tyInd Bool,0) (tyInd ty) cond
           [(pConstr true_name [],b1);(pConstr false_name [],b2)])
      (in custom expr at level 2,
          cond custom expr at level 4,
          ty constr at level 4,
          b1 custom expr at level 4,
          b2 custom expr at level 4).

  (** *** The AST of a crowdfunding contract *)
  Definition crowdfunding : expr :=
    [| \c : Ctx => \m : Msg => \s : State =>
         let bal : Money := balance s in
         let now : Nat := cur_time c in
         let tx_amount : Money := amount c in
         let sender : Address := ctx_from c in
         let own : Address := owner s in
         let accs : Map := donations s in
         case m : Msg return Result of
            | GetFunds ->
             if (own == sender) && (deadline s < now) && (goal s <= bal)  then
               Res (mkState 0 accs own (deadline s) True (goal s))
                   (Transfer bal sender)
             else Error : Result
           | Donate -> if now <= deadline s then
             (case (mfind accs sender) : Maybe return Result of
               | Just v ->
                 let newmap : Map := madd sender (v + tx_amount) accs in
                 Res (mkState (tx_amount + bal) newmap own (deadline s) (done s) (goal s)) Empty
               | Nothing ->
                 let newmap : Map := madd sender tx_amount accs in
                 Res (mkState (tx_amount + bal) newmap own (deadline s) (done s) (goal s)) Empty)
               else Error : Result
           | Claim ->
             if (deadline s < now) && (bal < goal s) && (~ done s) then
             (case (mfind accs sender) : Maybe return Result of
              | Just v -> let newmap : Map := madd sender 0 accs in
                  Res (mkState (bal-v) newmap own (deadline s) (done s) (goal s))
                      (Transfer v sender)
               | Nothing -> Error)
              else Error : Result
    |].

  Make Definition entry :=
    Eval compute in (expr_to_term Σ' (indexify nil crowdfunding)).

  Ltac inv_andb H := apply Bool.andb_true_iff in H;destruct H.
  Ltac split_andb := apply Bool.andb_true_iff;split.

  Open Scope nat.
  Open Scope bool.

  Import Lia.

  Definition deadline_passed now (s : State_coq) := s.(deadline_coq) <? now.

  Definition goal_reached (s : State_coq) := s.(goal_coq) <=? s.(balance_coq).

  Definition funded now (s : State_coq) :=
    deadline_passed now s && goal_reached s.

  Lemma not_leb n m : ~~ (n <=? m) -> m <? n.
  Proof.
   intros.
   unfold Nat.ltb in *.
   unfold is_true in *. rewrite Bool.negb_true_iff in *.
   rewrite Nat.leb_gt in *. rewrite Nat.leb_le in *. lia.
  Qed.

  Lemma not_ltb n m : ~~ (n <? m) -> m <=? n.
  Proof.
   intros.
   unfold Nat.ltb in *.
   unfold is_true in *. rewrite Bool.negb_true_iff in *.
   rewrite Nat.leb_gt in *. rewrite Nat.leb_le in *. lia.
  Qed.

  (** ** Properties of the crowdfunding contract *)

  (** This function is a simplistic execution environment that performs one step of execution *)
  Definition run (entry : State_coq -> Result_coq ) (init : State_coq)
    : State_coq * Action_coq :=
    match entry init with
    | Res_coq fin out => (fin, out)
    | Error_coq => (init, Empty_coq) (* if an error occurs, the state remains the same *)
    end.

  (** A wrapper for the assertions about the contract execution *)
  Definition assertion (pre : State_coq -> Prop)
             (entry : State_coq -> Result_coq )
             (post : State_coq -> Action_coq -> Prop) :=
    forall init, pre init -> exists fin out, run entry init = (fin, out) /\ post fin out.

  Notation "{{ P }} c {{ Q }}" := (assertion P c Q)( at level 50).

  (** The donations can be paid back to the backers if the goal is not
reached within a deadline *)

  Lemma get_money_back_guarantee CallCtx (sender := CallCtx.(_ctx_from)) v :
      (* pre-condition *)
      {{ fun init =>
         deadline_passed CallCtx.(_cur_time) init
       /\ ~~ (goal_reached init)
       /\ ~~ init.(done_coq)
       /\ lookup_map init.(donations_coq) sender = Just_map v }}

        (* contract call *)
       entry CallCtx Claim_coq

       (* post-condition *)
       {{fun fin out => lookup_map fin.(donations_coq) sender = Just_map 0
         /\ out = Transfer_coq v sender}}.
  Proof.
    unfold assertion. intros init H. simpl.
    destruct H as [Hdl [Hgoal [Hndone Hlook]]].
    unfold deadline_passed,goal_reached in *;simpl in *.
    repeat eexists. unfold run. simpl.
    assert (balance_coq init <? goal_coq init = true) by now apply not_leb.
    repeat destruct (_ <? _);tryfalse.
    destruct (~~ done_coq _)%bool;tryfalse.
    destruct (lookup_map _ _);tryfalse;inversion Hlook;subst;clear Hlook.
    repeat split;cbn. apply lookup_map_add.
  Qed.

  (** New donations are recorded correctly in the contract's state *)

  Lemma new_donation_correct CallCtx (sender := CallCtx.(_ctx_from))
        (donation := CallCtx.(_amount)) :

    {{ fun init =>
          sender ∉ init.(donations_coq) (* the sender have not donated before *)
       /\ ~~ deadline_passed CallCtx.(_cur_time) init }}

      (* contract call *)
    entry CallCtx Donate_coq

    {{ fun fin out =>
         (* nothing gets transferred *)
         out = Empty_coq
         (* donation has been accepted *)
         /\ lookup_map fin.(donations_coq) sender = Just_map donation  }}.
  Proof.
    unfold assertion. intros init H. simpl.
    destruct H as [Hnew_sender Hdl].
    unfold deadline_passed in *;simpl in *.
    unfold run.
    repeat eexists.
    simpl in *. apply not_ltb in Hdl.
    destruct (_ <=? _);tryfalse.
    unfold inmap_map in *.
    destruct (lookup_map _ _);tryfalse.
    repeat split;eauto. simpl. now rewrite lookup_map_add.
  Qed.

  (** Existing donations are updated correctly in the contract's state *)

  Lemma existing_donation_correct CallCtx (sender := CallCtx.(_ctx_from))
        (new_don := CallCtx.(_amount)) old_don :
    {{ fun init =>
         (* the sender has already donated before *)
         lookup_map init.(donations_coq) sender = Just_map old_don

       /\ ~~ deadline_passed CallCtx.(_cur_time) init }}

     entry CallCtx Donate_coq

    {{ fun fin out =>
         (* nothing gets transferred *)
         out = Empty_coq
         (* donation has been added *)
       /\ lookup_map fin.(donations_coq) sender = Just_map (new_don + old_don) }}.
  Proof.
    unfold assertion. intros init H. simpl.
    destruct H as [Hsender Hdl].
    unfold deadline_passed in *;simpl in *.
    subst;simpl in *.
    eexists. eexists.
    unfold run. simpl in *. apply not_ltb in Hdl.
    destruct (_ <=? _);tryfalse.
    destruct (lookup_map _ _);tryfalse.
    inversion Hsender;subst.
    repeat split;simpl;eauto. now rewrite lookup_map_add.
  Qed.

  Fixpoint sum_map  (m : addr_map) :=
    match m with
    | mnil => 0
    | mcons _ v m' => v + sum_map m'
    end.

  Lemma sum_map_add_in m : forall n0 v' v k,
      lookup_map m k = Just_map n0 ->
      sum_map m = v ->
      sum_map (add_map k (n0+v') m) = v' + v.
  Proof.
    intros;subst.
    revert dependent n0. revert v' k.
    induction m;intros;subst.
    + inversion H.
    + simpl in *. destruct (k =? n) eqn:Hkn.
      * simpl in *. inversion H. subst. lia.
      * simpl in *. rewrite IHm;auto. lia.
  Qed.

  Lemma sum_map_add_not_in m : forall v' v k,
      lookup_map m k = Nothing_map ->
      sum_map m = v ->
      sum_map (add_map k v' m) = v' + v.
  Proof.
    intros;subst.
    revert dependent k. revert v'.
    induction m;intros;subst.
    + reflexivity.
    + simpl in *. destruct (k =? n) eqn:Hkn.
      * inversion H.
      * simpl in *. rewrite IHm;auto. lia.
  Qed.

  (** The contract does no leak funds: the overall balance before the deadline is always equal to the sum of individual donations *)

  Definition consistent_balance ctx state :=
    ~~ deadline_passed ctx.(_cur_time) state /\
    sum_map state.(donations_coq) = state.(balance_coq).

  (** This lemma holds for any message  *)
  Lemma contract_backed CallCtx msg :

    {{ consistent_balance CallCtx }}

      entry CallCtx msg

    {{ fun fin _ => consistent_balance CallCtx fin }}.
  Proof.
    intros init H.
    destruct H as [Hdl Hsum].
    destruct msg.
    + (* Donate *)
      simpl in *.
      specialize Hdl as Hdl'.
      unfold deadline_passed in Hdl. unfold run,consistent_balance.
      apply not_ltb in Hdl.  simpl.
      destruct (_ <=? _);tryfalse.
      destruct (lookup_map _ _) eqn:Hlook.
      * repeat eexists;eauto. now apply sum_map_add_in.
      * repeat eexists;eauto. now apply sum_map_add_not_in.
    + (* GetFunds - it is not possible to get funds before the deadline, so the state is not modified *)
      unfold consistent_balance in *.
      unfold deadline_passed in *.
      exists init. exists Empty_coq. unfold run. simpl.
      destruct (_ <? _);tryfalse. rewrite Bool.andb_false_r. simpl.
      split;eauto.
    + (* Claim - it is not possible to claim a donation back before the deadline, so the state is not modified *)
      unfold consistent_balance in *.
      unfold deadline_passed in *.
      exists init. exists Empty_coq. unfold run. simpl.
      destruct (_ <? _);tryfalse. simpl.
      split;eauto.
  Qed.

  (** The owner gets the money after the deadline, if the goal is reached *)

  Lemma GetFunds_correct CallCtx (OwnerAddr := CallCtx.(_ctx_from)) funds :
    {{ fun init => funded CallCtx.(_cur_time) init
       /\ init.(owner_coq) =? OwnerAddr
       /\ balance_coq init = funds }}

    entry CallCtx GetFunds_coq

    {{ fun fin out =>
       (* the money are sent back *)
       out = Transfer_coq funds OwnerAddr
       (* set balance to 0 after withdrawing by the owner *)
       /\  fin.(balance_coq) = 0
       (* set the "done" flag *)
       /\ fin.(done_coq) = true}}.
  Proof.
    unfold assertion. intros init H. simpl.
    destruct H as [Hfunded [Hown Hbalance]]. unfold funded,goal_reached,deadline_passed in *.
    subst. simpl in *.
    unfold run. simpl in *. subst OwnerAddr. eexists. eexists.
    destruct (_ <? _);tryfalse. destruct ( _ =? _);tryfalse. simpl in *.
    destruct (_ <=? _);tryfalse. split;eauto.
  Qed.

  (** Backers cannot claim their money if the campaign have succeed (but owner haven't claimed the money yet, so the "done" flag is not set to [true]) *)
  Lemma no_claim_if_succeeded CallCtx the_state:
    {{ fun init =>
         funded CallCtx.(_cur_time) init
         /\ ~~ init.(done_coq)
         /\ init = the_state }}

      entry CallCtx Claim_coq

    (* Nothing happens - the stated stays the same and no outgoing transfers *)
    {{ fun fin out => fin = the_state /\ out = Empty_coq }}.
  Proof.
    unfold assertion. intros init H. simpl.
    unfold funded,deadline_passed,goal_reached in *. subst. simpl in *.
    destruct H as [Hdl [Hgoal Hst]].
    inv_andb Hdl. subst. unfold run. simpl.
    exists the_state. eexists.
    destruct the_state as [i_balance i_dons i_own i_dl i_done i_goal].
    destruct CallCtx as [from c_addr am now]. simpl in *.

    destruct (_ <? _);tryfalse. destruct (_ <=? _) eqn:Hleb;tryfalse.
    replace (i_balance <? i_goal) with false by
        (symmetry;rewrite Nat.ltb_ge in *; rewrite Nat.leb_le in *;lia).
    now simpl.
  Qed.

  (** Backers cannot claim their money if the contract is marked as "done" *)
  Lemma no_claim_after_done CallCtx the_state :
    {{ fun init => init.(done_coq) /\ init = the_state }}

     entry CallCtx Claim_coq
    (* Nothing happens - the stated stays the same and no outgoing transfers *)
    {{ fun fin out => fin = the_state /\ out = Empty_coq }}.
  Proof.
    unfold assertion. intros init H. simpl. destruct H. subst.
    unfold funded,deadline_passed,goal_reached in *. subst. simpl in *.
    exists the_state. eexists.
    unfold run. simpl in *. destruct (done_coq _);tryfalse. simpl in *.
    now rewrite Bool.andb_false_r.
  Qed.
End CrowdfundingContract.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V6.3                                  *)
(*                               Dec 24 1996                                *)
(*                                                                          *)
(****************************************************************************)
(*              Firing Squad Synchronization Problem                        *)
(*                                                                          *)
(*              Jean Duprat                                                 *)
(*                                                                          *)
(*              Developped in V5.10  July 1997                              *)
(****************************************************************************)

Require Export basic.

Section reflect.

Section UZ.

Inductive UA (t x cote : nat) : Prop :=
    make_UA : un < cote -> Diag t x cote G_Etat A_Etat G_Etat -> UA t x cote.
Inductive UAB (t x cote : nat) : Prop :=
    make_UAB :
      deux < cote ->
      Diag' t x cote G_Etat G_Etat B_Etat G_Etat ->
      Diag (S t) x cote G_Etat A_Etat G_Etat -> UAB t x cote.
Inductive ZCB (t x cote : nat) : Prop :=
    make_ZCB :
      un < cote ->
      Diag t x cote G_Etat C_Etat G_Etat ->
      Diag (S t) x cote G_Etat B_Etat G_Etat -> ZCB t x cote.

End UZ.

Section construction.

Notation rec3 := (Rec3 _ _ _ _) (only parsing).

Variable t x cote : nat.

Lemma B_UA :
 B_basic t x cote -> G_Etat (S t) (S x + cote) -> UA (S t) (S x) cote.
intros H; elim H; clear H; intros; apply make_UA; auto with arith.
apply
 D'D_D
  with
    (P := L_Etat)
    (Q := B_Etat)
    (R := G_Etat)
    (P' := L_Etat)
    (Q' := B_Etat); auto with arith.
unfold loi, L_Etat, A_Etat, B_Etat, G_Etat; intros; simpl;
 rewrite H3; rewrite H4; rewrite H5; auto with arith.

unfold loi, L_Etat, A_Etat, B_Etat, G_Etat; intros; simpl;
 rewrite H3; rewrite H4; rewrite H5; auto with arith.

unfold loi, L_Etat, A_Etat, B_Etat, G_Etat; intros; simpl;
 rewrite H3; rewrite H4; rewrite H5; auto with arith.
Qed.

Lemma C_UAB :
 deux < cote ->
 C_basic t x cote ->
 G_Etat (S t) (S x + cote) ->
 G_Etat (S (S t)) (S x + cote) -> UAB (S t) (S x) cote.
intros Hlt H; elim H; clear H; intros;
 apply (Rec3 _ _ _ _ (make_UAB (S t) (S x) cote));
 auto with arith.
apply DD_D' with (P := L_Etat) (Q := C_Etat) (P' := L_Etat) (Q' := C_Etat);
 auto with arith.
unfold loi, L_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H4; rewrite H5; rewrite H6; auto with arith.

unfold loi, L_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H4; rewrite H5; rewrite H6; auto with arith.

unfold loi, L_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H4; rewrite H5; rewrite H6; auto with arith.

unfold loi, L_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H4; rewrite H5; rewrite H6; auto with arith.

clear H0; intros H0;
 apply
  D_D'D
   with
     (P := L_Etat)
     (Q := C_Etat)
     (P' := G_Etat)
     (Q' := B_Etat)
     (R' := G_Etat); auto with arith.
unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H4; rewrite H5; rewrite H6;
 auto with arith.

unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H4; rewrite H5; rewrite H6;
 auto with arith.

unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H4; rewrite H5; rewrite H6;
 auto with arith.
Qed.

Lemma A_ZCB :
 A_basic t x cote ->
 G_Etat (S t) (S x + cote) ->
 G_Etat (S (S t)) (S x + cote) -> ZCB (S t) (S x) cote.
intros H; elim H; clear H; intros;
 apply (Rec3 _ _ _ _ (make_ZCB (S t) (S x) cote));
 auto with arith.
apply DD_D with (P := L_Etat) (Q := A_Etat) (P' := L_Etat) (Q' := A_Etat);
 auto with arith.
unfold loi, L_Etat, A_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H4; rewrite H5; rewrite H6; auto with arith.

unfold loi, L_Etat, A_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H4; rewrite H5; rewrite H6; auto with arith.

unfold loi, L_Etat, A_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H4; rewrite H5; rewrite H6; auto with arith.

clear H0; intros H0;
 apply D_DD with (P := L_Etat) (Q := A_Etat) (P' := G_Etat) (Q' := C_Etat);
 auto with arith.
unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H4; rewrite H5; rewrite H6;
 auto with arith.

unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H4; rewrite H5; rewrite H6;
 auto with arith.

unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H4; rewrite H5; rewrite H6;
 auto with arith.
Qed.

Lemma B_ZCB :
 B_basic t x cote ->
 G_Etat (S t) (S x + cote) ->
 G_Etat (S (S t)) (S x + cote) ->
 G_Etat (S (S (S t))) (S x + cote) -> ZCB (S (S t)) (S x) cote.
intros Hb; elim Hb; intros; elim B_UA; auto with arith; clear H0; intros Hlt H0;
 clear Hb Hlt; apply (Rec3 _ _ _ _ (make_ZCB (S (S t)) (S x) cote));
 auto with arith.
apply D_DD with (P := L_Etat) (Q := B_Etat) (P' := G_Etat) (Q' := A_Etat);
 auto with arith.
unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H5; rewrite H6; rewrite H7;
 auto with arith.

unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H5; rewrite H6; rewrite H7;
 auto with arith.

unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H5; rewrite H6; rewrite H7;
 auto with arith.

clear H1; intros H1;
 apply DDD with (P := G_Etat) (Q := A_Etat) (P' := G_Etat) (Q' := C_Etat);
 auto with arith.
unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H5; rewrite H6; rewrite H7;
 auto with arith.

unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H5; rewrite H6; rewrite H7;
 auto with arith.

unfold loi_droite, B_Etat, G_Etat; intros t0 x0; case x0; intros;
 simpl; rewrite H5; rewrite H6; auto with arith.

unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H5; rewrite H6; rewrite H7;
 auto with arith.

unfold loi, L_Etat, A_Etat, B_Etat, C_Etat, G_Etat; intros;
 simpl; rewrite H5; rewrite H6; rewrite H7;
 auto with arith.
Qed.

Lemma C_ZCB :
 deux < cote ->
 C_basic t x cote ->
 G_Etat (S t) (S x + cote) ->
 G_Etat (S (S t)) (S x + cote) ->
 G_Etat (S (S (S t))) (S x + cote) ->
 G_Etat (S (S (S (S t)))) (S x + cote) -> ZCB (S (S (S t))) (S x) cote.
intros; elim C_UAB; auto with arith; clear H H0 H1; intros;
 apply (Rec3 _ _ _ _ (make_ZCB (S (S (S t))) (S x) cote));
 auto with arith.
apply
 D'DD
  with
    (P := G_Etat)
    (Q := B_Etat)
    (R := G_Etat)
    (P' := G_Etat)
    (Q' := A_Etat); auto with arith.
unfold loi, A_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H5; rewrite H6; rewrite H7; auto with arith.

unfold loi, A_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H5; rewrite H6; rewrite H7; auto with arith.

unfold loi_droite, C_Etat, G_Etat; intros t0 x0; case x0; intros;
 simpl; rewrite H5; rewrite H6; auto with arith.

unfold loi, A_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H5; rewrite H6; rewrite H7; auto with arith.

unfold loi, A_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H5; rewrite H6; rewrite H7; auto with arith.

clear H0; intros H0;
 apply DDD with (P := G_Etat) (Q := A_Etat) (P' := G_Etat) (Q' := C_Etat);
 auto with arith.
unfold loi, A_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H5; rewrite H6; rewrite H7; auto with arith.

unfold loi, A_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H5; rewrite H6; rewrite H7; auto with arith.

unfold loi_droite, B_Etat, G_Etat; intros t0 x0; case x0; intros;
 simpl; rewrite H5; rewrite H6; auto with arith.

unfold loi, A_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H5; rewrite H6; rewrite H7; auto with arith.

unfold loi, A_Etat, B_Etat, C_Etat, G_Etat; intros; simpl;
 rewrite H5; rewrite H6; rewrite H7; auto with arith.
Qed.

End construction.

Section triangle_sup.

Variable t x cote : nat.

Lemma ZCB_GLC :
 deux < cote ->
 ZCB t x cote ->
 Verticale (S (S t)) (x + cote) cote G_Etat ->
 Diag (S t + un) (x + un) (cote - un) G_Etat L_Etat C_Etat.
intros Hlt Hz Hv; elim Hz; clear Hz; elim Hv; clear Hv; intros.
do 2 rewrite plus_un;
 apply
  DDdollar_D with (P := G_Etat) (Q := C_Etat) (P' := G_Etat) (Q' := B_Etat);
 auto with arith.
unfold loi, B_Etat, C_Etat, G_Etat, L_Etat; intros; simpl;
 rewrite H3; rewrite H4; rewrite H5; auto with arith.

unfold loi, B_Etat, C_Etat, G_Etat, L_Etat; intros; simpl;
 rewrite H3; rewrite H4; rewrite H5; auto with arith.

unfold loi, B_Etat, C_Etat, G_Etat, L_Etat; intros; simpl;
 rewrite H3; rewrite H4; rewrite H5; auto with arith.

apply lt_S_n; rewrite Sminus_un; auto with arith.

rewrite Sminus_un; auto with arith.

rewrite Sminus_un; auto with arith.

rewrite <- (plus_zero (S (S t))); rewrite (plus_n_Sm x); rewrite Sminus_un;
 auto with arith.
Qed.

Lemma ZCB_l :
 deux < cote ->
 ZCB t x cote ->
 Verticale (S (S t)) (x + cote) cote G_Etat ->
 Semi_Diag (S t + deux) (x + deux) (cote - deux) G_Etat L_Etat.
intros Hlt Hz Hv; elim Hz; elim Hv; intros.
do 2 rewrite plus_deux;
 apply
  DD_d
   with
     (P := G_Etat)
     (Q := B_Etat)
     (R := G_Etat)
     (P' := G_Etat)
     (Q' := L_Etat)
     (R' := C_Etat).
unfold loi, B_Etat, G_Etat, L_Etat; intros; simpl; rewrite H3;
 rewrite H4; rewrite H5; auto with arith.

unfold loi, B_Etat, G_Etat, L_Etat; intros; simpl; rewrite H3;
 rewrite H4; rewrite H5; auto with arith.

do 2 apply lt_S_n; rewrite SSminus_deux; auto with arith.

rewrite SSminus_deux; auto with arith.

rewrite <- (plus_un (S t)); rewrite <- (plus_un x); unfold deux;
 rewrite Sminus_aSb; auto with arith.
apply ZCB_GLC; auto with arith.

rewrite <- (plus_un (S (S t))); do 2 rewrite plus_n_Sm; rewrite SSminus_deux;
 auto with arith.
Qed.

Lemma ZCB_ll :
 trois < cote ->
 ZCB t x cote ->
 Verticale (S (S t)) (x + cote) cote G_Etat ->
 Semi_Diag (S t + trois) (x + trois) (cote - trois) G_Etat L_Etat.
intros Hlt Hz Hv; elim Hv; intros.
do 2 rewrite plus_trois;
 apply
  Dd_d
   with
     (P := G_Etat)
     (Q := L_Etat)
     (R := C_Etat)
     (P' := G_Etat)
     (Q' := L_Etat).
unfold loi, G_Etat, L_Etat; intros; simpl; rewrite H0;
 rewrite H1; rewrite H2; auto with arith.

unfold loi, G_Etat, L_Etat; intros; simpl; rewrite H0;
 rewrite H1; rewrite H2; auto with arith.

do 3 apply lt_S_n; rewrite SSSminus_trois; auto with arith.

rewrite <- (plus_un (S t)); rewrite <- (plus_un x); unfold trois;
 do 2 (rewrite Sminus_aSb; auto with arith).
apply ZCB_GLC; auto with arith.

apply lt_trans with (m := trois); auto with arith.

rewrite <- (plus_deux (S t)); rewrite <- (plus_deux x); unfold trois;
 rewrite Sminus_aSb; auto with arith.
apply ZCB_l; auto with arith.

do 2 rewrite plus_n_Sm; rewrite plus_Snm_nSm;
 rewrite <- (plus_deux (S (S t))); rewrite SSSminus_trois;
 auto with arith.
apply H; auto with arith.
apply le_trans with (m := trois); auto with arith.
Qed.

Lemma ZCB_lll :
 forall dcote : nat,
 deux <= dcote ->
 dcote < cote ->
 ZCB t x cote ->
 Verticale (S (S t)) (x + cote) cote G_Etat ->
 Semi_Diag (S t + dcote) (x + dcote) (cote - dcote) G_Etat L_Etat.
intros; elim H2; intros.
generalize H0;
 apply
  recur_nSn
   with
     (P := fun dcote : nat =>
           dcote < cote ->
           Semi_Diag (S t + dcote) (x + dcote) (cote - dcote) G_Etat L_Etat)
     (n := deux).
intros; apply ZCB_l; auto with arith.

intros; apply ZCB_ll; auto with arith.

intros; repeat rewrite <- plus_n_Sm;
 apply dd_d with (P := G_Etat) (Q := L_Etat) (P' := G_Etat) (Q' := L_Etat).
unfold loi, G_Etat, L_Etat; intros; simpl; rewrite H7;
 rewrite H8; rewrite H9; auto with arith.

unfold loi, G_Etat, L_Etat; intros; simpl; rewrite H7;
 rewrite H8; rewrite H9; auto with arith.

apply lt_O_minus; auto with arith.

do 2 (rewrite Sminus_aSb; auto with arith).
apply H4; apply lt_trans with (m := S (S p)); auto with arith.

apply lt_trans with (m := S (S p)); auto with arith.

do 2 rewrite plus_n_Sm; rewrite Sminus_aSb; auto with arith.

rewrite plus_n_Sm; do 3 rewrite <- plus_S; do 2 rewrite plus_n_Sm;
 rewrite plus_assoc_reverse; rewrite le_plus_minus_r;
 auto with arith.
apply H3; apply le_trans with (m := S (S p)); auto with arith.

auto with arith.
Qed.

Lemma ZCB_Ht1 :
 deux < cote ->
 ZCB t x cote ->
 Verticale (S (S t)) (x + cote) cote G_Etat ->
 Horizontale_t1 (t + S cote) x (cote - trois) G_Etat C_Etat L_Etat.
intros; apply make_horizontale_t1.
rewrite <- plus_Snm_nSm; elim H0; intros; elim H4; auto with arith.

elim ZCB_GLC; auto with arith; intros H2 H3 H4; clear H2 H3 H4.
rewrite plus_assoc_reverse; rewrite (plus_un x); rewrite plus_Snm_nSm;
 rewrite <- le_plus_minus; auto with arith.
apply le_trans with (m := deux); auto with arith.

apply make_horizontale; intros; elim ZCB_lll with (dcote := S (S dx));
 auto with arith; intros.
generalize (H5 (cote - S (S dx)) 0); clear H4 H5; repeat rewrite plus_zero.
rewrite plus_assoc_reverse; rewrite le_plus_minus_r;
 repeat rewrite plus_Snm_nSm; auto with arith.
rewrite <- (SSSminus_trois cote); auto with arith.

unfold deux; auto with arith.

rewrite <- (SSSminus_trois cote); auto with arith.
Qed.

End triangle_sup.

Section Z_verticale.

Variable t x cote : nat.

Lemma A_Vg :
 A_basic t x cote ->
 G_Etat (S t) (S x + cote) ->
 G_Etat (S (S t)) (S x + cote) -> Verticale (S t + cote) (S x) un G_Etat.
intros; elim (A_ZCB t x cote); auto with arith.
intros; apply vert_un.
elim H3; auto with arith.

elim H4; auto with arith.
Qed.

Lemma B_Vg :
 B_basic t x cote ->
 G_Etat (S t) (S x + cote) ->
 G_Etat (S (S t)) (S x + cote) ->
 G_Etat (S (S (S t))) (S x + cote) ->
 Verticale (S t + cote) (S x) deux G_Etat.
intros; elim (B_ZCB t x cote); auto with arith.
intros; elim (B_UA t x cote); auto with arith.
intros; apply vert_deux.
elim H7; auto with arith.

elim H4; auto with arith.

elim H5; auto with arith.
Qed.

Lemma C_Vg :
 deux < cote ->
 C_basic t x cote ->
 G_Etat (S t) (S x + cote) ->
 G_Etat (S (S t)) (S x + cote) ->
 G_Etat (S (S (S t))) (S x + cote) ->
 G_Etat (S (S (S (S t)))) (S x + cote) ->
 Verticale (S t + cote) (S x) trois G_Etat.
intros; elim (C_ZCB t x cote); auto with arith.
intros; elim (C_UAB t x cote); auto with arith.
intros; apply vert_trois.
elim H9; auto with arith.

elim H10; auto with arith.

elim H6; auto with arith.

elim H7; auto with arith.
Qed.

End Z_verticale.

End reflect.


Require Import ssreflect ssrnat ssrbool seq eqtype Ring Group ident3.
Import Ring.ideal.

Section Aux1. Import ZC_tactic.

Context (i j k l m n : nat) (a1 a2 b c d : R)
        {ij : i != j} {ji : j != i}
        {ik : i != k} {jk : j != k} {ki : k != i} {kj : k != j}
        {kl : k != l} {il : i != l} {jl : j != l} {lk : l != k} {li : l != i} {lj : l != j}.

Lemma ZC1_I_01:
Z' ij a1 b ^^ X ij c .* X' il d =
  X' il ((1 + (c * b + 1) * a1 * b) * d) .*
  X' jl (- (b * a1 * b * d)) .*
  Z' ij a1 b ^^ X ij c.
Proof.
remember (Z' ij a1 b ^^ X ij c) as RHS.
rewrite {1}HeqRHS.
rewrite (ZC1 _ _ k) //. ZCR. rewrite -?GA.
rewrite (Z3_swap' k i l) //.
rewrite (Z3_swap' j i l) //; simplify0.
rewrite (X5_swap' j i k l) //. rexpand. rsimpl.
rewrite (X5_swap' j k i l) //.
rewrite (X4'_swap' j k l) //.
rewrite (Z3_swap' j k l) //; simplify0.
rewrite (X4_swap' k l j) // -X0'.
rewrite -(Z5' k j i l) // X'def.
rewrite (Z3_swap' k j l) //; simplify0.

rexpand. rsimpl. rewrite -?plus_assoc.

remember (b * a1 * b) as A0.
remember (A0 * c * b * a1 * b) as A1.
remember (A0 * a1 * b) as A2.
remember (A1 * c * b * a1 * b * d) as A3.
remember (A1 * a1 * b * d) as A4.
remember (A2 * c * b * a1 * b * d) as A5.
remember (A2 * a1 * b * d) as A6.

cancm (A1 * d). cancm (A2 * d). cancm A3. cancm A4. cancm A5.

remember (a1 * b) as B0.
remember (B0 * c * b * a1 * b) as B1.
remember (B0 * a1 * b) as B2.
remember (B1 * c * b * a1 * b * d) as B3.
remember (B2 * c * b * a1 * b * d) as B4.
remember (B1 * a1 * b * d) as B5.
remember (B2 * a1 * b * d) as B6.

cancm B3. cancm B4. cancm B5.

rewrite (Z4'_swap' k j l) // -X0'. simplify0.
rewrite (X4_swap' k l j) // -X0'.
rewrite (X4'_swap' i j l) //.
rewrite (Z3_swap' i j l) //; simplify0.
rewrite (X4_swap' j l i) // -X0'.
rewrite (X5_swap' i j k l) //.
rewrite (X4'_swap' i k l) //.
rewrite (X5_swap' i k j l) //.
rewrite (Z3_swap' i k l) //; simplify0.
rewrite (X4_swap' k l i) //.
rewrite (X4_swap' j l i) // -X0'.
rewrite (X5_swap' k j i l) //.
rewrite (Z3_swap' k j l) //; simplify0.
rewrite (X4'_swap' k j l) // -X0'.
rewrite (Z3_swap _ _ _ k i l) //; simplify0.
rewrite (X5_swap' k i j l) //.
rewrite (X4'_swap' k i l) //.
rewrite (X4_swap' j l k) // -X0'.

subst. simplify0. rexpand. rsimpl. rewrite -?plus_assoc -?mul_assoc.

remember (c * b * a1 * b) as C0.
remember (a1 * b * a1 * b) as C1.
remember (a1 * b * c * b * a1 * b) as C2.
remember (C2 * a1 * b) as C3.
remember (C2 * c * b * a1 * b) as C4.
remember (C1 * a1 * b) as C5.
remember (C1 * c * b * a1 * b) as C6.
remember (C3 * a1 * b) as C7.
remember (C3 * c * b * a1 * b) as C8.
remember (C6 * a1 * b) as C9.
remember (C6 * c * b * a1 * b) as C10.
remember (C4 * a1 * b) as C11.
remember (C4 * c * b * a1 * b) as C12.
remember (C5 * a1 * b) as C13.
remember (C5 * c * b * a1 * b) as C14.

cancm (C1 * d). cancm (C2 * d). cancm (C3 * d). cancm (C4 * d).
cancm (C5 * d). cancm (C6 * d). cancm (C7 * d). cancm (C8 * d).
cancm (C9 * d). cancm (C10 * d). cancm (C11 * d). cancm (C12 * d).
cancm (C13 * d). rewrite inv_r X'zero GId. subst.

remember (c * b * a1 * b) as D1.
remember (D1 * c * b) as D2.
remember (D1 * a1 * b) as D3.
remember (D2 * a1 * b) as D4.
remember (D3 * a1 * b) as D5.
remember (D3 * c * b) as D6.
remember (D4 * a1 * b) as D7.
remember (D4 * c * b) as D8.
remember (D6 * a1 * b) as D9.
remember (D8 * a1 * b) as D10.

cancm (D4 * d). cancm (D3 * d). cancm (D10 * d). cancm (D9 * d).
cancm (D5 * d). subst.

remember (b * a1 * b) as E1.
remember (E1 * c * b) as E2.
remember (E1 * a1 * b) as E3.
remember (E2 * a1 * b) as E4.

cancm (E4 * d). subst.

rewrite (ZC1 _ _ k) //. ZCR.
rewrite -?GA. rexpand. rsimpl. by rewrite -?plus_assoc. Qed.

End Aux1.


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

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Theory.Core Compilers.Compilers Elab.Elab Elab.ElabCompilers Tools.Matches.
From Pyrosome.Lang Require Import SimpleVSubst SimpleVCPS SimpleUnit.
Import Core.Notations.
(*TODO: repackage this in compilers*)
Import CompilerDefs.Notations.

Require Coq.derive.Derive.

Notation compiler := (compiler string).

Definition prod_cc_def : lang :=
  {[l/subst
  [:| "G" : #"env", "A" : #"ty", "B" : #"ty",
      "v" : #"val" "G" (#"prod" "A" "B")
       -----------------------------------------------
       #".1" "v" : #"val" "G" "A"
  ];
  [:| "G" : #"env", "A" : #"ty", "B" : #"ty",
      "v" : #"val" "G" (#"prod" "A" "B")
       -----------------------------------------------
       #".2" "v" : #"val" "G" "B"
  ];
   [:= "G" : #"env", "A" : #"ty",
      "g" : #"val" "G" "A",
      "B" : #"ty",
      "v" : #"val" "G" "B"
      ----------------------------------------------- ("proj 1")
      #".1" (#"pair" "g" "v") = "g" : #"val" "G" "A"
  ];
  [:= "G" : #"env", "A" : #"ty",
      "g" : #"val" "G" "A",
      "B" : #"ty",
      "v" : #"val" "G" "B"
      ----------------------------------------------- ("proj 2")
      #".2" (#"pair" "g" "v") = "v" : #"val" "G" "B"
  ];
  [:= "G" : #"env", "A" : #"ty",
      "B" : #"ty",
      "v" : #"val" "G" (#"prod" "A" "B")
      ----------------------------------------------- ("negative pair eta")
      #"pair" (#".1" "v") (#".2" "v") = "v" : #"val" "G" (#"prod" "A" "B")
  ]]}.

Derive prod_cc
       SuchThat (elab_lang_ext (cps_prod_lang ++ block_subst ++value_subst) prod_cc_def prod_cc)
       As prod_cc_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve prod_cc_wf : elab_pfs.

Definition cc_lang_def : lang :=
  {[l/subst
      [:| "A" : #"ty"
          -----------------------------------------------
          #"neg" "A" : #"ty"
      ];
  [:| "G" : #"env",
      "A" : #"ty",
      "B" : #"ty",
      "e" : #"blk" (#"ext" #"emp" (#"prod" "A" "B")),
      "v" : #"val" "G" "A"
      -----------------------------------------------
      #"closure" "B" "e" "v" : #"val" "G" (#"neg" "B")
   ];
   [:| "G" : #"env",
       "A" : #"ty",
       "v1" : #"val" "G" (#"neg" "A"),
       "v2" : #"val" "G" "A"
      -----------------------------------------------
      #"jmp" "v1" "v2" : #"blk" "G"
   ];
  [:= "G" : #"env",
      "A" : #"ty",
      "B" : #"ty",
      "e" : #"blk" (#"ext" #"emp" (#"prod" "A" "B")),
      "v" : #"val" "G" "A",
      "v'" : #"val" "G" "B"
      ----------------------------------------------- ("jmp_beta")
      #"jmp" (#"closure" "B" "e" "v") "v'"
      = #"blk_subst" (#"snoc" #"forget" (#"pair" "v" "v'")) "e"
      : #"blk" "G"
  ];
  [:= "A" : #"ty",
      "B" : #"ty",
      "v" : #"val" (#"ext" #"emp" "A") (#"neg" "B")
      ----------------------------------------------- ("clo_eta")
      #"closure" "B"
        (#"jmp" (#"val_subst" (#"snoc" #"wkn" (#".1" #"hd")) "v") (#".2" #"hd"))
        #"hd"
      = "v"
      : #"val" (#"ext" #"emp" "A") (#"neg" "B")
  ]]}.

Derive cc_lang
       SuchThat (elab_lang_ext (prod_cc ++ cps_prod_lang ++ block_subst ++value_subst)
                               cc_lang_def
                               cc_lang)
       As cc_lang_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve cc_lang_wf : elab_pfs.

Definition subst_cc_def : compiler :=
  match # from (block_subst ++ value_subst) with
  | {{s #"env" }} => {{s #"ty"}}
  | {{s #"val" "G" "B"}} => {{s #"val" (#"ext" #"emp" "G") "B"}}
  | {{s #"blk" "G"}} => {{s #"blk" (#"ext" #"emp" "G")}}
  | {{s #"sub" "G" "G'"}} => {{s #"val" (#"ext" #"emp" "G") "G'"}}
  | {{e #"cmp" "G" "G'" "A" "g" "g'"}} =>
    {{e #"val_subst" (#"snoc" #"wkn" "g") "g'"}}
  | {{e #"emp"}} => {{e#"unit"}}
  | {{e #"forget"}} => {{e# "tt"}}
  | {{e #"ext" "A" "B" }} => {{e #"prod" "A" "B"}}
  | {{e #"snoc" "G" "G'""g" "A" "v"}} =>
    {{e #"pair" "g" "v"}}
  | {{e #"id" "G"}} => {{e #"hd"}}
  | {{e #"hd" "G" "A"}} => {{e #".2" #"hd"}}
  | {{e #"wkn" "G" "A"}} => {{e #".1" #"hd"}}
  | {{e #"val_subst" "G" "G'" "g" "A" "v"}} =>
    {{e #"val_subst" (#"snoc" #"wkn" "g") "v"}}
  | {{e #"blk_subst" "G" "G'" "g" "e"}} =>
    {{e #"blk_subst" (#"snoc" #"wkn" "g") "e"}}
  end.

Derive subst_cc
       SuchThat (elab_preserving_compiler []
                                          (unit_eta
                                             ++ unit_lang
                                             ++ prod_cc
                                             ++ cps_prod_lang
                                             ++ block_subst
                                             ++value_subst)
                                          subst_cc_def
                                          subst_cc
                                          (block_subst++value_subst))
       As subst_cc_preserving.
Proof.
  auto_elab_compiler.
  cleanup_elab_after
    (reduce; eredex_steps_with unit_eta "unit eta").
Qed.
#[export] Hint Resolve subst_cc_preserving : elab_pfs.

(*TODO: redo for positive products *)
Definition prod_cc_compile_def : compiler :=
  match # from cps_prod_lang with
  | {{e #"pm_pair" "G" "A" "B" "v" "e"}} =>
    {{e #"blk_subst"
        (#"snoc" #"wkn" (#"pair" (#"pair" {ovar 0} (#".1" "v")) (#".2" "v")))
        "e"}}
  end.

(*TODO: move to value_subst? could conflict w/ cmp_forget
  not currently used
*)
(*TODO: generalize? reverse for tactics?*)
Definition forget_eq_wkn_def : lang :=
  {[l
      [:= "A" : #"ty"
         ----------------------------------------------- ("wkn_emp_forget")
         #"forget" = #"wkn"
         : #"sub" (#"ext" #"emp" "A") #"emp"
      ]
  ]}.
Derive forget_eq_wkn
       SuchThat (elab_lang_ext value_subst
                               forget_eq_wkn_def
                               forget_eq_wkn)
       As forget_eq_wkn_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve forget_eq_wkn_wf : elab_pfs.

Derive prod_cc_compile
       SuchThat (elab_preserving_compiler subst_cc
                                          ( unit_eta
                                             ++ unit_lang
                                             ++ prod_cc
                                             ++ cps_prod_lang
                                             ++ block_subst
                                             ++value_subst)
                                          prod_cc_compile_def
                                          prod_cc_compile
                                          cps_prod_lang)
       As prod_cc_preserving.
Proof. auto_elab_compiler. Qed.
#[export] Hint Resolve prod_cc_preserving : elab_pfs.

Definition cc_def : compiler :=
  match # from (cps_lang) with
  | {{e #"neg" "A" }} => {{e #"neg" "A"}}
  | {{e #"cont" "G" "A" "e"}} =>
    {{e #"closure" "A" "e" #"hd"}}
  | {{e #"jmp" "G" "A" "v1" "v2"}} =>
    {{e #"jmp" "v1" "v2" }}
  end.

Derive cc
       SuchThat (elab_preserving_compiler (prod_cc_compile++subst_cc)
                                          (cc_lang
                                             ++ forget_eq_wkn
                                             ++ unit_eta
                                             ++ unit_lang
                                             ++ prod_cc
                                             ++ cps_prod_lang
                                             ++ block_subst
                                             ++value_subst)
                                          cc_def
                                          cc
                                          cps_lang)
       As cc_preserving.
Proof.
  auto_elab_compiler.
  cleanup_elab_after
  (reduce;
   eapply eq_term_trans;
   [eapply eq_term_sym;
   eredex_steps_with cc_lang "clo_eta"|];
   by_reduction).
Qed.
#[export] Hint Resolve cc_preserving : elab_pfs.