Require Import Coq.Init.Nat.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.FSets.FMapInterface.
Require Import Coq.FSets.FMapFacts.
Require Import Coq.FSets.FMapWeakList.
Require Import Coq.FSets.FSetWeakList.
Require Import TraceModel.
Require Import LanguageModel.
Require Import ChainModel.
Require Import RobustTraceCriterion.

Set Bullet Behavior "Strict Subproofs".

(* Simple binary location: program or context. *)
Inductive turn : Set :=
| ProgramTurn
| ContextTurn.

(* Name-function maps, with some parts stubbed. *)
Module DecidableString : DecidableType.
  Definition t := string.

  Definition eq : string -> string -> Prop := eq.

  Theorem eq_refl : forall x, eq x x.
  Proof.
    easy.
  Qed.

  Theorem eq_sym : forall x y, eq x y -> eq y x.
  Proof.
    easy.
  Qed.

  Theorem eq_trans : forall x y z, eq x y -> eq y z -> eq x z.
  Proof.
    intros x y z Hxy Hyz. inversion Hxy. inversion Hyz. easy.
  Qed.

  Definition eq_dec : forall x y, {eq x y} + {~ eq x y} := string_dec.
End DecidableString.

Module StringMap : WS with Module E := DecidableString :=
  FMapWeakList.Make DecidableString.

Module StringMapFacts := WFacts_fun DecidableString StringMap.

(* And function name sets, for interfacing purposes. *)
Module StringSet := FSetWeakList.Make DecidableString.
Notation "∅" := StringSet.empty (at level 70, no associativity).
Notation "s1 ∪ s2" := (StringSet.union s1 s2) (at level 70, right associativity).

Definition elements_set (A : Type) (m : StringMap.t A) : StringSet.t :=
  let keys := map fst (StringMap.elements m) in
  fold_left (fun acc key => StringSet.add key acc) keys StringSet.empty.

(* A helper. *)
Remark forall_app : forall A f (l1 l2 : list A),
  Forall f l1 -> Forall f l2 -> Forall f (l1 ++ l2).
Proof.
  induction l1; intros l2 H1 H2.
  - now eauto.
  - simpl. inversion H1. now eauto.
Qed.

(* Source language. *)
Module Source.
  (* Base expressions. *)
  Inductive expr : Type :=
  | Const : nat -> expr
  | Plus  : expr -> expr -> expr
  | IfLe  : expr -> expr -> expr -> expr -> expr
  | Seq   : expr -> expr -> expr
  | Out   : expr -> expr
  | Fun   : StringMap.key -> expr -> expr.

  (* Function expressions. *)
  Inductive fexpr : Type :=
  | FConst : nat -> fexpr
  | FPlus  : fexpr -> fexpr -> fexpr
  | FIfLe  : fexpr -> fexpr -> fexpr -> fexpr -> fexpr
  | FSeq   : fexpr -> fexpr -> fexpr
  | FOut   : fexpr -> fexpr
  | FArg   : fexpr.

  (* Function types. *)
  Definition funmap := StringMap.t fexpr.
  Definition funmap_turn := StringMap.t (turn * fexpr).
  Definition funset := StringSet.t.

  (* Some additional helpers to write properties. *)
  Definition funmap_bodies (fs : funmap) : list fexpr :=
    List.map snd (StringMap.elements fs).

  Definition funmap_turn_bodies (fs : funmap_turn) : funmap :=
    StringMap.map snd fs.

  (* Well-formed calls. *)
  Inductive well_formed_calls (fs : funmap_turn) : expr -> Prop :=
  | CallsConst : forall n,
      well_formed_calls fs (Const n)
  | CallsPlus : forall e1 e2,
      well_formed_calls fs e1 -> well_formed_calls fs e2 ->
      well_formed_calls fs (Plus e1 e2)
  | CallsIfLe : forall econd1 econd2 ethen eelse,
      well_formed_calls fs econd1 -> well_formed_calls fs econd2 ->
      well_formed_calls fs ethen -> well_formed_calls fs eelse ->
      well_formed_calls fs (IfLe econd1 econd2 ethen eelse)
  | CallsSeq : forall e1 e2,
      well_formed_calls fs e1 -> well_formed_calls fs e2 ->
      well_formed_calls fs (Seq e1 e2)
  | CallsOut : forall e,
      well_formed_calls fs e ->
      well_formed_calls fs (Out e)
  | CallsFun id earg :
      StringMap.mem id fs = true ->
      well_formed_calls fs earg -> well_formed_calls fs (Fun id earg).

  (* A simple notion of closed program with implicit, exact interfaces. *)
  Fixpoint funs (e : expr) : funset :=
    match e with
    | Const _ => ∅
    | Out e => funs e
    | Plus e1 e2 | Seq e1 e2 => funs e1 ∪ funs e2
    | IfLe e1 e2 e3 e4 => funs e1 ∪ funs e2 ∪ funs e3 ∪ funs e3
    | Fun f e => StringSet.add f (funs e)
    end.

  Definition closed (fs : funmap_turn) (e : expr) : bool :=
    StringSet.equal (elements_set _ fs) (funs e).

  (* Programs and contexts. *)
  Record par :=
    {
      par_funs : funmap;
      par_main : expr;
    }.

  Record ctx :=
    {
      ctx_funs : funmap;
    }.

  (* Record prg_wf (funs : funmap_turn) (main : expr) := *)
  (*   { *)
  (*     prg_wf_calls : well_formed_calls funs main *)
  (*   }. *)

  Record prg :=
    {
      prg_funs : funmap_turn;
      prg_main : expr;
    }.

  Definition prg_wf (p : prg) : Prop :=
    well_formed_calls (prg_funs p) (prg_main p).

  (* Linking. Assume main in the program and combine functions from program and
     context with tags to remember provenance. *)
  Definition link_fun (par_fun ctx_fun : option fexpr) :=
    match par_fun, ctx_fun with
    | Some f, _ => Some (ProgramTurn, f)
    | _, Some f => Some (ContextTurn, f)
    | _, _ => None
    end.

  Definition link_funmaps (funs_p funs_c : funmap) : funmap_turn :=
    StringMap.map2 link_fun funs_p funs_c.

  Definition link_funs (p : par) (c : ctx) : funmap_turn :=
    link_funmaps (par_funs p) (ctx_funs c).

  (* Lemma link_wf  (p : par) (c : ctx) : *)
  (*   closed (link_funs p c) (par_main p) = true -> *)
  (*   par_wf (par_funs p) (par_main p) -> *)
  (*   ctx_wf (ctx_funs c) -> *)
  (*   prg_wf (link_funs p c) (par_main p). *)
  (* Admitted. *)

  Definition link (p : par) (c : ctx) : prg :=
    Build_prg (link_funs p c) (par_main p).

  (* Traces as lists of events. *)
  Inductive event :=
  | Result : nat -> event
  | Output : nat -> event.

  Inductive reg_event : event -> Prop :=
  | RE_Output : forall n, reg_event (Output n).

  Definition trace := list event.

  (* Evaluation-based semantics, returns trace. *)
  Inductive eval_fun (arg : nat) : fexpr -> (nat * trace) -> Prop :=
  | FEval_Const : forall n,
      eval_fun arg (FConst n) (n, [])
  | FEval_Plus : forall e1 e2 n1 n2 t1 t2,
      eval_fun arg e1 (n1, t1) -> eval_fun arg e2 (n2, t2) ->
      eval_fun arg (FPlus e1 e2) (n1 + n2, t1 ++ t2)
  | FEval_IfThen : forall ecomp1 ecomp2 ethen eelse n1 n2 n t1 t2 t,
      eval_fun arg ecomp1 (n1, t1) -> eval_fun arg ecomp2 (n2, t2) ->
      n1 <= n2 -> eval_fun arg ethen (n, t) ->
      eval_fun arg (FIfLe ecomp1 ecomp2 ethen eelse) (n, t1 ++ t2 ++ t)
  | FEval_IfElse : forall ecomp1 ecomp2 ethen eelse n1 n2 n t1 t2 t,
      eval_fun arg ecomp1 (n1, t1) -> eval_fun arg ecomp2 (n2, t2) ->
      n1 > n2 -> eval_fun arg eelse (n, t) ->
      eval_fun arg (FIfLe ecomp1 ecomp2 ethen eelse) (n, t1 ++ t2 ++ t)
  | FEval_Seq : forall e1 e2 n1 n2 t1 t2,
      eval_fun arg e1 (n1, t1) -> eval_fun arg e2 (n2, t2) ->
      eval_fun arg (FSeq e1 e2) (n2, t1 ++ t2)
  | FEval_Out : forall e n t,
      eval_fun arg e (n, t) ->
      eval_fun arg (FOut e) (n, t ++ [Output n])
  | FEval_Arg :
      eval_fun arg FArg (arg, []).

  Inductive eval_main (fs : funmap_turn) : expr -> (nat * trace) -> Prop :=
  | Eval_Const : forall n,
      eval_main fs (Const n) (n, [])
  | Eval_Plus : forall e1 e2 n1 n2 t1 t2,
      eval_main fs e1 (n1, t1) -> eval_main fs e2 (n2, t2) ->
      eval_main fs (Plus e1 e2) (n1 + n2, t1 ++ t2)
  | Eval_IfThen : forall ecomp1 ecomp2 ethen eelse n1 n2 n t1 t2 t,
      eval_main fs ecomp1 (n1, t1) -> eval_main fs ecomp2 (n2, t2) ->
      n1 <= n2 -> eval_main fs ethen (n, t) ->
      eval_main fs (IfLe ecomp1 ecomp2 ethen eelse) (n, t1 ++ t2 ++ t)
  | Eval_IfElse : forall ecomp1 ecomp2 ethen eelse n1 n2 n t1 t2 t,
      eval_main fs ecomp1 (n1, t1) -> eval_main fs ecomp2 (n2, t2) ->
      n1 > n2 -> eval_main fs eelse (n, t) ->
      eval_main fs (IfLe ecomp1 ecomp2 ethen eelse) (n, t1 ++ t2 ++ t)
  | Eval_Seq : forall e1 e2 n1 n2 t1 t2,
      eval_main fs e1 (n1, t1) -> eval_main fs e2 (n2, t2) ->
      eval_main fs (Seq e1 e2) (n2, t1 ++ t2)
  | Eval_Out : forall e n t,
      eval_main fs e (n, t) ->
      eval_main fs (Out e) (n, t ++ [Output n])
  | Eval_Fun : forall id turn earg e arg n targ t,
      StringMap.find id fs = Some (turn, e) ->
      eval_main fs earg (arg, targ) -> eval_fun arg e (n, t) ->
      eval_main fs (Fun id earg) (n, targ ++ t)
  (* Temporary hack covering the bad case. *)
  | Eval_BadFun : forall id earg,
      StringMap.find id fs = None ->
      eval_main fs (Fun id earg) (0, []).

  Inductive eval_prg (p : prg) : trace -> Prop :=
  | Eval_Prg : forall n t,
      eval_main (prg_funs p) (prg_main p) (n, t) ->
      eval_prg p (t ++ [Result n]).

  Inductive sem_prg : prg -> trace -> Prop :=
  | SemEval : forall p t, eval_prg p t -> sem_prg p t.

  Remark trace_exists_fun : forall arg e, exists res t, eval_fun arg e (res, t).
  Proof.
    intros arg e. induction e.
    - do 2 eexists. now econstructor.
    - destruct IHe1 as [? [? Hfun1]].
      destruct IHe2 as [? [? Hfun2]].
      do 2 eexists. econstructor; eassumption.
    - destruct IHe1 as [n1 [? Hfun1]].
      destruct IHe2 as [n2 [? Hfun2]].
      destruct IHe3 as [n3 [? Hfun3]].
      destruct IHe4 as [n4 [? Hfun4]].
      destruct (Compare_dec.le_gt_dec n1 n2) as [Hle | Hgt].
      + do 2 eexists. econstructor; eassumption.
      + do 2 eexists. eapply FEval_IfElse; eassumption.
    - destruct IHe1 as [? [? Hfun1]].
      destruct IHe2 as [? [? Hfun2]].
      do 2 eexists. econstructor; eassumption.
    - destruct IHe as [? [? Hfun1]].
      do 2 eexists. econstructor; eassumption.
    - do 2 eexists. econstructor; eassumption.
  Qed.

  Remark trace_exists : forall W : prg, exists t : trace, sem_prg W t.
  Proof.
    intros [funs main].
    induction main.
    - eexists. now do 3 constructor.
    - destruct IHmain1 as [t1 Hsem1];
        inversion Hsem1 as [? ? Hprg1];
        inversion Hprg1 as [? ? Hmain1]; subst.
      destruct IHmain2 as [t2 Hsem2];
        inversion Hsem2 as [? ? Hprg2];
        inversion Hprg2 as [? ? Hmain2]; subst.
      eexists. do 3 constructor; eassumption.
    - destruct IHmain1 as [? Hsem1];
        inversion Hsem1 as [? ? Hprg1];
        inversion Hprg1 as [n1 t1 Hmain1]; subst.
      destruct IHmain2 as [? Hsem2];
        inversion Hsem2 as [? ? Hprg2];
        inversion Hprg2 as [n2 t2 Hmain2]; subst.
      destruct IHmain3 as [? Hsem3];
        inversion Hsem3 as [? ? Hprg3];
        inversion Hprg3 as [n3 t3 Hmain3]; subst.
      destruct IHmain4 as [? Hsem4];
        inversion Hsem4 as [? ? Hprg4];
        inversion Hprg4 as [n4 t4 Hmain4]; subst.
      destruct (Compare_dec.le_gt_dec n1 n2) as [Hle | Hgt].
      + eexists. do 3 econstructor; eassumption.
      + eexists. do 2 constructor. eapply Eval_IfElse; eassumption.
    - destruct IHmain1 as [t1 Hsem1];
        inversion Hsem1 as [? ? Hprg1];
        inversion Hprg1 as [? ? Hmain1]; subst.
      destruct IHmain2 as [t2 Hsem2];
        inversion Hsem2 as [? ? Hprg2];
        inversion Hprg2 as [? ? Hmain2]; subst.
      eexists. do 2 constructor. eapply Eval_Seq; eassumption.
    - destruct IHmain as [t1 Hsem];
        inversion Hsem as [? ? Hprg];
        inversion Hprg as [? ? Hmain]; subst.
      eexists. do 3 constructor; eassumption.
    - destruct IHmain as [? Hsem];
        inversion Hsem as [? ? Hprg];
        inversion Hprg as [n t' Hmain]; subst.
      destruct (StringMap.find k funs) as [[turn e] |] eqn:Hcase.
      + destruct (trace_exists_fun n e) as [? [? Hfun]].
        eexists. do 2 constructor. eapply Eval_Fun; try eassumption.
      + eexists. do 3 constructor; eassumption.
  Qed.

  Inductive wf_trace : trace -> Prop :=
  | WFTrace : forall t t' res,
      t = t' ++ [Result res] -> Forall reg_event t' -> wf_trace t.

  Lemma eval_fun_trace : forall arg e n t,
    eval_fun arg e (n, t) ->
    Forall reg_event t.
  Proof.
    induction e;
      intros res t Heval;
      inversion Heval; subst.
    - now eauto.
    - apply forall_app; now eauto.
    - apply forall_app; [| apply forall_app]; now eauto.
    - apply forall_app; [| apply forall_app]; now eauto.
    - apply forall_app; now eauto.
    - apply forall_app; first now eauto.
      now constructor.
    - now eauto.
  Qed.

  Lemma eval_main_trace : forall funs main n t,
    eval_main funs main (n, t) ->
    Forall reg_event t.
  Proof.
    induction main;
      intros res t Heval;
      inversion Heval; subst.
    - now eauto.
    - apply forall_app; now eauto.
    - apply forall_app; [| apply forall_app]; now eauto.
    - apply forall_app; [| apply forall_app]; now eauto.
    - apply forall_app; now eauto.
    - apply forall_app; first now eauto.
      now constructor.
    - apply forall_app; first now eauto.
      eapply eval_fun_trace; eassumption.
    - now eauto.
  Qed.

  Theorem sem_trace : forall p t, sem_prg p t -> wf_trace t.
  Proof.
    intros p t Hsem.
    inversion Hsem as [? ? Hprg]; subst.
    inversion Hprg as [? ? Hmain]; subst.
    apply eval_main_trace in Hmain.
    now econstructor.
  Qed.

  Definition lang := Build_Language link.
  Definition sem := Build_Semantics lang sem_prg trace_exists.
End Source.

(* Target language. *)
Module Target.
  (* Base expressions. *)
  Inductive expr : Type :=
  | Const : nat -> expr
  | Plus  : expr -> expr -> expr
  | IfLe  : expr -> expr -> expr -> expr -> expr
  | Seq   : expr -> expr -> expr
  | Out   : expr -> expr
  | OutH  : expr -> expr
  | Fun   : StringMap.key -> expr -> expr.

  (* Function expressions. *)
  Inductive fexpr : Type :=
  | FConst : nat -> fexpr
  | FPlus  : fexpr -> fexpr -> fexpr
  | FIfLe  : fexpr -> fexpr -> fexpr -> fexpr -> fexpr
  | FSeq   : fexpr -> fexpr -> fexpr
  | FOut   : fexpr -> fexpr
  | FOutH  : fexpr -> fexpr
  | FArg   : fexpr.

  (* Function types. *)
  Definition funmap := StringMap.t fexpr.
  Definition funmap_turn := StringMap.t (turn * fexpr).
  Definition funset := StringSet.t.

  (* Some additional helpers to write properties. *)
  Definition funmap_bodies (fs : funmap) : list fexpr :=
    List.map snd (StringMap.elements fs).

  Definition funmap_turn_bodies (fs : funmap_turn) : funmap :=
    StringMap.map snd fs.

  (* Well-formed calls. *)
  Inductive well_formed_calls (fs : funmap_turn) : expr -> Prop :=
  | CallsConst : forall n,
      well_formed_calls fs (Const n)
  | CallsPlus : forall e1 e2,
      well_formed_calls fs e1 -> well_formed_calls fs e2 ->
      well_formed_calls fs (Plus e1 e2)
  | CallsIfLe : forall econd1 econd2 ethen eelse,
      well_formed_calls fs econd1 -> well_formed_calls fs econd2 ->
      well_formed_calls fs ethen -> well_formed_calls fs eelse ->
      well_formed_calls fs (IfLe econd1 econd2 ethen eelse)
  | CallsSeq : forall e1 e2,
      well_formed_calls fs e1 -> well_formed_calls fs e2 ->
      well_formed_calls fs (Seq e1 e2)
  | CallsOut : forall e,
      well_formed_calls fs e ->
      well_formed_calls fs (Out e)
  | CallsOutH : forall e,
      well_formed_calls fs e ->
      well_formed_calls fs (OutH e)
  | CallsFun id earg :
      StringMap.mem id fs = true ->
      well_formed_calls fs earg -> well_formed_calls fs (Fun id earg).

  (* A simple notion of closed program with implicit, exact interfaces. *)
  Fixpoint funs (e : expr) : funset :=
    match e with
    | Const _ => ∅
    | Out e | OutH e => funs e
    | Plus e1 e2 | Seq e1 e2 => funs e1 ∪ funs e2
    | IfLe e1 e2 e3 e4 => funs e1 ∪ funs e2 ∪ funs e3 ∪ funs e3
    | Fun f e => StringSet.add f (funs e)
    end.

  Definition closed (fs : funmap_turn) (e : expr) : bool :=
    StringSet.equal (elements_set _ fs) (funs e).

  (* Programs and contexts. *)
  Record par :=
    {
      par_funs : funmap;
      par_main : expr;
    }.

  Record ctx :=
    {
      ctx_funs : funmap;
    }.

  (* Record prg_wf (funs : funmap_turn) (main : expr) := *)
  (*   { *)
  (*     prg_wf_calls : well_formed_calls funs main *)
  (*   }. *)

  Record prg :=
    {
      prg_funs : funmap_turn;
      prg_main : expr;
    }.

  Definition prg_wf (p : prg) : Prop :=
    well_formed_calls (prg_funs p) (prg_main p).

  (* Linking. Assume main in the program and combine functions from program and
     context with tags to remember provenance. *)
  Definition link_fun (par_fun ctx_fun : option fexpr) :=
    match par_fun, ctx_fun with
    | Some f, _ => Some (ProgramTurn, f)
    | _, Some f => Some (ContextTurn, f)
    | _, _ => None
    end.

  Definition link_funmaps (funs_p funs_c : funmap) : funmap_turn :=
    StringMap.map2 link_fun funs_p funs_c.

  Definition link_funs (p : par) (c : ctx) : funmap_turn :=
    link_funmaps (par_funs p) (ctx_funs c).

  (* Lemma link_wf  (p : par) (c : ctx) : *)
  (*   closed (link_funs p c) (par_main p) = true -> *)
  (*   par_wf (par_funs p) (par_main p) -> *)
  (*   ctx_wf (ctx_funs c) -> *)
  (*   prg_wf (link_funs p c) (par_main p). *)
  (* Admitted. *)

  Definition link (p : par) (c : ctx) : prg :=
    Build_prg (link_funs p c) (par_main p).

  (* Traces as lists of events. *)
  Inductive event :=
  | Result : nat -> event
  | Output : nat -> event
  | OutputH : nat -> event.

  Inductive reg_event : event -> Prop :=
  | RE_Output : forall n, reg_event (Output n)
  | RE_OutputH : forall n, reg_event (OutputH n).

  Definition trace := list event.

  (* Evaluation-based semantics, returns trace. *)
  Inductive eval_fun (arg : nat) : fexpr -> (nat * trace) -> Prop :=
  | FEval_Const : forall n,
      eval_fun arg (FConst n) (n, [])
  | FEval_Plus : forall e1 e2 n1 n2 t1 t2,
      eval_fun arg e1 (n1, t1) -> eval_fun arg e2 (n2, t2) ->
      eval_fun arg (FPlus e1 e2) (n1 + n2, t1 ++ t2)
  | FEval_IfThen : forall ecomp1 ecomp2 ethen eelse n1 n2 n t1 t2 t,
      eval_fun arg ecomp1 (n1, t1) -> eval_fun arg ecomp2 (n2, t2) ->
      n1 <= n2 -> eval_fun arg ethen (n, t) ->
      eval_fun arg (FIfLe ecomp1 ecomp2 ethen eelse) (n, t1 ++ t2 ++ t)
  | FEval_IfElse : forall ecomp1 ecomp2 ethen eelse n1 n2 n t1 t2 t,
      eval_fun arg ecomp1 (n1, t1) -> eval_fun arg ecomp2 (n2, t2) ->
      n1 > n2 -> eval_fun arg eelse (n, t) ->
      eval_fun arg (FIfLe ecomp1 ecomp2 ethen eelse) (n, t1 ++ t2 ++ t)
  | FEval_Seq : forall e1 e2 n1 n2 t1 t2,
      eval_fun arg e1 (n1, t1) -> eval_fun arg e2 (n2, t2) ->
      eval_fun arg (FSeq e1 e2) (n2, t1 ++ t2)
  | FEval_Out : forall e n t,
      eval_fun arg e (n, t) ->
      eval_fun arg (FOut e) (n, t ++ [Output n])
  | FEval_OutH : forall e n t,
      eval_fun arg e (n, t) ->
      eval_fun arg (FOutH e) (n, t ++ [OutputH n])
  | FEval_Arg :
      eval_fun arg FArg (arg, []).

  Inductive eval_main (fs : funmap_turn) : expr -> (nat * trace) -> Prop :=
  | Eval_Const : forall n,
      eval_main fs (Const n) (n, [])
  | Eval_Plus : forall e1 e2 n1 n2 t1 t2,
      eval_main fs e1 (n1, t1) -> eval_main fs e2 (n2, t2) ->
      eval_main fs (Plus e1 e2) (n1 + n2, t1 ++ t2)
  | Eval_IfThen : forall ecomp1 ecomp2 ethen eelse n1 n2 n t1 t2 t,
      eval_main fs ecomp1 (n1, t1) -> eval_main fs ecomp2 (n2, t2) ->
      n1 <= n2 -> eval_main fs ethen (n, t) ->
      eval_main fs (IfLe ecomp1 ecomp2 ethen eelse) (n, t1 ++ t2 ++ t)
  | Eval_IfElse : forall ecomp1 ecomp2 ethen eelse n1 n2 n t1 t2 t,
      eval_main fs ecomp1 (n1, t1) -> eval_main fs ecomp2 (n2, t2) ->
      n1 > n2 -> eval_main fs eelse (n, t) ->
      eval_main fs (IfLe ecomp1 ecomp2 ethen eelse) (n, t1 ++ t2 ++ t)
  | Eval_Seq : forall e1 e2 n1 n2 t1 t2,
      eval_main fs e1 (n1, t1) -> eval_main fs e2 (n2, t2) ->
      eval_main fs (Seq e1 e2) (n2, t1 ++ t2)
  | Eval_Out : forall e n t,
      eval_main fs e (n, t) ->
      eval_main fs (Out e) (n, t ++ [Output n])
  | Eval_OutH : forall e n t,
      eval_main fs e (n, t) ->
      eval_main fs (OutH e) (n, t ++ [OutputH n])
  | Eval_Fun : forall id turn earg e arg n targ t,
      StringMap.find id fs = Some (turn, e) ->
      eval_main fs earg (arg, targ) -> eval_fun arg e (n, t) ->
      eval_main fs (Fun id earg) (n, targ ++ t)
  (* Temporary hack covering the bad case. *)
  | Eval_BadFun : forall id earg,
      StringMap.find id fs = None ->
      eval_main fs (Fun id earg) (0, []).

  Inductive eval_prg (p : prg) : trace -> Prop :=
  | Eval_Prg : forall n t,
      eval_main (prg_funs p) (prg_main p) (n, t) ->
      eval_prg p (t ++ [Result n]).

  Inductive sem_prg : prg -> trace -> Prop :=
  | SemEval : forall p t, eval_prg p t -> sem_prg p t.

  Remark trace_exists_fun : forall arg e, exists res t, eval_fun arg e (res, t).
  Proof.
    intros arg e. induction e.
    - do 2 eexists. now econstructor.
    - destruct IHe1 as [? [? Hfun1]].
      destruct IHe2 as [? [? Hfun2]].
      do 2 eexists. econstructor; eassumption.
    - destruct IHe1 as [n1 [? Hfun1]].
      destruct IHe2 as [n2 [? Hfun2]].
      destruct IHe3 as [n3 [? Hfun3]].
      destruct IHe4 as [n4 [? Hfun4]].
      destruct (Compare_dec.le_gt_dec n1 n2) as [Hle | Hgt].
      + do 2 eexists. econstructor; eassumption.
      + do 2 eexists. eapply FEval_IfElse; eassumption.
    - destruct IHe1 as [? [? Hfun1]].
      destruct IHe2 as [? [? Hfun2]].
      do 2 eexists. econstructor; eassumption.
    - destruct IHe as [? [? Hfun1]].
      do 2 eexists. econstructor; eassumption.
    - destruct IHe as [? [? Hfun1]].
      do 2 eexists. econstructor; eassumption.
    - do 2 eexists. econstructor; eassumption.
  Qed.

  Remark trace_exists : forall W : prg, exists t : trace, sem_prg W t.
  Proof.
    intros [funs main].
    induction main.
    - eexists. now do 3 constructor.
    - destruct IHmain1 as [t1 Hsem1];
        inversion Hsem1 as [? ? Hprg1];
        inversion Hprg1 as [? ? Hmain1]; subst.
      destruct IHmain2 as [t2 Hsem2];
        inversion Hsem2 as [? ? Hprg2];
        inversion Hprg2 as [? ? Hmain2]; subst.
      eexists. do 3 constructor; eassumption.
    - destruct IHmain1 as [? Hsem1];
        inversion Hsem1 as [? ? Hprg1];
        inversion Hprg1 as [n1 t1 Hmain1]; subst.
      destruct IHmain2 as [? Hsem2];
        inversion Hsem2 as [? ? Hprg2];
        inversion Hprg2 as [n2 t2 Hmain2]; subst.
      destruct IHmain3 as [? Hsem3];
        inversion Hsem3 as [? ? Hprg3];
        inversion Hprg3 as [n3 t3 Hmain3]; subst.
      destruct IHmain4 as [? Hsem4];
        inversion Hsem4 as [? ? Hprg4];
        inversion Hprg4 as [n4 t4 Hmain4]; subst.
      destruct (Compare_dec.le_gt_dec n1 n2) as [Hle | Hgt].
      + eexists. do 3 econstructor; eassumption.
      + eexists. do 2 constructor. eapply Eval_IfElse; eassumption.
    - destruct IHmain1 as [t1 Hsem1];
        inversion Hsem1 as [? ? Hprg1];
        inversion Hprg1 as [? ? Hmain1]; subst.
      destruct IHmain2 as [t2 Hsem2];
        inversion Hsem2 as [? ? Hprg2];
        inversion Hprg2 as [? ? Hmain2]; subst.
      eexists. do 2 constructor. eapply Eval_Seq; eassumption.
    - destruct IHmain as [t1 Hsem];
        inversion Hsem as [? ? Hprg];
        inversion Hprg as [? ? Hmain]; subst.
      eexists. do 3 constructor; eassumption.
    - destruct IHmain as [? Hsem];
        inversion Hsem as [? ? Hprg];
        inversion Hprg as [n t' Hmain]; subst.
      eexists. do 3 constructor; eassumption.
    - destruct IHmain as [? Hsem];
        inversion Hsem as [? ? Hprg];
        inversion Hprg as [n t' Hmain]; subst.
      destruct (StringMap.find k funs) as [[turn e] |] eqn:Hcase.
      + destruct (trace_exists_fun n e) as [? [? Hfun]].
        eexists. do 2 constructor. eapply Eval_Fun; try eassumption.
      + eexists. do 3 constructor; eassumption.
  Qed.

  Inductive wf_trace : trace -> Prop :=
  | WFTrace : forall t t' res,
      t = t' ++ [Result res] -> Forall reg_event t' -> wf_trace t.

  Lemma eval_fun_trace : forall arg e n t,
    eval_fun arg e (n, t) ->
    Forall reg_event t.
  Proof.
    induction e;
      intros res t Heval;
      inversion Heval; subst.
    - now eauto.
    - apply forall_app; now eauto.
    - apply forall_app; [| apply forall_app]; now eauto.
    - apply forall_app; [| apply forall_app]; now eauto.
    - apply forall_app; now eauto.
    - apply forall_app; first now eauto.
      now repeat constructor.
    - apply forall_app; first now eauto.
      now repeat constructor.
    - now eauto.
  Qed.

  Lemma eval_main_trace : forall funs main n t,
    eval_main funs main (n, t) ->
    Forall reg_event t.
  Proof.
    induction main;
      intros res t Heval;
      inversion Heval; subst.
    - now eauto.
    - apply forall_app; now eauto.
    - apply forall_app; [| apply forall_app]; now eauto.
    - apply forall_app; [| apply forall_app]; now eauto.
    - apply forall_app; now eauto.
    - apply forall_app; first now eauto.
      now repeat constructor.
    - apply forall_app; first now eauto.
      now repeat constructor.
    - apply forall_app; first now eauto.
      eapply eval_fun_trace; eassumption.
    - now eauto.
  Qed.

  Theorem sem_trace : forall p t, sem_prg p t -> wf_trace t.
  Proof.
    intros p t Hsem.
    inversion Hsem as [? ? Hprg]; subst.
    inversion Hprg as [? ? Hmain]; subst.
    apply eval_main_trace in Hmain.
    now econstructor.
  Qed.

  Definition lang := Build_Language link.
  Definition sem := Build_Semantics lang sem_prg trace_exists.
End Target.

(* Compiler. *)
Module Compiler.
  Module S := Source.
  Module T := Target.

  (* Build the identity compiler and define the chain. *)
  Fixpoint comp_expr (e : S.expr) : T.expr :=
    match e with
    | S.Const n => T.Const n
    | S.Plus e1 e2 => T.Plus (comp_expr e1) (comp_expr e2)
    | S.IfLe e1 e2 e3 e4 =>
      T.IfLe (comp_expr e1) (comp_expr e2) (comp_expr e3) (comp_expr e4)
    | S.Seq e1 e2 => T.Seq (comp_expr e1) (comp_expr e2)
    | S.Out e => T.Out (comp_expr e)
    | S.Fun f e => T.Fun f (comp_expr e)
    end.

  Fixpoint comp_fexpr (e : S.fexpr) : T.fexpr :=
    match e with
    | S.FConst n => T.FConst n
    | S.FPlus e1 e2 => T.FPlus (comp_fexpr e1) (comp_fexpr e2)
    | S.FIfLe e1 e2 e3 e4 =>
      T.FIfLe (comp_fexpr e1) (comp_fexpr e2) (comp_fexpr e3) (comp_fexpr e4)
    | S.FSeq e1 e2 => T.FSeq (comp_fexpr e1) (comp_fexpr e2)
    | S.FOut e => T.FOut (comp_fexpr e)
    | S.FArg => T.FArg
    end.

  Definition comp_funmap (fs : S.funmap) : T.funmap :=
    StringMap.map comp_fexpr fs.

  Definition comp_funmap_turn (fs : S.funmap_turn) : T.funmap_turn :=
    StringMap.map (fun '(t, e) => (t, comp_fexpr e)) fs.

  Definition comp_prg (p : prg S.lang) : prg T.lang :=
    T.Build_prg (comp_funmap_turn (S.prg_funs p)) (comp_expr (S.prg_main p)).

  Definition comp_par (p : par S.lang) : par T.lang :=
    T.Build_par (comp_funmap (S.par_funs p)) (comp_expr (S.par_main p)).

  Definition comp_ctx (c : ctx S.lang) : ctx T.lang :=
    T.Build_ctx (comp_funmap (S.ctx_funs c)).

  Definition chain :=
    Build_CompilationChain S.lang T.lang comp_prg comp_par comp_ctx.
End Compiler.

(* Compiler proofs. *)
Module RTCtilde.
  Module S := Source.
  Module T := Target.
  Module C := Compiler.

  (* A simple trace relation that does not track program-context changes. It
     will say less about the target in the source, but also be a bit easier to
     prove. *)
  Definition pub_event (e : T.event) : bool :=
    match e with
    | T.OutputH _ => false
    | T.Output _ | T.Result _ => true
    end.

  Definition clean_event (e : T.event) : S.event :=
    match e with
    | T.Result n => S.Result n
    | T.Output n => S.Output n
    (* Bad case. *)
    | T.OutputH _ => S.Output 0
    end.

  Definition clean_trace (t : T.trace) : S.trace :=
    map clean_event (filter pub_event t). (* Reasoning on filter vs. ... *)

  Inductive trel : S.trace -> T.trace -> Prop :=
  | RelTrace : forall t, T.wf_trace t -> trel (clean_trace t) t.

  (* Properties of trace cleanup. *)
  Remark clean_trace_app : forall t1 t2,
    clean_trace (t1 ++ t2) = clean_trace t1 ++ clean_trace t2.
  Proof.
    induction t1 as [| e t1' IHt1']; intros t2.
    - reflexivity.
    - simpl. unfold clean_trace.
      destruct (pub_event e) eqn:Hcase; simpl; rewrite Hcase; simpl;
        unfold clean_trace in IHt1'; now rewrite IHt1'.
  Qed.

  Remark clean_trace_snoc_result : forall t n,
    clean_trace (t ++ [T.Result n]) = clean_trace t ++ [S.Result n].
  Proof.
    intros; now rewrite clean_trace_app.
  Qed.

  Remark clean_trace_snoc_output : forall t n,
    clean_trace (t ++ [T.Output n]) = clean_trace t ++ [S.Output n].
  Proof.
    intros; now rewrite clean_trace_app.
  Qed.

  Remark clean_trace_snoc_outputh : forall t n,
    clean_trace (t ++ [T.OutputH n]) = clean_trace t.
  Proof.
    intros; rewrite clean_trace_app.
    unfold clean_trace. now rewrite app_nil_r.
  Qed.

  Theorem trel_clean_trace : forall p t,
    T.sem_prg p t ->
    trel (clean_trace t) t.
  Proof.
    intros p t Hsem.
    apply T.sem_trace in Hsem.
    now constructor.
  Qed.

  (* Context cleanup. *)
  Fixpoint clean_expr (e : T.expr) : S.expr :=
    match e with
    | T.Const n => S.Const n
    | T.Plus e1 e2 => S.Plus (clean_expr e1) (clean_expr e2)
    | T.Seq e1 e2 => S.Seq (clean_expr e1) (clean_expr e2)
    | T.OutH e => clean_expr e
    | T.Out e => S.Out (clean_expr e)
    | T.IfLe e1 e2 e3 e4 =>
      S.IfLe (clean_expr e1) (clean_expr e2) (clean_expr e3) (clean_expr e4)
    | T.Fun f e => S.Fun f (clean_expr e)
    end.

  Fixpoint clean_fexpr (e : T.fexpr) : S.fexpr :=
    match e with
    | T.FConst n => S.FConst n
    | T.FPlus e1 e2 => S.FPlus (clean_fexpr e1) (clean_fexpr e2)
    | T.FSeq e1 e2 => S.FSeq (clean_fexpr e1) (clean_fexpr e2)
    | T.FOutH e => clean_fexpr e
    | T.FOut e => S.FOut (clean_fexpr e)
    | T.FIfLe e1 e2 e3 e4 =>
      S.FIfLe (clean_fexpr e1) (clean_fexpr e2) (clean_fexpr e3) (clean_fexpr e4)
    | T.FArg => S.FArg
    end.

  Definition clean_funmap : T.funmap -> S.funmap :=
    StringMap.map clean_fexpr.

  Definition clean_ctx (c : T.ctx) : S.ctx :=
    S.Build_ctx (clean_funmap (T.ctx_funs c)).

  Lemma clean_comp_fexpr : forall e, clean_fexpr (C.comp_fexpr e) = e.
  Proof.
    intro e; induction e; simpl; congruence.
  Qed.

  (* Cheat code: the language model does not easily allow a conditional
     formulation based on some well-formedness conditions on program and
     context. Use this to artificially establish that assumed fact after
     program and context have been introduced. *)
  Hypothesis hyp_wf : forall p c, T.prg_wf (T.link (C.comp_par p) c).

  (* Main auxiliary results. *)
  Remark eval_main_link_prg funs_p main_p funs_c main res :
    T.eval_main (T.link_funs (T.Build_par funs_p main_p) (T.Build_ctx funs_c)) main res ->
    let pc := T.Build_prg (T.link_funmaps funs_p funs_c) main in
    T.eval_main (T.prg_funs pc) (T.prg_main pc) res.
  Proof.
    unfold T.link_funs. intros Heval. assumption.
  Qed.

  Remark sem_prg_link funs1 funs2 main t :
    T.sem_prg (T.Build_prg (T.link_funmaps funs1 funs2) main)       t ->
    T.sem_prg (T.link (T.Build_par funs1 main) (T.Build_ctx funs2)) t.
  Proof.
    easy.
  Qed.

  (* If lookup succeeds on a target map containing functions from a compiled
     source program (clean by definition) and a target context, a second lookup
     on the source map containing the functions from the original source program
     and the cleaned functions from the context will also succeed, and its body
     be the body of the first lookup, once cleaned. This property follows
     trivially from our definitions and those of standard maps. *)
  Remark find_clean_ctx : forall k par_s ctx_t tag e,
    StringMap.find k (T.link_funs (C.comp_par par_s)            ctx_t)  = Some (tag, e) ->
    StringMap.find k (S.link_funs             par_s  (clean_ctx ctx_t)) = Some (tag, clean_fexpr e).
  Proof.
    intros k [par_funs par_main] [ctx_funs] tag e.
    unfold T.link_funs, S.link_funs, T.link_funmaps, S.link_funmaps. simpl.
    unfold C.comp_funmap, clean_funmap. simpl.
    intro H.
    setoid_rewrite StringMap.map2_1; [setoid_rewrite StringMap.map2_1 in H |].
    - (* Main goal. *)
      unfold T.link_fun in H. unfold S.link_fun.
      destruct (StringMap.find k (StringMap.map C.comp_fexpr par_funs)) as [e' |] eqn:Hcase1.
      + inversion H; subst tag e; clear H.
        rewrite StringMapFacts.map_o in Hcase1. unfold option_map in Hcase1.
        destruct (StringMap.find k par_funs) as [e |] eqn:Hcase2; last discriminate.
        inversion Hcase1; subst e'; clear Hcase1.
        now rewrite clean_comp_fexpr.
      + destruct (StringMap.find k ctx_funs) as [f |] eqn:Hcase2; last discriminate.
        inversion H; subst tag e; clear H.
        rewrite StringMapFacts.map_o in Hcase1. unfold option_map in Hcase1.
        destruct (StringMap.find k par_funs) eqn:Hcase3; first discriminate.
        rewrite StringMapFacts.map_o. unfold option_map. now rewrite Hcase2.
    - (* First side goal. *)
      remember
        (StringMap.map2 T.link_fun (StringMap.map C.comp_fexpr par_funs) ctx_funs)
        as map.
      apply StringMap.find_2, StringMap.elements_1 in H.
      pose proof @StringMapFacts.elements_in_iff (turn * T.fexpr) map k as Hlemma.
      assert
        (Hex : exists e : turn * T.fexpr,
            InA (StringMap.eq_key_elt (elt:=turn * T.fexpr)) (k, e) (StringMap.elements map))
        by eauto.
      apply Hlemma in Hex.
      subst map.
      now apply StringMap.map2_2 in Hex.
    - (* Second side goal, differing from the first only in the last step. *)
      remember
        (StringMap.map2 T.link_fun (StringMap.map C.comp_fexpr par_funs) ctx_funs)
        as map.
      apply StringMap.find_2, StringMap.elements_1 in H.
      pose proof @StringMapFacts.elements_in_iff (turn * T.fexpr) map k as Hlemma.
      assert
        (Hex : exists e : turn * T.fexpr,
            InA (StringMap.eq_key_elt (elt:=turn * T.fexpr)) (k, e) (StringMap.elements map))
        by eauto.
      apply Hlemma in Hex.
      subst map.
      apply StringMap.map2_2 in Hex as [Hpar | Hctx].
      + left. now apply StringMapFacts.map_in_iff in Hpar.
      + right. now apply StringMapFacts.map_in_iff.
  Qed.

  Lemma eval_fun_clean (arg res : nat) (e : T.fexpr) (t : T.trace) :
    T.eval_fun arg e (res, t) ->
    S.eval_fun arg (clean_fexpr e) (res, clean_trace t).
  Proof.
    revert arg res t.
    induction e; subst;
      intros arg res t Heval;
      inversion Heval; subst;
      simpl.
    - now constructor.
    - rewrite clean_trace_app. constructor.
      + eapply IHe1; eassumption.
      + eapply IHe2; eassumption.
    - rewrite 2!clean_trace_app. econstructor.
      + eapply IHe1; eassumption.
      + eapply IHe2; eassumption.
      + assumption.
      + eapply IHe3; eassumption.
    - rewrite 2!clean_trace_app. eapply S.FEval_IfElse.
      + eapply IHe1; eassumption.
      + eapply IHe2; eassumption.
      + assumption.
      + eapply IHe4; eassumption.
    - rewrite clean_trace_app. eapply S.FEval_Seq.
      + eapply IHe1; eassumption.
      + eapply IHe2; eassumption.
    - rewrite clean_trace_app; simpl. econstructor.
      apply IHe; eassumption.
    - rewrite clean_trace_snoc_outputh.
      apply IHe; assumption.
    - now constructor.
  Qed.

  Ltac t_sem_clean_ind :=
    match goal with
    | IHmain : forall _ _ _ _ , S.sem_prg {| S.prg_funs := _; S.prg_main := ?E |} _,
      Heval_main : T.eval_main _ (C.comp_expr ?E) (_, ?T)
      |- S.eval_main _ ?E (_, clean_trace ?T) =>
      apply eval_main_link_prg in Heval_main;
      pose proof T.Eval_Prg _ _ _ Heval_main as Heval_prg';
      pose proof T.SemEval _ _ Heval_prg' as Hsem_prg';
      apply sem_prg_link in Hsem_prg';
      specialize (IHmain _ _ _ Hsem_prg');
      rewrite clean_trace_snoc_result in IHmain;
      inversion IHmain as [? ? Heval_prg'']; subst;
      inversion Heval_prg'' as [? ? Heval_main'' Htrace]; subst;
      unfold T.link in Heval_main''; simpl in Heval_main'';
      apply app_inj_tail in Htrace as [Ht Hn]; inversion Hn; subst;
      eassumption
  end.

  Ltac t_sem_clean_constr :=
    match goal with
    | |- S.eval_main _ (S.IfLe _ _ _ _) _ =>
      match goal with
      | H : _ <= _ |- _ => eapply S.Eval_IfThen
      | H : _ >  _ |- _ => eapply S.Eval_IfElse
      end
    | _ => econstructor
    end.

  Ltac t_sem_clean :=
    match goal with
    | Hsem_prg : T.sem_prg ?P _ |- _ =>
      inversion Hsem_prg as [? ? Heval_prg]; subst;
      inversion Heval_prg as [? ? Heval_main]; subst;
      inversion Heval_main; subst;
      simpl in *;
      match goal with (* Discharge function not found case. *)
      | H : StringMap.find _  (T.link_funs (C.comp_par ?P) ?C) = None |- _ =>
        pose proof hyp_wf P C as Hwf;
        inversion Hwf as [| | | | | | ? ? Hcontra]; subst;
        unfold T.link in Hcontra; simpl in Hcontra;
        apply StringMap.mem_2 in Hcontra;
        apply StringMapFacts.not_find_in_iff in H;
        contradiction
      | _ => idtac
      end;
      match P with (* Pre-constructor rewrites. *)
      | {| T.prg_funs := _; T.prg_main := T.Const _ |} =>
        unfold clean_trace; simpl;
        try change [S.Result ?X] with ([] ++ [S.Result X])
      | _ =>
        try rewrite clean_trace_snoc_result;
        repeat rewrite clean_trace_app
      end;
      constructor; constructor; simpl; t_sem_clean_constr;
      match P with (* Discharge side sub-goals. *)
      | {| T.prg_funs := _; T.prg_main := T.IfLe _ _ _ _ |} =>
        try eassumption
      | {| T.prg_funs := _; T.prg_main := T.Fun _ _ |} =>
        (try apply eval_fun_clean; eassumption) ||
        (try apply find_clean_ctx; eassumption)
      | _ => idtac
      end;
      now t_sem_clean_ind (* Finish inductive sub-goals. *)
    end.

  Theorem sem_clean (par_s : S.par) (ctx_t : T.ctx) (t : T.trace) :
    T.sem_prg (T.link (C.comp_par par_s) ctx_t) t ->
    S.sem_prg (S.link par_s (clean_ctx ctx_t)) (clean_trace t).
  Proof.
    unfold S.link, T.link.
    set (Hpar_s := par_s). destruct par_s as [funs_s main_s].
    set (Hctx_t := ctx_t). destruct ctx_t as [funs_t].
    simpl.
    revert funs_s Hpar_s funs_t Hctx_t t.
    induction main_s;
      intros funs_s Hpar_s funs_t Hctx_t t Hsem;
      simpl in *;
      t_sem_clean.
  Qed.

  (* Main theorem. *)
  Corollary extra_target_RTCt : rel_RTC C.chain S.sem T.sem trel.
  Proof.
    unfold rel_RTC. simpl. intros par_s ctx_t t Hsem.
    exists (clean_ctx ctx_t), (clean_trace t). split.
    - eapply trel_clean_trace; eassumption.
    - now apply sem_clean.
  Qed.
End RTCtilde.


(** * Addendum to the standard library of Coq *)

Require Import Bool Arith Coq.Arith.Div2 List Permutation.
Require Export Omega.

Global Obligation Tactic := idtac.

Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) .. ).

Lemma length_nil : forall A (l : list A),
  length l = 0 -> l = nil.
Proof.
 intros; destruct l; trivial; intros.
 simpl in H; contradict H; omega.
Qed.

Lemma length_tail A l : length (@tail A l) = length l - 1.
Proof.
  destruct l; simpl; auto with arith.
Qed.

Lemma hd_nth_0 A (l : list A) d :
  hd d l = nth 0 l d.
Proof. intros; case l; simpl; trivial. Qed.

Lemma hd_nth_1 A (l : list A) d :
  hd d (tl l) = nth 1 l d.
Proof.
 intros; case l; simpl; intros; trivial.
 apply hd_nth_0.
Qed.

Lemma In_hd (A : Type)(d:A)(l : list A)(n : nat)(H : length l = S n) :
  In (hd d l) l.
Proof.
destruct l.
simpl in H.
discriminate H.
simpl; tauto.
Qed.

Lemma map_hd : forall A B (f:A->B) d l, f (hd d l) = hd (f d) (map f l).
Proof.
intros A B f d [ | x l]; trivial.
Qed.

Lemma map_tl : forall A B (f:A->B) l, map f (tl l) = tl (map f l).
Proof.
intros A B f [ | x l]; trivial.
Qed.

Lemma map_eq_hd :
  forall A B (f:A->B) d l1 l2,
  map f l1 = map f l2 -> f (hd d l1) = f (hd d l2).
Proof.
intros A B f d [ | a1 l1] [ | a2 l2]; simpl; congruence.
Qed.

Lemma firstn_nil {A} n : firstn n (@nil A) = nil.
Proof. case n; simpl; trivial. Qed.

Lemma skipn_nil : forall {A} n (x : list A),
  length x <= n -> skipn n x = nil.
Proof.
  induction n; simpl in *; trivial; intros.
  apply length_nil; auto; omega.
  destruct x; simpl in *; trivial.
  apply IHn; omega.
Qed.

Lemma nth_firstn : forall A i j (l:list A) d,
  i < j -> nth i (firstn j l) d = nth i l d.
Proof.
 intros A i j.
 revert i; induction j; simpl; intros.
 contradict H; omega.
 case l; simpl; destruct i; simpl; trivial; intros.
 apply IHj; omega.
Qed.

Lemma nth_skipn A i j (l:list A) d :
  nth i (skipn j l) d = nth (j+i) l d.
Proof.
 intros; revert i l.
 induction j; simpl; intros; trivial.
 destruct l; simpl; trivial; case i; trivial.
Qed.

Lemma length_skipn : forall A n (y : list A),
  length (skipn n y) = length y - n.
Proof.
  induction n; simpl; intros; [ omega | ].
  destruct y; simpl; trivial.
Qed.

Lemma skipn_length : forall {A} n (l:list A),
  length (skipn n l) = length l - n.
Proof.
  induction n; simpl; intros; auto with arith.
  destruct l; simpl; auto.
Qed.

Lemma cons_skipn :
  forall A d i (l:list A),
  i < length l ->
  nth i l d :: skipn (S i) l = skipn i l.
Proof.
 induction i as [ | i IH]; simpl; intros.
 destruct l as [ | x l]; trivial.
 contradict H; simpl; omega.
 destruct l as [ | x l].
 contradict H; simpl; omega.
 rewrite <- IH; trivial.
 simpl in H; omega.
Qed.

Lemma skipn_plus :
  forall A j i (l:list A), skipn (i+j) l = skipn i (skipn j l).
Proof.
 induction j as [ | j IH]; simpl; intros.
 rewrite plus_0_r; trivial.
 rewrite <- plus_Snm_nSm.
 case l.
 rewrite !skipn_nil; simpl; trivial; omega.
 simpl; trivial.
Qed.

Lemma skipn_hd : forall {A} n y (d:A),
  n < length y ->
  skipn n y = nth n y d :: skipn (S n) y.
Proof.
 induction n; simpl; intros.
 destruct y; simpl in *; trivial.
 contradict H; omega.
 destruct y; simpl in *.
 contradict H; omega.
 apply IHn.
 omega.
Qed.

Lemma firstn_app {A} (l l' : list A) :
  firstn (length l) (l ++ l') = l.
Proof.
 induction l; intros; simpl; trivial.
 rewrite IHl; trivial.
Qed.

Lemma skipn_app {A} (l l' : list A) :
  skipn (length l) (l ++ l') = l'.
Proof. induction l; intros; simpl; trivial. Qed.

Lemma map_cons : forall A B (f:A->B) a l, map f (a::l) = f a :: map f l.
Proof. trivial. Qed.

Lemma map_firstn : forall A B (f:A->B) n l,
  map f (firstn n l) = firstn n (map f l).
Proof.
 induction n; simpl; intros; trivial.
 case l; simpl; trivial; congruence.
Qed.

Lemma map_skipn : forall A B (f:A->B) n l,
  map f (skipn n l) = skipn n (map f l).
Proof.
 induction n; simpl; intros; trivial.
 case l; simpl; trivial; congruence.
Qed.

Lemma map_nth_seq : forall A (l:list A) len n d,
  length l = len + n ->
  map (fun x : nat => nth x l d) (seq n len) = (skipn n l).
Proof.
 intros A l len; revert l.
 induction len; simpl; intros.
 rewrite skipn_nil; trivial; omega.
 rewrite IHlen, <- skipn_hd; trivial; omega.
Qed.

Lemma skipn_nil_length : forall A n (l : list A),
  skipn n l = nil -> length l <= n.
Proof.
  induction n; simpl in *; intros.
  subst; simpl; trivial.
  destruct l; simpl; [ omega | ].
  generalize (IHn _ H); omega.
Qed.

Lemma firstn_map_nth :
  forall A d n m (l:list A),
  m+n <= length l ->
  firstn n (skipn m l) = map (fun i => nth i l d) (seq m n).
Proof.
 induction n as [ | n IH]; simpl; intros; trivial.
 rewrite <- IH by omega.
 replace (skipn (S m) l) with (tl (skipn m l)).
 case_eq (skipn m l).
 intro H0.
 contradict H0.
 contradict H.
 apply skipn_nil_length in H; omega.
 intros x l' H0; simpl; f_equal.
 erewrite skipn_hd in H0.
 injection H0.
 intros _ H1.
 symmetry; apply H1.
 omega.
 rewrite <- cons_skipn with (d:=d); trivial; omega.
Qed.

Lemma firstn_seq n start len :
  firstn n (seq start len) = seq start (min n len).
Proof.
 intros; revert n start.
 induction len; simpl; intros.
 rewrite min_r; simpl;[ | omega].
 apply firstn_nil.
 case n; simpl; trivial; congruence.
Qed.

Lemma skipn_seq n start len :
  skipn n (seq start len) = seq (start+n) (len-n).
Proof.
 intros; revert n start.
 induction len; simpl; intros.
 apply skipn_nil; simpl; omega.
 case n; simpl; intros.
 rewrite plus_0_r; trivial.
 rewrite <- plus_Snm_nSm; apply IHlen.
Qed.

Lemma in_seq_iff : forall x len start,
  In x (seq start len) <-> start <= x < start+len.
Proof.
intros x len.
induction len; simpl; intros;[ omega | ].
split.
intros [H | H]; subst; try omega.
assert (S start <= x < S start + len).
rewrite <- IHlen; trivial.
omega.
intro H; rewrite IHlen; omega.
Qed.

Lemma nth_map_cst :
  forall {A B} (l:list A) n (d:B), nth n (map (fun _ => d) l) d = d.
Proof.
intros A B l.
induction l as [ | a l IH]; intros [ | n] d; simpl; trivial.
Qed.

Lemma nth_S_tl A (l : list A) d n :
  nth n (tl l) d = nth (S n) l d.
Proof.
 intros; destruct l; simpl; intros; trivial.
 case n; trivial.
Qed.

Lemma map_ext2 : forall {A B} (f g : A -> B) l,
  (forall a : A, In a l -> f a = g a) -> map f l = map g l.
Proof.
 intros; induction l; simpl; trivial.
 f_equal.
 apply H; simpl; auto.
 apply IHl.
 intros; apply H; simpl; auto.
Qed.

Lemma map_nth2
  (A B : Type) (f : A -> B) (l : list A) b d n :
  (f d) = b ->
  nth n (map f l) b = f (nth n l d).
Proof. intros; rewrite <- H; apply map_nth. Qed.

Lemma length_plus_ex {A} n1 n2 (l : list A):
  length l = n1 + n2 ->
  exists l1, exists l2,
    length l1 = n1 /\ length l2 = n2 /\ l = l1 ++ l2.
Proof.
 intros.
 exists (firstn n1 l).
 exists (skipn n1 l).
 rewrite firstn_length, min_l, length_skipn, firstn_skipn; repeat split; omega.
Qed.

Lemma tl_app : forall A (l1 l2 : list A),
  l1 <> nil ->
  tl (l1 ++ l2) = tl l1 ++ l2.
Proof.
 intros; destruct l1; simpl; trivial.
 elim H; trivial.
Qed.

Lemma map_seq_nth : forall A B (l : list A) (g : A -> B) d,
 map (fun n => g (nth n l d)) (seq 0 (length l)) = map g l.
Proof.
 intros A B l g d.
 change l with (skipn 0 l) at 3.
 rewrite <- map_nth_seq with (len := length l) (d := d).
 rewrite map_map.
 auto.
 auto.
Qed.

Lemma map_seq_shift : forall A m (f : nat -> A) n,
n <> 0 ->
map f (seq 0 m) = map (fun x => f (x - n)%nat) (seq n m).
Proof.
 induction m; simpl; intros; auto.
 f_equal.
 f_equal; omega.
 rewrite <- seq_shift with (start := 0).
 rewrite map_map.
 rewrite IHm with (n := S n).
 apply map_ext2.
 intros; f_equal.
 rewrite in_seq_iff in H0.
 omega.
 omega.
Qed.

Lemma map_seq_nth_safe : forall A B (l : list A) (g : A -> B) d m,
 map (fun n => g (nth (n - m) l d)) (seq m (length l)) = map g l.
Proof.
 intros A B l g d m.
 rewrite <- map_seq_nth with (d := d).
 destruct m; simpl.
 apply map_ext; intros.
 rewrite <- minus_n_O; trivial.
 rewrite map_seq_shift with (n := S m); auto.
Qed.

Lemma seq_app : forall x y z,
  seq x y ++ seq (x + y) z = seq x (y + z).
Proof.
 intros.
 rewrite <- firstn_skipn with (l := seq x (y + z)) (n := y).
 f_equal.
 rewrite firstn_seq.
 rewrite Min.min_l; auto.
 omega.
 rewrite skipn_seq.
 f_equal; omega.
Qed.

Definition andl {A} (P:A->Prop)(l:list A) : Prop :=
  fold_right (fun a res => P a /\ res) True l.

Lemma forall_andl A (P:A->Prop) l :
  (forall x, In x l -> P x) <-> andl P l.
Proof.
 induction l; simpl; intros;[ tauto | ].
 split; intro.
 rewrite <- IHl; auto.
 intros x [H1 | H2]; subst;[ tauto | ].
 apply IHl; tauto.
Qed.

Fixpoint fun_power {A:Type}(n:nat)(f:A->A)(x:A) : A :=
  match n with
  | 0 => x
  | S n' => f (fun_power n' f x)
  end.

Lemma fun_power_minus_S : forall A (f:A->A) x m n,
  m < n -> f (fun_power (n - S m) f x) = fun_power (n - m) f x.
Proof.
 intros A f x m n H.
 replace (n-m) with (S (n - S m)) by omega; trivial.
Qed.

Definition mod2 (n : nat) : nat :=
  n - 2 * div2 n.

Fixpoint power (m n:nat) : nat :=
 match n with
 | 0 => 1
 | S n' => m * power m n'
 end.

Lemma power_le_l : forall a b n, a <= b -> power a n <= power b n.
Proof.
 induction n; simpl; intros; trivial.
 apply mult_le_compat; tauto.
Qed.

Definition plusl (l:list nat) : nat :=
  fold_right plus 0 l.

Lemma plusl_cons : forall x l, plusl (x :: l) = x + plusl l.
Proof. trivial. Qed.

Lemma plusl_app l1 l2 :
  plusl (l1++l2) = plusl l1 + plusl l2.
Proof.
 induction l1; simpl; intros; trivial.
 rewrite IHl1; ring.
Qed.

Lemma plusl_compat : forall A (l : list A) f g,
  (forall x, In x l -> f x <= g x) ->
  plusl (map f l) <= plusl (map g l).
Proof.
 induction l; simpl; intros; auto.
 apply plus_le_compat; auto.
Qed.

Definition multl (l:list nat) : nat :=
  fold_right mult 1 l.

Lemma multl_app l1 l2 :
  multl (l1++l2) = multl l1 * multl l2.
Proof.
 induction l1; simpl; intros; trivial.
 rewrite IHl1; ring.
Qed.

Lemma multl_plus_distr_l n l :
  n * plusl l = plusl (map (fun m => n * m) l).
Proof.
 induction l as [ | m l' IH]; simpl; intros; [ | rewrite <- IH]; ring.
Qed.

Fixpoint maxl l :=
  match l with
    | nil => 0
    | a :: l' => max a (maxl l')
  end.

Lemma in_le_maxl x l : In x l -> x <= maxl l.
Proof.
 induction l; simpl; intros.
 tauto.
 destruct H; subst.
 apply Nat.le_max_l.
 eapply le_trans; [ | apply Nat.le_max_r]; tauto.
Qed.

Lemma maxl_map A l (f : A -> nat) n :
  (forall x, In x l -> f x = n) ->
  maxl (map f l) <= n.
Proof.
 induction l; simpl; intros; trivial.
 omega.
 apply Nat.max_lub.
 rewrite H; auto.
 apply IHl.
 intros; apply H; auto.
Qed.

Lemma maxl_le l e :
  maxl l <= e ->
  (forall x, In x l -> x <= e).
Proof.
 induction l; simpl;[ tauto | intros].
 destruct H0; subst.
 apply Nat.max_lub_l with (maxl l); trivial.
 apply IHl; trivial.
 apply Nat.max_lub_r with a; trivial.
Qed.

Lemma maxl_eq_le l e :
  maxl l = e ->
  (forall x, In x l -> x <= e).
Proof.
 intros.
 apply maxl_le with l; auto.
 rewrite H; auto.
Qed.

Lemma maxl_eq_le3 e1 e2 e3 e :
  maxl [e1; e2; e3] = e ->
  e1 <= e /\ e2 <= e /\ e3 <= e.
Proof.
 intros.
 assert (Hl := maxl_eq_le _ _ H).
 repeat split; apply Hl; simpl; auto.
Qed.

Lemma maxl_le3 e1 e2 e3 e :
  maxl [e1; e2; e3] <= e ->
  e1 <= e /\ e2 <= e /\ e3 <= e.
Proof.
 intros.
 assert (Hl := maxl_le _ _ H).
 repeat split; apply Hl; simpl; auto.
Qed.

Lemma maxl_bound e1 e2 e3 e :
  e1 <= e -> e2 <= e -> e3 <= e ->
  maxl [e1; e2; e3] <= e.
Proof.
 intros.
 simpl.
 apply Nat.max_lub; trivial.
 apply Nat.max_lub; trivial.
 apply Nat.max_lub; trivial.
 omega.
Qed.

Lemma maxl_bound_in l e :
  (forall e', In e' l -> e' <= e) -> maxl l <= e.
Proof.
 induction l; simpl; intros;[ omega | ].
 apply Nat.max_lub.
 apply H; auto.
 apply IHl.
 intros; apply H; auto.
Qed.

Lemma maxl_cons l n : n <= maxl (n :: l).
Proof.
 destruct l; simpl; intros.
 auto with arith.
 apply Nat.le_max_l.
Qed.

Lemma le_maxl_cons l m n :
 n <= maxl l -> n <= maxl (m :: l).
Proof.
 induction l; simpl; intros;[ omega | ].
 eapply le_trans.
 apply Nat.le_max_r.
 apply Nat.max_le_compat_l; trivial.
Qed.

Lemma nth_maxl_bound : forall A (l : list A) (m:A->nat) d i,
  m d = 0 -> m (nth i l d) <= maxl (map m l).
Proof.
intros A l m d.
induction l as [ | a l IH]; intros [ | i] H; simpl.
omega.
omega.
auto with arith.
eapply le_trans.
apply IH.
exact H.
apply Nat.le_max_r.
Qed.

Lemma length_hd_app A (l1 l2 : list (list A)) :
  length (hd nil l1) <= length (hd nil (l1 ++ l2)).
Proof. intros; case l1; simpl; trivial; omega. Qed.

Lemma length_nth_app A (l1 l2 : list (list A)) i :
  length (nth i l1 nil) <= length (nth i (l1 ++ l2) nil).
Proof.
 intros; destruct (le_lt_dec (length l1) i).
 rewrite nth_overflow; simpl; trivial; omega.
 rewrite app_nth1; trivial.
Qed.

Lemma maxl_nth l :
  exists i, maxl l = nth i l 0.
Proof.
 induction l; simpl.
 exists 0; trivial.
 destruct IHl.
 destruct (le_lt_dec a (maxl l)).
 rewrite max_r; trivial.
 exists (S x); trivial.
 exists 0; rewrite max_l; trivial.
 omega.
Qed.

Lemma maxl_map_0 A l (f : A -> nat)  :
  (forall x, In x l -> (f x) = 0) ->
  maxl (map f l) = 0.
Proof.
 induction l; simpl; intros; trivial.
 rewrite H, IHl; simpl; trivial; intros; auto.
Qed.

Lemma maxl_le_plusl : forall l, maxl l <= plusl l.
Proof.
 induction l; trivial; simpl.
 apply Nat.max_lub; omega.
Qed.

Lemma forallb_forall_conv :
  forall A f (l:list A), forallb f l = false <-> (exists x, In x l /\ f x = false).
Proof.
 induction l as [ | x l IH]; simpl; split.
 congruence.
 intros [x H]; tauto.
 intro H.
 apply andb_false_elim in H.
 destruct H as [H | H].
 exists x; tauto.
 rewrite IH in H.
 destruct H as [y H]; exists y; tauto.
 intros [y H].
 apply andb_false_iff.
 destruct H as [ [H1 | H1] H2]; subst; auto.
 right; rewrite IH; exists y; tauto.
Qed.

Lemma forallb_nth : forall A (l : list A) (p : A -> bool) n d,
  p d = true ->
  forallb p l = true ->
  p (nth n l d) = true.
Proof.
 induction l; simpl; intros; case n; trivial; intros;
   rewrite andb_true_iff in H0; [ | apply IHl ]; tauto.
Qed.

Lemma forallb_hd : forall A (l : list A) (p : A -> bool) d,
  forallb p l = true ->
  p d = true ->
  p (hd d l) = true.
Proof.
 destruct l; simpl; intros; trivial.
 rewrite andb_true_iff in H; tauto.
Qed.

Lemma forallb_tl : forall A (l : list A) (p : A -> bool),
  forallb p l = true ->
  forallb p (tail l) = true.
Proof.
 induction l; simpl; intros; trivial.
 rewrite andb_true_iff in H; tauto.
Qed.

Lemma forallb_map : forall A B (l : list A) (p : B -> bool) (f : A -> B),
  (forall x, In x l -> p (f x) = true) ->
  forallb p (map f l) = true.
Proof.
 intros; apply forallb_forall.
 intros.
 apply in_map_iff in H0.
 destruct H0 as ( x' & H0 & H1); subst; auto.
Qed.

Fixpoint repeat {A:Type}(n:nat)(x:A) : list A :=
  match n with
  | 0 => nil
  | S n' => x :: repeat n' x
  end.

Lemma firstn_repeat_le :
  forall A (x:A) m n,
  m <= n ->
  firstn m (repeat n x) = repeat m x.
Proof.
intros A x m.
induction m as [ | m IH]; intros n H.
trivial.
destruct n as [ | n].
contradict H.
omega.
simpl.
f_equal.
apply IH.
omega.
Qed.

Lemma in_repeat_eq : forall A (x y:A) n, In x (repeat n y) -> x=y.
Proof.
 induction n as [ | n IH]; simpl; intro H; [ tauto | ].
 destruct H as [H | H].
 congruence.
 tauto.
Qed.

Lemma map_repeat : forall A B (f:A->B) n x, map f (repeat n x) = repeat n (f x).
Proof.
 induction n as [ | n IH].
 trivial.
 simpl; congruence.
Qed.

Lemma multl_repeat_power : forall n x, multl (repeat n x) = power x n.
Proof. induction n as [ | n IH]; trivial; simpl; congruence. Qed.

Lemma length_repeat : forall A n (x:A), length (repeat n x) = n.
Proof. induction n; simpl; intros; trivial; congruence. Qed.

Lemma nth_repeat :
  forall A n (x:A) d i, i < n ->
  nth i (repeat n x) d = x.
Proof.
 intros A n x d.
 induction n as [ | n IH]; simpl ; intros i H.
 contradict H.
 omega.
 destruct i as [ | i]; auto with arith.
Qed.

Definition move_forward {A}(i j:nat)(l:list A)(d:A) : list A :=
  firstn i l ++ firstn j (skipn (S i) l) ++ (nth i l d :: skipn (S (i+j)) l).

Lemma move_forward_map A B d1 d2 i j (f:A->B) l :
  f d1 = d2 ->
  move_forward i j (map f l) d2 = map f (move_forward i j l d1).
Proof.
 intros; unfold move_forward.
 rewrite !map_app; f_equal.
 rewrite map_firstn; trivial.
 f_equal.
 rewrite map_firstn, map_skipn; trivial.
 rewrite map_nth2 with (d:=d1); trivial.
 rewrite <- map_skipn; trivial.
Qed.

Lemma length_move_forward :
  forall A i j (l:list A) d, i+j < length l -> length (move_forward i j l d) = length l.
Proof.
unfold move_forward.
intros.
do 2 rewrite app_length.
do 2 rewrite firstn_length.
rewrite min_l.
rewrite min_l.
change (length (nth i l d :: skipn (S (i + j)) l)) with (1 + length (skipn (S (i + j)) l)).
rewrite length_skipn.
omega.
rewrite length_skipn.
omega.
omega.
Qed.

Lemma in_move_forward_iff :
  forall A x i j d (l:list A), i < length l -> (In x (move_forward i j l d) <-> In x l).
Proof.
unfold move_forward.
intros A x i j d l Hi.
transitivity (In x (firstn i l ++ nth i l d :: firstn j (skipn (S i) l) ++ skipn (S (i + j)) l)).
split.
apply Permutation_in.
apply Permutation_app_head.
apply Permutation_sym.
apply Permutation_middle.
apply Permutation_in.
apply Permutation_app_head.
apply Permutation_middle.
assert (l = firstn i l ++ nth i l d :: firstn j (skipn (S i) l) ++ skipn (S (i + j)) l) as H.
rewrite <- (firstn_skipn i l) at 1.
f_equal.
transitivity (nth i l d :: skipn (S i) l).
symmetry.
apply cons_skipn.
trivial.
f_equal.
transitivity (firstn j (skipn (S i) l) ++ skipn j (skipn (S i) l)).
rewrite firstn_skipn.
trivial.
f_equal.
rewrite <- skipn_plus.
f_equal.
ring.
rewrite H at 5.
tauto.
Qed.

Lemma firstn_simpl : forall A B (l : list A) (l2 : list B),
 length l2 = length l ->
 firstn (length l2) l = l.
Proof.
 intros.
 rewrite H.
 rewrite <- app_nil_r with (l := l) at 2 .
 rewrite firstn_app.
 trivial.
Qed.

Lemma firstn_app2 : forall (A : Type) (l l' : list A) n,
 length l = n -> firstn n (l ++ l') = l .
Proof. intros; subst; apply firstn_app. Qed.

Lemma firstn_firstn : forall A n (l : list A),
 firstn n (firstn n l) = firstn n l.
Proof.
 induction n; simpl; auto.
 intros [ | a l]; try rewrite IHn; auto.
Qed.

Lemma In_firstn : forall A n a (l : list A),
  In a (firstn n l) -> In a l.
Proof.
 intros A; induction n; simpl; intros.
 elim H.
 destruct l; simpl in *.
 elim H.
 destruct H; subst; auto.
Qed.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Bool.Bool.
From Coq Require Import Strings.String.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Lia.
From Coq Require Import Strings.String.
From Coq Require Import Logic.Eqdep_dec.
From Coq Require Recdef.
From PFPL Require Import PartialMap_Set.

(** E Language *)
Inductive EExp : Type :=
  | ENum (n : nat)
  | EStr (s : string)
  | EId (x : nat)
  | EPlus (e1 e2 : EExp)
  | ETimes (e1 e2 : EExp)
  | ECat (e1 e2 : EExp)
  | ELen (e1 : EExp)
  | ELet (e1 : EExp) (x : nat) (e2: EExp). (* let x = e1 in e2 <=> (lambda e2) e1 *)

(** Depth of an expression (to help us prove the termination of some functions) *)
Fixpoint depth (e: EExp) : nat :=
  match e with
  | EId x => 0
  | ELet e1 x e2 => 1 + max (depth e1) (depth e2)
  | ENum _ => 0
  | EStr _ => 0
  | EPlus e1 e2 => 1 + max (depth e1) (depth e2)
  | ETimes e1 e2 => 1 + max (depth e1) (depth e2)
  | ECat e1 e2 => 1 + max (depth e1) (depth e2)
  | ELen e1 => 1 + depth e1
  end.

(** Returns the set of free variables *)
Fixpoint free_vars (e : EExp) : set :=
  match e with
  | EId x => singletonSet x
  | ELet e1 x e2 => unionSet (free_vars e1) (removeFromSet (free_vars e2) x)
  | ENum n => emptySet
  | EStr s => emptySet
  | EPlus e1 e2 => unionSet (free_vars e1) (free_vars e2)
  | ETimes e1 e2 => unionSet (free_vars e1) (free_vars e2)
  | ECat e1 e2 => unionSet (free_vars e1) (free_vars e2)
  | ELen e1 => free_vars e1
  end.

(** An expression is closed if it does not contain free variables *)
Definition closed (e : EExp) := free_vars e = emptySet.

(** Returns the set of bound variables *)
Fixpoint bound_vars (e : EExp) : set :=
  match e with
  | EId x => emptySet
  | ELet e1 x e2 => unionSet (bound_vars e1) (updateSet (bound_vars e2) x)
  | ENum n => emptySet
  | EStr s => emptySet
  | EPlus e1 e2 => unionSet (bound_vars e1) (bound_vars e2)
  | ETimes e1 e2 => unionSet (bound_vars e1) (bound_vars e2)
  | ECat e1 e2 => unionSet (bound_vars e1) (bound_vars e2)
  | ELen e1 => bound_vars e1
  end.

(** Returns the set of all variables *)
Fixpoint all_vars (e : EExp) : set :=
  match e with
  | EId x => singletonSet x
  | ELet e1 x e2 => unionSet (all_vars e1) (updateSet (all_vars e2) x)
  | ENum n => emptySet
  | EStr s => emptySet
  | EPlus e1 e2 => unionSet (all_vars e1) (all_vars e2)
  | ETimes e1 e2 => unionSet (all_vars e1) (all_vars e2)
  | ECat e1 e2 => unionSet (all_vars e1) (all_vars e2)
  | ELen e1 => all_vars e1
  end.

(** Returns a new variable not present in the expression *)
Fixpoint get_fresh_var (e : EExp) : nat :=
  match e with
  | EId x => S x
  | ELet e1 x e2 => max (get_fresh_var e1) (max (S x) (get_fresh_var e2))
  | ENum n => 0
  | EStr s => 0
  | EPlus e1 e2 => max (get_fresh_var e1) (get_fresh_var e2)
  | ETimes e1 e2 => max (get_fresh_var e1) (get_fresh_var e2)
  | ECat e1 e2 => max (get_fresh_var e1) (get_fresh_var e2)
  | ELen e1 => get_fresh_var e1
  end.

(** Rename one free variable for another *)
Fixpoint rename (e: EExp) (x x': nat) : EExp :=
  match e with
  | EId y => if x =? y then EId x' else EId y
  | ELet e1 y e2 => let e1' := rename e1 x x' in
                    if x =? y then ELet e1' y e2 else ELet e1' y (rename e2 x x')
  | ENum _ => e
  | EStr _ => e
  | EPlus e1 e2 => EPlus (rename e1 x x') (rename e2 x x')
  | ETimes e1 e2 => ETimes (rename e1 x x') (rename e2 x x')
  | ECat e1 e2 => ECat (rename e1 x x') (rename e2 x x')
  | ELen e1 => ELen (rename e1 x x')
  end.

(** Inductive definition of the alpha-equivalence relation *)
Inductive alpha_equiv_rel : EExp -> EExp -> Prop :=
  | alpha_equiv_rel_id : forall x, alpha_equiv_rel (EId x) (EId x)
  | alpha_equiv_rel_let :
    forall e1 x e2 e1' x' e2',
      alpha_equiv_rel e1 e1' ->
      (forall z, (all_vars e2) z = false -> (all_vars e2') z = false ->
      alpha_equiv_rel (rename e2 x z) (rename e2' x' z)) ->
      alpha_equiv_rel (ELet e1 x e2) (ELet e1' x' e2')
  | alpha_equiv_rel_num : forall n, alpha_equiv_rel (ENum n) (ENum n)
  | alpha_equiv_rel_str : forall s s', (eqb s s') = true -> alpha_equiv_rel (EStr s) (EStr s')
  | alpha_equiv_rel_plus : forall e1 e2 e1' e2', alpha_equiv_rel e1 e1' -> alpha_equiv_rel e2 e2' -> alpha_equiv_rel (EPlus e1 e2) (EPlus e1' e2')
  | alpha_equiv_rel_times : forall e1 e2 e1' e2', alpha_equiv_rel e1 e1' -> alpha_equiv_rel e2 e2' -> alpha_equiv_rel (ETimes e1 e2) (ETimes e1' e2')
  | alpha_equiv_rel_cat : forall e1 e2 e1' e2', alpha_equiv_rel e1 e1' -> alpha_equiv_rel e2 e2' -> alpha_equiv_rel (ECat e1 e2) (ECat e1' e2')
  | alpha_equiv_rel_len : forall e1 e1', alpha_equiv_rel e1 e1' -> alpha_equiv_rel (ELen e1) (ELen e1').

(** Auxiliary lemma to prove the termination of the following function *)
Lemma rename_keeps_depth : forall e x x', depth e = depth (rename e x x').
Proof.
  intros. induction e; simpl.
  - reflexivity.
  - reflexivity.
  - case_eq (x =? x0); intros; simpl; reflexivity.
  - f_equal. rewrite IHe1. rewrite IHe2. reflexivity.
  - f_equal. rewrite IHe1. rewrite IHe2. reflexivity.
  - f_equal. rewrite IHe1. rewrite IHe2. reflexivity.
  - f_equal. rewrite IHe. reflexivity.
  - case_eq (x =? x0); intros; simpl.
    + f_equal. rewrite IHe1. rewrite IHe2. reflexivity.
    + f_equal. rewrite IHe1. rewrite IHe2. reflexivity.
Qed.

(** Function to test alpha-equivalence of two expressions *)
Function alpha_equiv (e e' : EExp) {measure depth e} : bool :=
  match e, e' with
  | EId x, EId x' => x =? x'
  | ELet e1 x e2, ELet e1' x' e2' =>
    let z := (max (get_fresh_var e2) (get_fresh_var e2')) in
      alpha_equiv e1 e1' &&
      alpha_equiv (rename e2 x z) (rename e2' x' z)
  | ENum n, ENum n' => n =? n'
  | EStr s, EStr s' => eqb s s'
  | EPlus e1 e2, EPlus e1' e2' => alpha_equiv e1 e1' && alpha_equiv e2 e2'
  | ETimes e1 e2, ETimes e1' e2' => alpha_equiv e1 e1' && alpha_equiv e2 e2'
  | ECat e1 e2, ECat e1' e2' => alpha_equiv e1 e1' && alpha_equiv e2 e2'
  | ELen e1, ELen e1' => alpha_equiv e1 e1'
  | _, _ => false
  end.
Proof.
  intros. simpl. lia.
  intros. simpl. lia.
  intros. simpl. lia.
  intros. simpl. lia.
  intros. simpl. lia.
  intros. simpl. lia.
  intros. simpl. lia.
  intros. simpl.
  rewrite <- (rename_keeps_depth _ x (max (get_fresh_var e2) (get_fresh_var e2'))).
  lia.
  intros. simpl. lia.
Qed.

(** If two expressions have the same structure *)
Inductive same_structure : EExp -> EExp -> Prop :=
  | same_structure_id : forall x x',
      same_structure (EId x) (EId x')
  | same_structure_let : forall e1 x e2 e1' x' e2',
      same_structure e1 e1' -> same_structure e2 e2' -> same_structure (ELet e1 x e2) (ELet e1' x' e2')
  | same_structure_num : forall n n',
      same_structure (ENum n) (ENum n')
  | same_structure_str : forall s s',
      same_structure (EStr s) (EStr s')
  | same_structure_plus : forall e1 e2 e1' e2',
      same_structure e1 e1' -> same_structure e2 e2' -> same_structure (EPlus e1 e2) (EPlus e1' e2')
  | same_structure_times : forall e1 e2 e1' e2',
      same_structure e1 e1' -> same_structure e2 e2' -> same_structure (ETimes e1 e2) (ETimes e1' e2')
  | same_structure_cat : forall e1 e2 e1' e2',
      same_structure e1 e1' -> same_structure e2 e2' -> same_structure (ECat e1 e2) (ECat e1' e2')
  | same_structure_len : forall e1 e1',
      same_structure e1 e1' -> same_structure (ELen e1) (ELen e1').

(** Returns the True proposition if the constructors of the expressions are not the same *)
Function diff_constructor (e e' : EExp) : Prop :=
  match e, e' with
    | ENum _, ENum _ => False
    | EStr _, EStr _ => False
    | EId _, EId _ => False
    | EPlus _ _, EPlus _ _ => False
    | ETimes _ _, ETimes _ _ => False
    | ECat _ _, ECat _ _ => False
    | ELen _, ELen _ => False
    | ELet _ _ _, ELet _ _ _ => False
    | _, _ => True
    end.

(** Give fresh renamining to all bound variables and free variables in [bv] by summing [offset] *)
Fixpoint fresh_rename (e: EExp) (bv: set) (offset: nat) : EExp :=
  match e with
  | EId x => if bv x then EId (x + offset) else EId x
  | ELet e1 x e2 => let e1' := fresh_rename e1 bv offset in
                    let x' := x + offset in
                    let e2' := fresh_rename e2 (updateSet bv x) offset in
                    ELet e1' x' e2'
  | ENum _ => e
  | EStr _ => e
  | EPlus e1 e2 => EPlus (fresh_rename e1 bv offset) (fresh_rename e2 bv offset)
  | ETimes e1 e2 => ETimes (fresh_rename e1 bv offset) (fresh_rename e2 bv offset)
  | ECat e1 e2 => ECat (fresh_rename e1 bv offset) (fresh_rename e2 bv offset)
  | ELen e1 => ELen (fresh_rename e1 bv offset)
  end.

(** Substitution [[e'/x]e] without capture avoidance *)
Fixpoint subst' (e' : EExp) (x : nat) (e : EExp) : EExp :=
  match e with
  | EId y => if x =? y then e' else e
  | ELet e1 y e2 => if x =? y then
                      ELet (subst' e' x e1) y e2
                    else
                      ELet (subst' e' x e1) y (subst' e' x e2)
  | ENum _ => e
  | EStr _ => e
  | EPlus e1 e2 => EPlus (subst' e' x e1) (subst' e' x e2)
  | ETimes e1 e2 => ETimes (subst' e' x e1) (subst' e' x e2)
  | ECat e1 e2 => ECat (subst' e' x e1) (subst' e' x e2)
  | ELen e1 => ELen (subst' e' x e1)
  end.

(** Substitution [[e'/x]e] with capture avoidance *)
Definition subst (e' : EExp) (x : nat) (e : EExp)  : EExp :=
  (* Rename all bound variables in e to avoid free variables in e' *)
  let offset := max (get_fresh_var e) (get_fresh_var e') in
    subst' e' x (fresh_rename e emptySet offset).

(** Types *)
Inductive EType : Type :=
  | TNum
  | TStr.

(** Typing context *)
Definition context := partial_map EType.

(** Empty typing context *)
Definition empty_ctx := @empty EType.

(** Rules of the type system *)
Inductive hastype : context -> EExp -> EType -> Prop :=
  | T_Var : forall Gamma x t, Gamma x = Some(t) -> hastype Gamma (EId x) t
  | T_Str : forall Gamma s, hastype Gamma (EStr s) TStr
  | T_Num : forall Gamma n, hastype Gamma (ENum n) TNum
  | T_Plus : forall Gamma e1 e2, hastype Gamma e1 TNum -> hastype Gamma e2 TNum -> hastype Gamma (EPlus e1 e2) TNum
  | T_Times : forall Gamma e1 e2, hastype Gamma e1 TNum -> hastype Gamma e2 TNum -> hastype Gamma (ETimes e1 e2) TNum
  | T_Cat : forall Gamma e1 e2, hastype Gamma e1 TStr -> hastype Gamma e2 TStr -> hastype Gamma (ECat e1 e2) TStr
  | T_Len : forall Gamma e, hastype Gamma e TStr -> hastype Gamma (ELen e) TNum
  | T_Let : forall Gamma e1 t1 x e2 t2,
              hastype Gamma e1 t1 -> hastype (update Gamma x t1) e2 t2 -> hastype Gamma (ELet e1 x e2) t2.

(** Values of the language *)
Inductive Val : EExp -> Prop :=
  | valNum : forall n, (Val (ENum n))
  | valStr : forall s, (Val (EStr s)).

Definition is_val (e : EExp) : bool :=
  match e with ENum _ | EStr _ => true | _ => false end.

Lemma val_rel_equiv_is_val : forall e,
  Val e <-> is_val e = true.
Proof.
  intro; split; intro.
  - inversion H; subst; simpl; auto.
  - destruct e.
    constructor. constructor.
    all: simpl in H; discriminate.
Qed.

(** Small-step relation *)
Inductive Eval : EExp -> EExp -> Prop :=
  | evalPlus1 : forall n1 n2 n, n = n1 + n2 -> Eval (EPlus (ENum n1) (ENum n2)) (ENum n)
  | evalPlus2 : forall e1 e2 e1', Eval e1 e1' -> Eval (EPlus e1 e2) (EPlus e1' e2)
  | evalPlus3 : forall e1 e2 e2', Val e1 -> Eval e2 e2' -> Eval (EPlus e1 e2) (EPlus e1 e2')
  | evalTimes1 : forall n1 n2 n, n = n1 * n2 -> Eval (ETimes (ENum n1) (ENum n2)) (ENum n)
  | evalTimes2 : forall e1 e2 e1', Eval e1 e1' -> Eval (ETimes e1 e2) (ETimes e1' e2)
  | evalTimes3 : forall e1 e2 e2', Val e1 -> Eval e2 e2' -> Eval (ETimes e1 e2) (ETimes e1 e2')
  | evalCat1 : forall s1 s2 s, s = append s1 s2 -> Eval (ECat (EStr s1) (EStr s2)) (EStr s)
  | evalCat2 : forall e1 e2 e1', Eval e1 e1' -> Eval (ECat e1 e2) (ECat e1' e2)
  | evalCat3 : forall e1 e2 e2', Val e1 -> Eval e2 e2' -> Eval (ECat e1 e2) (ECat e1 e2')
  | evalLen1 : forall n s1, n = length s1 -> Eval (ELen (EStr s1)) (ENum n)
  | evalLen2 : forall e1 e1', Eval e1 e1' -> Eval (ELen e1) (ELen e1')
  | evalLet1 : forall e1 x e2 e1', Eval e1 e1' -> Eval (ELet e1 x e2) (ELet e1' x e2)
  | evalLet2 : forall e1 x e2, Val e1 -> Eval (ELet e1 x e2) (subst e1 x e2).

(** Star relation *)
Inductive EvalStar : EExp -> EExp -> Prop :=
  | star0 : forall e, EvalStar e e
  | starN : forall e e' e'', Eval e e'' -> EvalStar e'' e' -> EvalStar e e'.

(** N-times relation *)
Inductive EvalN : EExp -> EExp -> nat -> Prop :=
  | eval0 : forall e, EvalN e e 0
  | evalN : forall e e' e'' n, Eval e e' -> EvalN e' e'' n -> EvalN e e'' (S n).

(** Based on https://softwarefoundations.cis.upenn.edu/plf-current/StlcProp.html#lab244 *)
Definition stuck e : Prop := (~ exists e', Eval e e') /\ ~ Val e.

(** Big-step relation *)
Inductive EvalBig : EExp -> EExp -> Prop :=
  | evalBigNum : forall n, EvalBig (ENum n) (ENum n)
  | evalBigStr : forall s, EvalBig (EStr s) (EStr s)
  | evalBigPlus : forall e1 e2 n1 n2,
      EvalBig e1 (ENum n1) -> EvalBig e2 (ENum n2) -> EvalBig (EPlus e1 e2) (ENum (n1 + n2))
  | evalBigTimes : forall e1 e2 n1 n2,
      EvalBig e1 (ENum n1) -> EvalBig e2 (ENum n2) -> EvalBig (ETimes e1 e2) (ENum (n1 * n2))
  | evalBigCat : forall e1 e2 s1 s2,
      EvalBig e1 (EStr s1) -> EvalBig e2 (EStr s2) -> EvalBig (ECat e1 e2) (EStr (append s1 s2))
  | evalBigLen : forall e1 s1,
      EvalBig e1 (EStr s1) -> EvalBig (ELen e1) (ENum (length s1))
  | evalBigLet : forall e1 e2 x e1' e2',
      EvalBig e1 e1' -> EvalBig (subst e1' x e2) e2' ->  EvalBig (ELet e1 x e2) e2'.

(** Small-step implementation *)
Fixpoint eval (e : EExp) : option EExp :=
  match e with
  | EId _ | ENum _ | EStr _ => None
  | EPlus e1 e2 =>
    match e1, e2 with
    | ENum n1, ENum n2 => Some (ENum (n1 + n2))
    | _, _ =>
      if is_val e1 then
        match eval e2 with
        | Some e2' => Some (EPlus e1 e2')
        | None => None
        end
      else
        match eval e1 with
        | Some e1' => Some (EPlus e1' e2)
        | None => None
        end
      end
  | ETimes e1 e2 =>
    match e1, e2 with
    | ENum n1, ENum n2 => Some (ENum (n1 * n2))
    | _, _ =>
      if is_val e1 then
        match eval e2 with
        | Some e2' => Some (ETimes e1 e2')
        | None => None
        end
      else
        match eval e1 with
        | Some e1' => Some (ETimes e1' e2)
        | None => None
        end
      end
  | ECat e1 e2 =>
    match e1, e2 with
    | EStr s1, EStr s2 => Some (EStr (append s1 s2))
    | _, _ =>
      if is_val e1 then
        match eval e2 with
        | Some e2' => Some (ECat e1 e2')
        | None => None
        end
      else
        match eval e1 with
        | Some e1' => Some (ECat e1' e2)
        | None => None
        end
      end
  | ELen e1 =>
    match e1 with
    | EStr s1 => Some (ENum (length s1))
    | _ =>
      match eval e1 with
      | Some e1' => Some (ELen e1')
      | None => None
      end
    end
  | ELet e1 x e2 =>
    if is_val e1 then
      Some (subst e1 x e2)
    else
      match eval e1 with
      | Some e1' => Some (ELet e1' x e2)
      | None => None
      end
  end.

(** Function to count the number of subexpressions *)
Fixpoint subexprs_count (e : EExp) : nat :=
  match e with
  | EId _ => 1
  | ELet e1 x e2 => 1 + subexprs_count e1 + subexprs_count e2
  | ENum _ => 1
  | EStr _ => 1
  | EPlus e1 e2 => 1 + subexprs_count e1 + subexprs_count e2
  | ETimes e1 e2 => 1 + subexprs_count e1 + subexprs_count e2
  | ECat e1 e2 => 1 + subexprs_count e1 + subexprs_count e2
  | ELen e1 => 1 + subexprs_count e1
  end.

(** Big-step implementation can be found in the file [Theorems_Eval.v] *)


Require Import Rbase Reals QArith micromega.Lia micromega.Lra.

From BY Require Import Impl.
From BY.Hierarchy Require Import Definitions.

Local Open Scope R_scope.

Ltac assert_pow :=
    repeat match goal with
    | [ |- context[?a ^ 2] ] => match goal with
                               | [ _ : 0 <= a ^ 2 |- _ ] => fail 1
                               | [ |- _ ] =>
                                 assert (0 <= a ^ 2) by (apply pow2_ge_0; nra)
                               end
           end.

Ltac assert_sqrt :=
    repeat match goal with
    | [ |- context[sqrt ?a] ] => match goal with
                               | [ _ : 0 <= sqrt a |- _ ] => fail 1
                               | [ |- _ ] =>
                                 assert (0 <= sqrt a) by (apply sqrt_positivity; nra)
                               end
           end.

Ltac split_pairs :=
  repeat match goal with
         | [ |- context[let '(_, _) := ?b in _] ] => let E := fresh in destruct b eqn:E
         | [ H : context[let '(_, _) := ?b in _] |- _ ] => let E := fresh in destruct b eqn:E
         | [ H : _ /\ _ |- _ ] => destruct H
         | [ H : ?a = ?a |- _ ] => clear H
         | [ H : (?a, ?b) = (?c, ?d) |- _ ] => assert (a = c) by congruence; assert (b = d) by congruence; clear H
         | [ H : (?a, ?b) ≡ ?p |- _ ] => assert (a ≡ p.1) by (inversion H; assumption); assert (b ≡ p.2) by (inversion H; assumption); clear H
         end; subst.

Ltac destruct_ifs :=
  repeat match goal with
         | [ |- context[if ?b then _ else _] ] => let E := fresh in destruct b eqn:E
         end; subst.

Ltac split_pairs2 :=
  repeat match goal with
         | [ |- context[let '(_, _) := ?b in _] ] => let E := fresh in destruct b eqn:E
         | [ H : context[let '(_, _) := ?b in _] |- _ ] => let E := fresh in destruct b eqn:E
         | [ H : _ /\ _ |- _ ] => destruct H
         | [ H : ?a = ?a |- _ ] => clear H
         | [ H : (?a, ?b) = (?c, ?d) |- _ ] => assert (a = c) by congruence; assert (b = d) by congruence; clear H
         end.

Ltac split_pairs_in H :=
  repeat match H with
         | context[let '(_, _) := ?b in _] => let E := fresh in destruct b eqn:E
         end.

(* Ltac rify_all := cbv [ring_op abelian_group_op Rplus_abelian_group_op abelian_group_opp Rmult_ring_op *)
(*                               Ropp_abelian_group_opp abelian_group_id Rzero_abelian_group_id ring_id Rone_ring_id] in *. *)
(* Ltac rify_in H := cbv [ring_op abelian_group_op Rplus_abelian_group_op abelian_group_opp Rmult_ring_op *)
(*                                Ropp_abelian_group_opp abelian_group_id Rzero_abelian_group_id ring_id Rone_ring_id] in H. *)
(* Ltac rify := cbv [ring_op abelian_group_op Rplus_abelian_group_op abelian_group_opp Rmult_ring_op *)
(*                           Ropp_abelian_group_opp abelian_group_id Rzero_abelian_group_id ring_id Rone_ring_id]. *)

Ltac lira :=
  lra +
  (autorewrite with push_izr; try apply lt_IZR; lra) +
  (autorewrite with push_izr; try apply le_IZR; lra) +
  (autorewrite with pull_izr;
       try match goal with
       | [ |- (IZR _ < IZR _)%R ] => try apply IZR_lt
       | [ |- (IZR _ <= IZR _)%R ] => try apply IZR_le
       | [ |- (IZR _ <> IZR _)%R ] => try apply IZR_neq
       end; lia).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall B C K L X : Universe, ((wd_ L B /\ (wd_ X K /\ (wd_ L X /\ (wd_ L C /\ (wd_ K L /\ (wd_ X B /\ (wd_ K C /\ (wd_ B C /\ (col_ K C L /\ (col_ L B C /\ col_ X L B)))))))))) -> col_ X L K)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import ssreflect.
From Tweetnacl.Libs Require Import Export.
From Tweetnacl.Gen Require Import Get_abcdef.
From Tweetnacl.Gen Require Import AMZubSqSel.
From Tweetnacl.Gen Require Import ABCDEF.

Section Montgomery_Rec.

Context {T : Type}.
Context {T' : Type}.
Context {Mod : T -> T}.
Context {O : Ops T T' Mod}.

Open Scope Z.

Local Notation "X + Y" := (A X Y) (only parsing).
Local Notation "X - Y" := (Zub X Y) (only parsing).
Local Notation "X * Y" := (M X Y) (only parsing).
Local Notation "X ^2" := (Sq X) (at level 40,
  only parsing, left associativity).

Fixpoint montgomery_rec (m : nat) (z : T')
(a: T) (b: T) (c: T) (d: T) (e: T) (f: T) (x: T) :
(* a: x2              *)
(* b: x3              *)
(* c: z2              *)
(* d: z3              *)
(* e: temporary  var  *)
(* f: temporary  var  *)
(* x: x1              *)
(T * T * T * T * T * T) :=
match m with
| 0%nat => (a,b,c,d,e,f)
| S n =>
  let r := Getbit (Z.of_nat n) z in
    (* k_t = (k >> t) & 1                            *)
    (* swap <- k_t                                   *)
  let (a, b) := (Sel25519 r a b, Sel25519 r b a) in
    (* (x_2, x_3) = cswap(swap, x_2, x_3)            *)
  let (c, d) := (Sel25519 r c d, Sel25519 r d c) in
    (* (z_2, z_3) = cswap(swap, z_2, z_3)            *)
  let e := a + c in   (* A = x_2 + z_2               *)
  let a := a - c in   (* B = x_2 - z_2               *)
  let c := b + d in   (* C = x_3 + z_3               *)
  let b := b - d in   (* D = x_3 - z_3               *)
  let d := e ^2 in    (* AA = A^2                    *)
  let f := a ^2 in    (* BB = B^2                    *)
  let a := c * a in   (* CB = C * B                  *)
  let c := b * e in   (* DA = D * A                  *)
  let e := a + c in   (* x_3 = (DA + CB)^2           *)
  let a := a - c in   (* z_3 = x_1 * (DA - CB)^2     *)
  let b := a ^2 in    (* z_3 = x_1 * (DA - CB)^2     *)
  let c := d - f in   (* E = AA - BB                 *)
  let a := c * C_121665 in
                      (* z_2 = E * (AA + a24 * E)    *)
  let a := a + d in   (* z_2 = E * (AA + a24 * E)    *)
  let c := c * a in   (* z_2 = E * (AA + a24 * E)    *)
  let a := d * f in   (* x_2 = AA * BB               *)
  let d := b * x in   (* z_3 = x_1 * (DA - CB)^2     *)
  let b := e ^2 in    (* x_3 = (DA + CB)^2           *)
  let (a, b) := (Sel25519 r a b, Sel25519 r b a) in
    (* (x_2, x_3) = cswap(swap, x_2, x_3)            *)
  let (c, d) := (Sel25519 r c d, Sel25519 r d c) in
    (* (z_2, z_3) = cswap(swap, z_2, z_3)            *)
  montgomery_rec n z a b c d e f x
end.

Close Scope Z.

End Montgomery_Rec.


(* 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                                                     *)

Require Export reduce.
Require Export table.
Require Export abstract_machine.

Section SUM_REDUCE.

Variable Data : Set.

Variable s0 : Site.

Let Bag_of_message := Bag_of_Data Data.

Variable f : Data -> Z.

Definition sigma_reduce (bom : Bag_of_message) :=
  sigma Site LS (fun si : Site => reduce Data f (bom s0 si)).

Lemma sigma_reduce_pos :
 forall (s0 s1 : Site) (bom : Bag_of_message),
 (forall m : Data, (f m > 0)%Z) -> (sigma_reduce bom >= 0)%Z.
Proof.
  intros s1 s2 bom H.
  unfold sigma_reduce in |- *.
  apply sigma_pos.
  intro x_.
  apply reduce_positive.
  auto.
Qed.

End SUM_REDUCE.


  Record CTS_spec : Type :=
    {cts_axiom : relation sort;
     cts_rules : sort -> sort -> sort -> Prop;
     universes : relation sort;
     head_reduct : Basic_rule}.

  Variable the_CTS : CTS_spec.

  (* open the_CTS *)
  Let axiom := cts_axiom the_CTS.
  Let rule := cts_rules the_CTS.
  Let univ := universes the_CTS.
  Let hd_rule := head_reduct the_CTS.

  Let hdr := Rule hd_rule.
  Let lifts : R_lift hdr := R_lifts hd_rule.
  Let substs : R_subst hdr := R_substs hd_rule.
  Let stable : R_stable_env hdr := R_stable hd_rule.

  Let red_step := ctxt hdr.

  (* short-cuts *)
  Let stable_conv : R_stable_env (conv hdr).
Proof R_rst_stable red_step (ctxt_stable hdr stable).

  Hint Resolve stable: pts.


(* |- means conclusion *)
Ltac find_if :=
  match goal with
  | [ |- if ?X then _ else _ ] => destruct X
  end.

Theorem hmm : forall (a b c : bool),
  if a
    then if b
      then True
      else True
    else if c
      then True
      else True.
Proof.
  intros;  repeat find_if; reflexivity.
Qed.
(* [repeat] is a tactical aka tactic combinator *)


(* Specific tests about guard condition *)

(* f must unfold to x, not F (de Bruijn mix-up!) *)
Check let x (f:nat->nat) k := f k in
      fun (y z:nat->nat) =>
      let f:=x in (* f := Rel 3 *)
      fix F (n:nat) : nat :=
        match n with
        | 0 => 0
        | S k => f F k (* here Rel 3 = F ! *)
        end.

(** Commutation of guard condition allows recursive calls on functional arguments,
    despite rewriting in their domain types.  *)
Inductive foo : Type -> Type :=
| End A : foo A
| Next A : (A -> foo A) -> foo A.

Definition nat : Type := nat.

Fixpoint bar (A : Type) (e : nat = A) (f : foo A) {struct f} : nat :=
match f with
| End _ => fun _ => O
| Next A g => fun e =>
    match e in (_ = B) return (B -> foo A) -> nat with
    | eq_refl => fun (g' : nat -> foo A) => bar A e (g' O)
    end g
end e.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
Require Import ZArith_ext.
Require Import machine_int.
Import MachineInt.

Require Import multi_int.
Require Import mips_seplog.
Require Import compile.

Local Open Scope multi_int_scope.

Module compile_m := Compile WMIPS_Hoare.

Require Import mont_mul_prg mont_mul_triple.

Definition k := reg_s6.
Definition alpha := reg_s7.
Definition x := reg_a0.
Definition y := reg_a1.
Definition z := reg_a2.
Definition m := reg_a3.

Definition one := reg_t0.
Definition ext := reg_t1.
Definition int_ := reg_t2.
Definition X_ := reg_t3.
Definition Y_ := reg_t4.
Definition M_ := reg_t5.
Definition Z_ := reg_t6.
Definition quot := reg_t7.
Definition C := reg_t8.

Definition t := reg_v0.
Definition s_ := reg_v1.

Lemma Hset : uniq (k :: alpha :: x :: y :: z :: m :: one :: ext :: int_ :: X_ ::
  Y_ :: M_ :: Z_ :: quot :: C :: t :: s_ :: r0 :: nil). Proof. done. Qed.

Section test.

Variable nk : nat.
Variables X Y M : seq (int 32).
Hypothesis Hx : length X = nk.
Hypothesis Hy : length Y = nk.
Hypothesis Hm : length M = nk.
Hypothesis HX : \S_{ nk } X < \S_{ nk } M.
Hypothesis HY : \S_{ nk } Y < \S_{ nk } M.
Variables vx vy vm vz : int 32.
Hypothesis Hnz : u2Z vz + 4 * Z_of_nat nk < Zbeta 1.
Variable valpha : int 32.

Local Open Scope eqmod_scope.
Local Open Scope machine_int_scope.

Hypothesis Halpha : u2Z (M `32_ 0) * u2Z valpha =m -1 {{ Zbeta 1 }}.

(** * Application: Generation of Hoare-logic Proofs from %\while%#While#

   %\label{sec:application}%

   *)

(**
   %\label{sec:montgomery}%

   %As explained in Section \ref{sec:intro}, % in %\cite{affeldt06asian}%#[Affeldt&Marti2006]#,
   we verified in Coq an implementation of the Montgomery multiplication written in the SmartMIPS instruction set.
   We worked on a version of the program where branches were replaced by while-loops and
   while-loops where compiled away by a certified macro-expander afterwards. Strictly speaking, there was
   therefore no Hoare-logic proof for the assembly code to be run.

   The rest of this section shows that one can recover a Hoare-logic proof for the assembly code to be run
   by using the previously formalized theorem %\coqdocvar{preservation\_hoare}%#preservation_hoare#
   %(Section \ref{thm:hoare-triple-preservation})%.

*)

(** %\coqdocvar{montgomery}%#montgomery# is the program with while-loops. We instantiate it with
   a set of registers: *)

Definition mont_mul_cmd : while.cmd := montgomery k alpha x y z m one ext int_ X_ Y_ M_ Z_ quot C t s_.

(** Given a certain set of parameters (concrete initial values to put in registers and in the mutable memory),
   the proof of correctness %\coqdocvar{mont\_mul\_specif}%#mont_mul_triple# gives a proof-term that is the
   proof that the Montgomery multiplication with while-loops is correct. In other words, this is a proof of
   correctness prior to compilation. This is clear when checked with the %\texttt{Check}%#Check# command.*)

Definition mont_mul_cmd_hoare :=
  mont_mul_triple _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hset nk valpha vx vy vm vz X Y M Halpha Hx Hy Hm Hnz HX HY.

Local Open Scope mips_expr_scope.
Import assert_m.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope mips_hoare_scope.

Check mont_mul_cmd_hoare.

(**
%\small\begin{verbatim}
> Check mont_mul_cmd_hoare.
{{fun s h => [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z ([k]_s) = Z_of_nat nk /\ [alpha]_s = valpha /\
  (((var_e x |--> X ** var_e y |--> Y) ** var_e z |--> nseq nk zero32) **
   var_e m |--> M) s h /\
  store.multi_null s}}
montgomery k alpha x y z m one ext int_ X_ Y_ M_ Z_ quot C t s_
{{fun s h => exists Z0, length Z0 = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z ([k]_s) = Z_of_nat nk /\ [alpha]_s = valpha /\
  (((var_e x |--> X ** var_e y |--> Y) ** var_e z |--> Z0) ** var_e m |--> M) s h /\
  (Zbeta nk * \S_{ nk }.+1 (Z0 ++ [C]_s :: nil) =m \S_{ nk } X * \S_{ nk } Y {{\S_{ nk } M}}) /\
  \S_{ nk }.+1 (Z0 ++ [C]_s :: nil) < 2 * \S_{ nk } M /\
  u2Z ([t]_s) = 4 * nz + 4 * Z_of_nat (nk - 1)}}
\end{verbatim}\normalsize%

Now, let us consider %\coqdocvar{mont\_mul\_scode}%#mont_mul_scode#, the Montgomery multiplication with gotos,
obtained by automatically macro-expanding if-then-else's and while-loops and locating the code at
starting label 0
   (using a function corresponding to the %\coqdocvar{compile}%#compile#
   predicate %(see Section \ref{sec:compile})%): *)

Definition mont_mul_scode : compile_m.sgoto_hoare_m.sgoto_m.scode := compile_m.compile_f O mont_mul_cmd.

Set Printing Depth 100.
Eval vm_compute in (compile_m.compile_f O mont_mul_cmd).

Lemma Hcompile : compile_m.compile O mont_mul_cmd mont_mul_scode 38%nat.
Proof.
have <- : (O + size (compile_m.sgoto_hoare_m.sgoto_m.sdom mont_mul_scode) = 38)%nat by vm_compute.
apply compile_m.compile_f_compile.
rewrite /mont_mul_scode.
reflexivity.
Qed.

(** By application of %\coqdocvar{preservation\_hoare}%#preservation_hoare# and given the proof that the
   Montgomery multiplication with while-loops is correct, we obtain a proof-term that is the proof
   that the Montgomery multiplication %{\em% with gotos%}% is correct. Again,
   this can be checked with the %\texttt{Check}%#Check# command:
   the same triple as above is shown to hold, with the additional information that the starting label is 0, and the ending label is 38. *)

Definition mont_mul_sgoto_hoare :=
  compile_m.preservation_hoare _ _ _ mont_mul_cmd_hoare _ _ _ Hcompile.

(**
%\small\begin{verbatim}
> Check mont_mul_sgoto_hoare.
compile_m.sgoto_hoare_m.hoare_sgoto
(fun pc s h0 => pc = /\ (fun s0 h =>
 [x]_s0 = vx /\ [y]_s0 = vy /\ [z]_s0 = vz /\ [m]_s0 = vm /\
 u2Z ([k]_s0) = Z_of_nat nk /\ [alpha]_s0 = valpha /\
 (((var_e x |--> X ** var_e y |--> Y) ** var_e z |--> nseq nk zero32) **
  var_e m |--> M) s0 h /\
 store.multi_null s0) s h0)
mont_mul_scode
(fun pc s h0 => pc = 38 /\ (fun s0 h => exists Z0, length Z0 = nk /\
 [x]_s0 = vx /\ [y]_s0 = vy /\ [z]_s0 = vz /\ [m]_s0 = vm /\
 u2Z ([k]_s0) = Z_of_nat nk /\ [alpha]_s0 = valpha /\
 (((var_e x |--> X ** var_e y |--> Y) ** var_e z |--> Z0) ** var_e m |--> M) s0 h /\
 (Zbeta nk * \S_{ nk }.+1 (Z0 ++ [C]_s0 :: nil) =m \S_{ nk } X * \S_{ nk } Y {{\S_{ nk } M}}) /\
 \S_{ nk }.+1 (Z0 ++ [C]_s0 :: nil) < 2 * \S_{ nk } M /\
 u2Z ([t]_s0) = 4 * nz + 4 * Z_of_nat (nk - 1)) s h0)
\end{verbatim}\normalsize%
*)

End test.