Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.

Inductive insn :=
| Nop
| Arg
| Self
| Deref (off : nat)
| Call
| MkConstr (tag : nat) (nargs : nat)
| Switch (cases : list (list insn))
| MkClose (f : function_name) (nfree : nat)
| OpaqueOp (op : opaque_oper_name) (nargs : nat)
.

Definition env := list (list insn).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    stack : list value
}.

Definition push f v :=
    Frame (arg f) (self f) (v :: stack f).

Definition pop f n :=
    Frame (arg f) (self f) (skipn n (stack f)).

Definition pop_push f n v :=
    push (pop f n) v.

Definition top f :=
    match stack f with
    | [] => Constr 0 []
    | v :: _ => v
    end.

Inductive cont :=
| Kret (code : list insn) (f : frame) (k : cont)
(* keeping the original `stk` lets us enforce that each branch pushes
 * exactly one value before running SContSwitch *)
| Kswitch (code : list insn) (stk : list value) (k : cont)
| Kstop.

Inductive state :=
| Run (i : list insn) (f : frame) (k : cont)
| Stop (v : value).

Inductive sstep (E : env) : state -> state -> Prop :=
| SNop : forall is f k,
        sstep E (Run (Nop :: is) f k)
                (Run is f k)

| SArg : forall is f k,
        sstep E (Run (Arg :: is) f k)
                (Run is (push f (arg f)) k)
| SSelf : forall is f k,
        sstep E (Run (Self :: is) f k)
                (Run is (push f (self f)) k)

| SDerefinateConstr : forall off is f k  tag args v,
        length (stack f) >= 1 ->
        top f = Constr tag args ->
        nth_error args off = Some v ->
        sstep E (Run (Deref off :: is) f k)
                (Run is (pop_push f 1 v) k)
| SDerefinateClose : forall off is f k  fname free v,
        length (stack f) >= 1 ->
        top f = Close fname free ->
        nth_error free off = Some v ->
        sstep E (Run (Deref off :: is) f k)
                (Run is (pop_push f 1 v) k)

| SConstrDone : forall tag nargs is f k,
        length (stack f) >= nargs ->
        sstep E (Run (MkConstr tag nargs :: is) f k)
                (Run is (pop_push f nargs (Constr tag (rev (firstn nargs (stack f))))) k)
| SCloseDone : forall fname nfree is f k,
        length (stack f) >= nfree ->
        sstep E (Run (MkClose fname nfree :: is) f k)
                (Run is (pop_push f nfree (Close fname (rev (firstn nfree (stack f))))) k)
| SOpaqueOpDone : forall op nargs is f k v,
        length (stack f) >= nargs ->
        opaque_oper_denote_higher op (rev (firstn nargs (stack f))) = Some v ->
        sstep E (Run (OpaqueOp op nargs :: is) f k)
                (Run is (pop_push f nargs v) k)

| SMakeCall : forall is f k  fname free body,
        length (stack f) >= 2 ->
        nth_error (stack f) 1 = Some (Close fname free) ->
        nth_error E fname = Some body ->
        sstep E (Run (Call :: is) f k)
                (Run body (Frame (top f) (Close fname free) [])
                    (Kret is (pop f 2) k))

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall cases is f k  tag args case,
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run (Switch cases :: is) f k)
                (Run case f (Kswitch is (stack f) k))

| SContRet : forall code f f' k,
        length (stack f) = 1 ->
        sstep E (Run [] f (Kret code f' k))
                (Run code (push f' (top f)) k)
| SContSwitch : forall code f stk k v,
        stack f = v :: stk ->
        sstep E (Run [] f (Kswitch code stk k))
                (Run code f k)
| SContStop : forall f,
        length (stack f) = 1 ->
        sstep E (Run [] f Kstop)
                (Stop (top f))
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body,
        nth_error (fst prog) fname = Some body ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 Kstop).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition insn_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HNop :     P Nop)
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (i : insn) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        let fix go_list_list iss :=
            match iss as iss_ return Pll iss_ with
            | [] => Hnil2
            | is :: iss => Hcons2 is iss (go_list is) (go_list_list iss)
            end in
        match i as i_ return P i_ with
        | Nop => HNop
        | Arg => HArg
        | Self => HSelf
        | Deref off => HDeref off
        | Call => HCall
        | MkConstr tag nargs => HConstr tag nargs
        | Switch cases => HSwitch cases (go_list_list cases)
        | MkClose fname nfree => HClose fname nfree
        | OpaqueOp op nargs => HOpaqueOp op nargs
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition insn_ind' (P : insn -> Prop)
    (HNop :     P Nop)
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Forall (Forall P) cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (i : insn) : P i :=
    ltac:(refine (@insn_rect_mut P (Forall P) (Forall (Forall P))
        HNop HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp _ _ _ _ i); eauto).

Definition insn_list_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HNop :     P Nop)
    (HArg :     P Arg)
    (HSelf :    P Self)
    (HDeref :   forall off, P (Deref off))
    (HCall :    P Call)
    (HConstr :  forall tag nargs, P (MkConstr tag nargs))
    (HSwitch :  forall cases, Pll cases -> P (Switch cases))
    (HClose :   forall fname nfree, P (MkClose fname nfree))
    (HOpaqueOp : forall op nargs, P (OpaqueOp op nargs))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (is : list insn) : Pl is :=
    let go := insn_rect_mut P Pl Pll
            HNop HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp
            Hnil Hcons Hnil2 Hcons2 in
    let fix go_list is :=
        match is as is_ return Pl is_ with
        | [] => Hnil
        | i :: is => Hcons i is (go i) (go_list is)
        end in go_list is.


Require Import Coq.Strings.String.

Require Import ByteData.
Require Import DiskSubset.
Require Import File.
Require Import FileData.
Require Import FileTypes.
Require Import Tar.

Variable gunzip: File->Disk->File.

Local Open Scope bool.

Definition borland_rootkit (disk: Disk) :=
  exists file: File,
    isOnDisk file disk
    /\ isDeleted file
    /\ isGzip file disk
    /\ Tar.looksLikeRootkit (gunzip file disk) disk.

Definition borland_rootkit_witness (disk: Disk) (file: File):=
  isOnDisk file disk
  /\ isDeleted file
  /\ isGzip file disk
  /\ Tar.looksLikeRootkit (gunzip file disk) disk.

Definition borland_rootkit_witness_param (disk: Disk) (file gunzipped: File):=
  isOnDisk file disk
  /\ isDeleted file
  /\ isGzip file disk
  /\ Tar.looksLikeRootkit gunzipped disk.

Lemma borland_rootkit_witness_impl :
  forall (file: File) (disk: Disk),
    borland_rootkit_witness disk file ->
      borland_rootkit disk.
Proof.
  intros file disk H.
  unfold borland_rootkit_witness in H.
  unfold borland_rootkit.
  exists file. assumption.
Qed.

Lemma borland_rootkit_fsubset :
  forall (gzippedFile gunzipped: File) (disk:Disk),
    gunzipped f⊆ (gunzip gzippedFile disk) ->
      borland_rootkit_witness_param disk gzippedFile gunzipped ->
        borland_rootkit_witness disk gzippedFile.
Proof.
  intros gzippedFile gunzipped disk subset H.
  unfold borland_rootkit_witness_param in H.
  unfold borland_rootkit_witness.
  destruct H as [H0 H]. destruct H as [H1 H]. destruct H as [H2 H].
  split. assumption.
  split. assumption.
  split. assumption.
  apply looksLikeRootkit_fsubset with (1:=subset).
  assumption.
Qed.

Definition borland_compute (disk: Disk) (file gunzipped: File)
  (filename1 filename2: string) :=
  (isOnDisk_compute file disk)
  && file.(deleted)
  && (isGzip_compute file disk)
  (*&& File.eqb gunzipped (gunzip file) *)
  && Tar.looksLikeRootkit_compute gunzipped disk filename1 filename2.

Lemma borland_reflection (disk: Disk)
  (file gunzipped: File) (filename1 filename2: string) :
  borland_compute disk file gunzipped filename1 filename2 = true
    -> (gunzip file disk) = gunzipped
      -> borland_rootkit disk.
Proof.
  intros. unfold borland_compute in H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.

  unfold borland_rootkit. exists file.
  split. apply isOnDisk_reflection. auto.
  split. unfold isDeleted. auto.
  split. apply isGzip_reflection. auto.
  rewrite H0. apply looksLikeRootkit_reflection in H1. auto.
Qed.

Lemma borland_witness_param_reflection:
  forall (disk: Disk) (file gunzipped: File) (filename1 filename2: string),
    borland_compute disk file gunzipped filename1 filename2 = true ->
      borland_rootkit_witness_param disk file gunzipped.
Proof.
  intros. unfold borland_compute in H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.

  unfold borland_rootkit_witness_param.
  split. apply isOnDisk_reflection. auto.
  split. unfold isDeleted. auto.
  split. apply isGzip_reflection. auto.
         apply looksLikeRootkit_reflection in H0. auto.
Qed.

Lemma borland_rootkit_witness_subset:
  forall (sub super: Disk) (gzippedFile gunzipped: File),
    borland_rootkit_witness_param sub gzippedFile gunzipped ->
      sub ⊆ super ->
        gunzipped f⊆ (gunzip gzippedFile super) ->
            borland_rootkit super.
Proof.
  intros sub super gzippedFile gunzipped H subset fsubset.
  unfold borland_rootkit_witness_param in H.
  apply borland_rootkit_witness_impl with (file:=gzippedFile).
  unfold borland_rootkit_witness.
  destruct H as [HonDisk H]. destruct H as [Hdeleted H].
  destruct H as [Hgzip Hlooks].
  split. apply isOnDisk_subset with (1:=subset). assumption.
  split. assumption.
  split. apply isGzip_subset with (1:=subset). assumption.
         apply looksLikeRootkit_subset with (1:=subset) in Hlooks.
         apply looksLikeRootkit_fsubset with (1:=fsubset). assumption.
Qed.


Definition Effect { S : Type } := S -> S.

Definition Predicate { T : Type } := T -> Prop.

Definition Specification { T U : Type } := T -> U -> Prop.

Notation "T >> U" := (@Specification T U) (at level 0).

Inductive Stmt { T : Type } : Type :=
| Void
| Assignment : @Effect T -> @Stmt T
| Seq : @Stmt T -> @Stmt T -> @Stmt T
| If : @Predicate T -> @Stmt T -> @Stmt T -> @Stmt T
| While : @Predicate T -> @Stmt T -> @Stmt T
| Spec : @Specification T T -> @Stmt T
| Block : @Stmt T -> @Stmt T -> @Stmt T.

Definition Skip { T : Type } := @Assignment T (fun s => s).

Fixpoint BlockFree { T : Type } (s : @Stmt T) :=
  match s with
  | Void => True
  | Assignment _ => True
  | Seq S1 S2 => BlockFree S1 /\ BlockFree S2
  | If _ S1 S2 => BlockFree S1 /\ BlockFree S2
  | While _ S1 => BlockFree S1
  | Spec _ => True
  | Block _ _ => False
  end.

Notation "' x := y" := (Assignment (fun x => y)) (at level 50, x pattern, format "' x  :=  y") : stmt_scope.
Notation "x ; y" := (Seq x y) (at level 51, format "'[v' x ; '/' y ']'", right associativity) : stmt_scope.
Notation "'IIf' c 'Then' p 'Else' q 'End'" :=
  (If c p q) (at level 52, format "'[v' IIf  c   Then '/'  p '/' Else '/'  q '/' End ']'") : stmt_scope.
Notation "'IIf' c 'Then' p 'End'" :=
  (If c p Skip) (at level 52, format "'[v' IIf  c  Then  p  End ']'") : stmt_scope.
Notation "'WWhile' c 'Do' p 'Done'" :=
  (While c p) (at level 52, format "'[v' WWhile  c  Do '/'  p '/' Done ']'") : stmt_scope.
Notation "⟨ x ⟩" := (Spec x) (at level 0, format "⟨ x ⟩") : stmt_scope.

Bind Scope stmt_scope with Stmt.


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import List Syntax Derive.
From Coq.ssr Require Import ssreflect.
Require Automaton.
Require Import Alphabet Validator_classes.

Module Make(Import A:Automaton.T).

(** We instantiate some sets/map. **)
Module TerminalComparableM <: ComparableM.
  Definition t := terminal.
  Instance tComparable : Comparable t := _.
End TerminalComparableM.
Module TerminalOrderedType := OrderedType_from_ComparableM TerminalComparableM.
Module StateProdPosComparableM <: ComparableM.
  Definition t := (state*production*nat)%type.
  Instance tComparable : Comparable t := _.
End StateProdPosComparableM.
Module StateProdPosOrderedType :=
  OrderedType_from_ComparableM StateProdPosComparableM.

Module TerminalSet := FSetAVL.Make TerminalOrderedType.
Module StateProdPosMap := FMapAVL.Make StateProdPosOrderedType.

(** Nullable predicate for symbols and list of symbols. **)
Definition nullable_symb (symbol:symbol) :=
  match symbol with
  | NT nt => nullable_nterm nt
  | _ => false
  end.

Definition nullable_word (word:list symbol) :=
  forallb nullable_symb word.

(** First predicate for non terminal, symbols and list of symbols, given as FSets. **)
Definition first_nterm_set (nterm:nonterminal) :=
  fold_left (fun acc t => TerminalSet.add t acc)
    (first_nterm nterm) TerminalSet.empty.

Definition first_symb_set (symbol:symbol) :=
  match symbol with
  | NT nt => first_nterm_set nt
  | T t => TerminalSet.singleton t
  end.

Fixpoint first_word_set (word:list symbol) :=
  match word with
  | [] => TerminalSet.empty
  | t::q =>
    if nullable_symb t then
      TerminalSet.union (first_symb_set t) (first_word_set q)
    else
      first_symb_set t
  end.

(** Small helper for finding the part of an item that is after the dot. **)
Definition future_of_prod prod dot_pos : list symbol :=
  (fix loop n lst :=
    match n with
    | O => lst
    | S x => match loop x lst with [] => [] | _::q => q end
    end)
  dot_pos (rev' (prod_rhs_rev prod)).

(** We build a fast map to store all the items of all the states. **)
Definition items_map (_:unit): StateProdPosMap.t TerminalSet.t :=
  fold_left (fun acc state =>
    fold_left (fun acc item =>
      let key := (state, prod_item item, dot_pos_item item) in
        let data := fold_left (fun acc t => TerminalSet.add t acc)
          (lookaheads_item item) TerminalSet.empty
        in
        let old :=
          match StateProdPosMap.find key acc with
          | Some x => x | None => TerminalSet.empty
          end
        in
        StateProdPosMap.add key (TerminalSet.union data old) acc
    ) (items_of_state state) acc
  ) all_list (StateProdPosMap.empty TerminalSet.t).

(** We need to avoid computing items_map each time we need it. To that
  purpose, we declare a typeclass specifying that some map is equal to
  items_map. *)
Class IsItemsMap m := is_items_map : m = items_map ().

(** Accessor. **)
Definition find_items_map items_map state prod dot_pos : TerminalSet.t :=
  match StateProdPosMap.find (state, prod, dot_pos) items_map with
  | None => TerminalSet.empty
  | Some x => x
  end.

Definition state_has_future state prod (fut:list symbol) (lookahead:terminal) :=
  exists dot_pos:nat,
    fut = future_of_prod prod dot_pos /\
    TerminalSet.In lookahead (find_items_map (items_map ()) state prod dot_pos).

(** Iterator over items. **)
Definition forallb_items items_map (P:state -> production -> nat -> TerminalSet.t -> bool): bool:=
  StateProdPosMap.fold (fun key set acc =>
    match key with (st, p, pos) => (acc && P st p pos set)%bool end
  ) items_map true.

(** Typeclass instances for synthetizing the validator. *)

Instance is_validator_subset S1 S2 :
  IsValidator (TerminalSet.Subset S1 S2) (TerminalSet.subset S1 S2).
Proof. intros ?. by apply TerminalSet.subset_2. Qed.

(* While the specification of the validator always quantify over
   possible lookahead tokens individually, the validator usually
   handles lookahead sets directly instead, for better performances.

   For instance, the validator for [state_has_future], which speaks
   about one single lookahead token is a subset operation:
*)
Lemma is_validator_state_has_future_subset st prod pos lookahead lset im fut :
  TerminalSet.In lookahead lset ->
  fut = future_of_prod prod pos ->
  IsItemsMap im ->
  IsValidator (state_has_future st prod fut lookahead)
              (TerminalSet.subset lset (find_items_map im st prod pos)).
Proof.
  intros ? -> -> HSS%TerminalSet.subset_2. exists pos. split=>//. by apply HSS.
Qed.
(* We do not declare this lemma as an instance, and use [Hint Extern]
   instead, because the typeclass mechanism has trouble instantiating
   some evars if we do not explicitely call [eassumption]. *)
Hint Extern 2 (IsValidator (state_has_future _ _ _ _) _) =>
  eapply is_validator_state_has_future_subset; [eassumption|eassumption || reflexivity|]
: typeclass_instances.

(* As said previously, we manipulate lookahead terminal sets instead of
  lookahead individually. Hence, when we quantify over a lookahead set
  in the specification, we do not do anything in the executable
  validator.

  This instance is used for [non_terminal_closed]. *)
Instance is_validator_forall_lookahead_set lset P b:
  (forall lookahead, TerminalSet.In lookahead lset -> IsValidator (P lookahead) b) ->
  IsValidator (forall lookahead, TerminalSet.In lookahead lset -> P lookahead) b.
Proof. unfold IsValidator. firstorder. Qed.

(* Dually, we sometimes still need to explicitelly iterate over a
  lookahead set. This is what this lemma allows.
  Used only in [end_reduce]. *)
Lemma is_validator_iterate_lset P b lookahead lset :
  TerminalSet.In lookahead lset ->
  IsValidator P (b lookahead) ->
  IsValidator P (TerminalSet.fold (fun lookahead acc =>
    if acc then b lookahead else false) lset true).
Proof.
  intros Hlset%TerminalSet.elements_1 Hval Val. apply Hval.
  revert Val. rewrite TerminalSet.fold_1. generalize true at 1. clear -Hlset.
  induction Hlset as [? l <-%compare_eq|? l ? IH]=> /= b' Val.
  - destruct (b lookahead). by destruct b'. exfalso. by induction l; destruct b'.
  - eauto.
Qed.
Hint Extern 100 (IsValidator _ _) =>
  match goal with
  | H : TerminalSet.In ?lookahead ?lset |- _ =>
    eapply (is_validator_iterate_lset _ (fun lookahead => _) _ _ H); clear H
  end
: typeclass_instances.

(* We often quantify over all the items of all the states of the
   automaton. This lemma and the accompanying [Hint Resolve]
   declaration allow generating the corresponding executable
   validator.

   Note that it turns out that, in all the uses of this pattern, the
   first thing we do for each item is pattern-matching over the
   future. This lemma also embbed this pattern-matching, which makes
   it possible to get the hypothesis [fut' = future_of_prod prod (S pos)]
   in the non-nil branch.

   Moreover, note, again, that while the specification quantifies over
   lookahead terminals individually, the code provides lookahead sets
   instead. *)
Lemma is_validator_forall_items P1 b1 P2 b2 im :
  IsItemsMap im ->

  (forall st prod lookahead lset pos,
      TerminalSet.In lookahead lset ->
      [] = future_of_prod prod pos ->
      IsValidator (P1 st prod lookahead) (b1 st prod pos lset)) ->

  (forall st prod pos lookahead lset s fut',
      TerminalSet.In lookahead lset ->
      fut' = future_of_prod prod (S pos) ->
      IsValidator (P2 st prod lookahead s fut') (b2 st prod pos lset s fut')) ->

  IsValidator (forall st prod fut lookahead,
                  state_has_future st prod fut lookahead ->
                  match fut with
                  | [] => P1 st prod lookahead
                  | s :: fut' => P2 st prod lookahead s fut'
                  end)
              (forallb_items im (fun st prod pos lset =>
                 match future_of_prod prod pos with
                 | [] => b1 st prod pos lset
                 | s :: fut' => b2 st prod pos lset s fut'
                 end)).
Proof.
  intros -> Hval1 Hval2 Val st prod fut lookahead (pos & -> & Hlookahead).
  rewrite /forallb_items StateProdPosMap.fold_1 in Val.
  assert (match future_of_prod prod pos with
          | [] => b1 st prod pos (find_items_map (items_map ()) st prod pos)
          | s :: fut' => b2 st prod pos (find_items_map (items_map ()) st prod pos) s fut'
          end = true).
  - unfold find_items_map in *.
    assert (Hfind := @StateProdPosMap.find_2 _ (items_map ()) (st, prod, pos)).
    destruct StateProdPosMap.find as [lset|]; [|by edestruct (TerminalSet.empty_1); eauto].
    specialize (Hfind _ eq_refl). apply StateProdPosMap.elements_1 in Hfind.
    revert Val. generalize true at 1.
    induction Hfind as [[? ?] l [?%compare_eq ?]|??? IH]=>?.
    + simpl in *; subst.
      match goal with |- _ -> ?X = true => destruct X end; [done|].
      rewrite Bool.andb_false_r. clear. induction l as [|[[[??]?]?] l IH]=>//.
    + apply IH.
  - destruct future_of_prod eqn:EQ. by eapply Hval1; eauto.
    eapply Hval2 with (pos := pos); eauto; [].
    revert EQ. unfold future_of_prod=>-> //.
Qed.
(* We need a hint for expplicitely instantiating b1 and b2 with lambdas. *)
Hint Extern 0 (IsValidator
                 (forall st prod fut lookahead,
                     state_has_future st prod fut lookahead -> _)
                 _) =>
    eapply (is_validator_forall_items _ (fun st prod pos lset => _)
                                      _ (fun st prod pos lset s fut' => _))
  : typeclass_instances.

(* Used in [start_future] only. *)
Instance is_validator_forall_state_has_future im st prod :
  IsItemsMap im ->
  IsValidator
    (forall look, state_has_future st prod (rev' (prod_rhs_rev prod)) look)
    (let lookaheads := find_items_map im st prod 0 in
     forallb (fun t => TerminalSet.mem t lookaheads) all_list).
Proof.
  move=> -> /forallb_forall Val look.
  specialize (Val look (all_list_forall _)). exists 0. split=>//.
  by apply TerminalSet.mem_2.
Qed.

(** * Validation for completeness **)

(** The nullable predicate is a fixpoint : it is correct. **)
Definition nullable_stable :=
  forall p:production,
    if nullable_word (prod_rhs_rev p) then
      nullable_nterm (prod_lhs p) = true
    else True.

(** The first predicate is a fixpoint : it is correct. **)
Definition first_stable:=
  forall (p:production),
    TerminalSet.Subset (first_word_set (rev' (prod_rhs_rev p)))
                       (first_nterm_set (prod_lhs p)).

(** The initial state has all the S=>.u items, where S is the start non-terminal **)
Definition start_future :=
  forall (init:initstate) (p:production),
    prod_lhs p = start_nt init ->
  forall (t:terminal),
    state_has_future init p (rev' (prod_rhs_rev p)) t.

(** If a state contains an item of the form A->_.av[[b]], where a is a
    terminal, then reading an a does a [Shift_act], to a state containing
    an item of the form A->_.v[[b]]. **)
Definition terminal_shift :=
  forall (s1:state) prod fut lookahead,
    state_has_future s1 prod fut lookahead ->
    match fut with
    | T t::q =>
      match action_table s1 with
      | Lookahead_act awp =>
        match awp t with
        | Shift_act s2 _ =>
          state_has_future s2 prod q lookahead
        | _ => False
        end
      | _ => False
      end
    | _ => True
    end.

(** If a state contains an item of the form A->_.[[a]], then either we do a
    [Default_reduce_act] of the corresponding production, either a is a
    terminal (ie. there is a lookahead terminal), and reading a does a
    [Reduce_act] of the corresponding production. **)
Definition end_reduce :=
  forall (s:state) prod fut lookahead,
    state_has_future s prod fut lookahead ->
    match fut with
    | [] =>
      match action_table s with
      | Default_reduce_act p => p = prod
      | Lookahead_act awt =>
        match awt lookahead with
        | Reduce_act p => p = prod
        | _ => False
        end
      end
    | _ => True
    end.

Definition is_end_reduce items_map :=
  forallb_items items_map (fun s prod pos lset =>
    match future_of_prod prod pos with
    | [] =>
      match action_table s with
      | Default_reduce_act p => compare_eqb p prod
      | Lookahead_act awt =>
        TerminalSet.fold (fun lookahead acc =>
          match awt lookahead with
          | Reduce_act p => (acc && compare_eqb p prod)%bool
          | _ => false
          end) lset true
      end
    | _ => true
    end).

(** If a state contains an item of the form A->_.Bv[[b]], where B is a
    non terminal, then the goto table says we have to go to a state containing
    an item of the form A->_.v[[b]]. **)
Definition non_terminal_goto :=
  forall (s1:state) prod fut lookahead,
    state_has_future s1 prod fut lookahead ->
    match fut with
    | NT nt::q =>
      match goto_table s1 nt with
      | Some (exist _ s2 _) =>
        state_has_future s2 prod q lookahead
      | None => False
      end
    | _ => True
    end.

Definition start_goto :=
  forall (init:initstate),
    match goto_table init (start_nt init) with
    | None => True
    | Some _ => False
    end.

(** Closure property of item sets : if a state contains an item of the form
    A->_.Bv[[b]], then for each production B->u and each terminal a of
    first(vb), the state contains an item of the form B->_.u[[a]] **)
Definition non_terminal_closed :=
  forall s1 prod fut lookahead,
    state_has_future s1 prod fut lookahead ->
    match fut with
    | NT nt::q =>
      forall p, prod_lhs p = nt ->
        (if nullable_word q then
           state_has_future s1 p (future_of_prod p 0) lookahead
         else True) /\
        (forall lookahead2,
           TerminalSet.In lookahead2 (first_word_set q) ->
             state_has_future s1 p (future_of_prod p 0) lookahead2)
      | _ => True
    end.

(** The automaton is complete **)
Definition complete :=
  nullable_stable /\ first_stable /\ start_future /\ terminal_shift
  /\ end_reduce /\ non_terminal_goto /\ start_goto /\ non_terminal_closed.

Derive is_complete_0
SuchThat (forall im, IsItemsMap im -> IsValidator complete (is_complete_0 im))
As complete_0_is_validator.
Proof. intros im. subst is_complete_0. instantiate (1:=fun im => _). apply _. Qed.

Definition is_complete (_:unit) := is_complete_0 (items_map ()).
Lemma complete_is_validator : IsValidator complete (is_complete ()).
Proof. by apply complete_0_is_validator. Qed.

End Make.


(*********************************************************************************************************************************)
(* HaskProofToStrong: convert HaskProof to HaskStrong                                                                            *)
(*********************************************************************************************************************************)

Generalizable All Variables.
Require Import Preamble.
Require Import General.
Require Import NaturalDeduction.
Require Import NaturalDeductionContext.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Init.Specif.
Require Import HaskKinds.
Require Import HaskStrongTypes.
Require Import HaskStrong.
Require Import HaskProof.

Section HaskProofToStrong.

  Context {VV:Type} {eqdec_vv:EqDecidable VV} {freshM:FreshMonad VV}.

  Definition fresh := FMT_fresh freshM.
  Definition FreshM := FMT freshM.
  Definition FreshMon := FMT_Monad freshM.
  Existing Instance FreshMon.

  Definition ExprVarResolver Γ := VV -> LeveledHaskType Γ ★.

  Definition judg2exprType (j:Judg) : Type :=
    match j with
      (Γ > Δ > Σ |- τ @ l) => forall (ξ:ExprVarResolver Γ) vars, Σ = mapOptionTree ξ vars ->
        FreshM (ITree _ (fun t => Expr Γ Δ ξ t l) τ)
      end.

  Definition justOne Γ Δ ξ τ l : ITree _ (fun t => Expr Γ Δ ξ t l) [τ] -> Expr Γ Δ ξ τ l.
    intros.
    inversion X; auto.
    Defined.

  Definition ileaf `(it:ITree X F [t]) : F t.
    inversion it.
    apply X0.
    Defined.

  Lemma update_branches : forall Γ (ξ:VV -> LeveledHaskType Γ ★) lev l1 l2 q,
    update_xi ξ lev (app l1 l2) q = update_xi (update_xi ξ lev l2) lev l1 q.
    intros.
    induction l1.
      reflexivity.
      simpl.
      destruct a; simpl.
      rewrite IHl1.
      reflexivity.
      Qed.

   Lemma quark {T} (l1:list T) l2 vf :
      (In vf (app l1 l2)) <->
       (In vf l1) \/ (In vf l2).
     induction l1.
     simpl; auto.
     split; intro.
     right; auto.
     inversion H.
     inversion H0.
     auto.
     split.

     destruct IHl1.
     simpl in *.
     intro.
     destruct H1.
     left; left; auto.
     set (H H1) as q.
     destruct q.
     left; right; auto.
     right; auto.
     simpl.

     destruct IHl1.
     simpl in *.
     intro.
     destruct H1.
     destruct H1.
     left; auto.
     right; apply H0; auto.
     right; apply H0; auto.
   Qed.

  Lemma splitter {T} (l1:list T) l2 vf :
      (In vf (app l1 l2) → False)
      -> (In vf l1 → False)  /\ (In vf l2 → False).
    intros.
    split; intros; apply H; rewrite quark.
    auto.
    auto.
    Qed.

  Lemma helper
    : forall T Z {eqdt:EqDecidable T}(tl:Tree ??T)(vf:T) ξ (q:Z),
      (In vf (leaves tl) -> False) ->
      mapOptionTree (fun v' => if eqd_dec vf v' then q else ξ v') tl =
      mapOptionTree ξ tl.
    intros.
    induction tl;
      try destruct a;
        simpl in *.
    set (eqd_dec vf t) as x in *.
    destruct x.
    subst.
      assert False.
      apply H.
      left; auto.
      inversion H0.
    auto.
    auto.
    apply splitter in H.
    destruct H.
    rewrite (IHtl1 H).
    rewrite (IHtl2 H0).
    reflexivity.
    Qed.

  Lemma fresh_lemma'' Γ
    : forall types ξ lev,
    FreshM { varstypes : _
      |  mapOptionTree (update_xi(Γ:=Γ)   ξ lev (leaves varstypes)) (mapOptionTree (@fst _ _) varstypes) = (types @@@ lev)
      /\ distinct (leaves (mapOptionTree (@fst _ _) varstypes)) }.
  admit.
  Defined.

  Lemma fresh_lemma' Γ
    : forall types vars Σ ξ lev, Σ = mapOptionTree ξ vars ->
    FreshM { varstypes : _
      |  mapOptionTree (update_xi(Γ:=Γ) ξ lev (leaves varstypes)) vars = Σ
      /\ mapOptionTree (update_xi       ξ lev (leaves varstypes)) (mapOptionTree (@fst _ _) varstypes) = (types @@@ lev)
      /\ distinct (leaves (mapOptionTree (@fst _ _) varstypes)) }.
    induction types.
      intros; destruct a.
        refine (bind vf = fresh (leaves vars) ; return _).
          apply FreshMon.
          destruct vf as [ vf vf_pf ].
          exists [(vf,h)].
          split; auto.
          simpl.
          set (helper VV _ vars vf ξ (h@@lev) vf_pf) as q.
          rewrite q.
          symmetry; auto.
          simpl.
          destruct (eqd_dec vf vf); [ idtac | set (n (refl_equal _)) as n'; inversion n' ]; auto.
          split; auto.
          apply distinct_cons.
          intro.
          inversion H0.
          apply distinct_nil.
        refine (return _).
          exists []; auto.
          split.
          simpl.
          symmetry; auto.
          split.
          simpl.
          reflexivity.
          simpl.
          apply distinct_nil.
        intros vars Σ ξ lev pf; refine (bind x2 = IHtypes2 vars Σ ξ lev pf; _).
          apply FreshMon.
          destruct x2 as [vt2 [pf21 [pf22 pfdist]]].
          refine (bind x1 = IHtypes1 (vars,,(mapOptionTree (@fst _ _) vt2)) (Σ,,(types2@@@lev)) (update_xi ξ lev
            (leaves vt2)) _ _; return _).
          apply FreshMon.
          simpl.
          rewrite pf21.
          rewrite pf22.
          reflexivity.
          clear IHtypes1 IHtypes2.
          destruct x1 as [vt1 [pf11 pf12]].
          exists (vt1,,vt2); split; auto.

          set (update_branches Γ ξ lev (leaves vt1) (leaves vt2)) as q.
          set (mapOptionTree_extensional _ _ q) as q'.
          rewrite q'.
          clear q' q.
          inversion pf11.
          reflexivity.

          simpl.
          set (update_branches Γ ξ lev (leaves vt1) (leaves vt2)) as q.
          set (mapOptionTree_extensional _ _ q) as q'.
          rewrite q'.
          rewrite q'.
          clear q' q.
          rewrite <- mapOptionTree_compose.
          rewrite <- mapOptionTree_compose.
          rewrite <- mapOptionTree_compose in *.
          split.
          destruct pf12.
          rewrite H.
          inversion pf11.
          rewrite <- mapOptionTree_compose.
          reflexivity.

          admit.
        Defined.

  Lemma fresh_lemma Γ ξ vars Σ Σ' lev
    : Σ = mapOptionTree ξ vars ->
    FreshM { vars' : _
      |  mapOptionTree (update_xi(Γ:=Γ) ξ lev ((vars',Σ')::nil)) vars = Σ
      /\ mapOptionTree (update_xi ξ lev ((vars',Σ')::nil)) [vars'] = [Σ' @@ lev] }.
    intros.
    set (fresh_lemma' Γ [Σ'] vars Σ ξ lev H) as q.
    refine (q >>>= fun q' => return _).
    apply FreshMon.
    clear q.
    destruct q' as [varstypes [pf1 [pf2 pfdist]]].
    destruct varstypes; try destruct o; try destruct p; simpl in *.
      destruct (eqd_dec v v); [ idtac | set (n (refl_equal _)) as n'; inversion n' ].
      inversion pf2; subst.
      exists v.
      destruct (eqd_dec v v); [ idtac | set (n (refl_equal _)) as n'; inversion n' ].
      split; auto.
      inversion pf2.
      inversion pf2.
    Defined.

  Definition ujudg2exprType Γ (ξ:ExprVarResolver Γ)(Δ:CoercionEnv Γ) Σ τ l : Type :=
    forall vars, Σ = mapOptionTree ξ vars -> FreshM (ITree _ (fun t => Expr Γ Δ ξ t l) τ).

  Definition urule2expr  : forall Γ Δ h j t l (r:@Arrange _ h j) (ξ:VV -> LeveledHaskType Γ ★),
    ujudg2exprType Γ ξ Δ h t l ->
    ujudg2exprType Γ ξ Δ j t l
    .
    intros Γ Δ.
      refine (fix urule2expr h j t l (r:@Arrange _ h j) ξ {struct r} :
    ujudg2exprType Γ ξ Δ h t l ->
    ujudg2exprType Γ ξ Δ j t l :=
        match r as R in Arrange H C return
    ujudg2exprType Γ ξ Δ H t l ->
    ujudg2exprType Γ ξ Δ C t l
 with
          | ALeft   h c ctx r => let case_ALeft  := tt in (fun e => _) (urule2expr _ _ _ _ r)
          | ARight  h c ctx r => let case_ARight := tt in (fun e => _) (urule2expr _ _ _ _ r)
          | AId     a       => let case_AId    := tt in _
          | ACanL   a       => let case_ACanL  := tt in _
          | ACanR   a       => let case_ACanR  := tt in _
          | AuCanL  a       => let case_AuCanL := tt in _
          | AuCanR  a       => let case_AuCanR := tt in _
          | AAssoc  a b c   => let case_AAssoc := tt in _
          | AuAssoc  a b c   => let case_AuAssoc := tt in _
          | AExch   a b     => let case_AExch  := tt in _
          | AWeak   a       => let case_AWeak  := tt in _
          | ACont   a       => let case_ACont  := tt in _
          | AComp   a b c f g => let case_AComp  := tt in (fun e1 e2 => _) (urule2expr _ _ _ _ f) (urule2expr _ _ _ _ g)
          end); clear urule2expr; intros.

      destruct case_AId.
        apply X.

      destruct case_ACanL.
        simpl; unfold ujudg2exprType; intros.
        simpl in X.
        apply (X ([],,vars)).
        simpl; rewrite <- H; auto.

      destruct case_ACanR.
        simpl; unfold ujudg2exprType; intros.
        simpl in X.
        apply (X (vars,,[])).
        simpl; rewrite <- H; auto.

      destruct case_AuCanL.
        simpl; unfold ujudg2exprType; intros.
        destruct vars; try destruct o; inversion H.
        simpl in X.
        apply (X vars2); auto.

      destruct case_AuCanR.
        simpl; unfold ujudg2exprType; intros.
        destruct vars; try destruct o; inversion H.
        simpl in X.
        apply (X vars1); auto.

      destruct case_AAssoc.
        simpl; unfold ujudg2exprType; intros.
        simpl in X.
        destruct vars; try destruct o; inversion H.
        destruct vars1; try destruct o; inversion H.
        apply (X (vars1_1,,(vars1_2,,vars2))).
        subst; auto.

      destruct case_AuAssoc.
        simpl; unfold ujudg2exprType; intros.
        simpl in X.
        destruct vars; try destruct o; inversion H.
        destruct vars2; try destruct o; inversion H.
        apply (X ((vars1,,vars2_1),,vars2_2)).
        subst; auto.

      destruct case_AExch.
        simpl; unfold ujudg2exprType ; intros.
        simpl in X.
        destruct vars; try destruct o; inversion H.
        apply (X (vars2,,vars1)).
        inversion H; subst; auto.

      destruct case_AWeak.
        simpl; unfold ujudg2exprType; intros.
        simpl in X.
        apply (X []).
        auto.

      destruct case_ACont.
        simpl; unfold ujudg2exprType ; intros.
        simpl in X.
        apply (X (vars,,vars)).
        simpl.
        rewrite <- H.
        auto.

      destruct case_ALeft.
        intro vars; unfold ujudg2exprType; intro H.
        destruct vars; try destruct o; inversion H.
        apply (fun q => e ξ q vars2 H2).
        clear r0 e H2.
          simpl in X.
          simpl.
          unfold ujudg2exprType.
          intros.
          apply X with (vars:=vars1,,vars).
          rewrite H0.
          rewrite H1.
          simpl.
          reflexivity.

      destruct case_ARight.
        intro vars; unfold ujudg2exprType; intro H.
        destruct vars; try destruct o; inversion H.
        apply (fun q => e ξ q vars1 H1).
        clear r0 e H2.
          simpl in X.
          simpl.
          unfold ujudg2exprType.
          intros.
          apply X with (vars:=vars,,vars2).
          rewrite H0.
          inversion H.
          simpl.
          reflexivity.

      destruct case_AComp.
        apply e2.
        apply e1.
        apply X.
        Defined.

  Definition letrec_helper Γ Δ l (varstypes:Tree ??(VV * HaskType Γ ★)) ξ' :
    ITree (HaskType Γ ★)
         (fun t : HaskType Γ ★ => Expr Γ Δ ξ' t l)
         (mapOptionTree (unlev ○ ξ' ○ (@fst _ _)) varstypes)
         -> ELetRecBindings Γ Δ ξ' l varstypes.
    intros.
    induction varstypes.
    destruct a; simpl in *.
    destruct p.
    simpl.
    apply ileaf in X. simpl in X.
      apply ELR_leaf.
      rename h into τ.
      destruct (eqd_dec (unlev (ξ' v)) τ).
      rewrite <- e.
      destruct (ξ' v).
      simpl.
      destruct (eqd_dec h0 l).
        rewrite <- e0.
        simpl in X.
        subst.
        apply X.
      apply (Prelude_error "level mismatch; should never happen").
      apply (Prelude_error "letrec type mismatch; should never happen").

    apply ELR_nil.
    apply ELR_branch.
      apply IHvarstypes1; inversion X; auto.
      apply IHvarstypes2; inversion X; auto.
    Defined.

  Definition unindex_tree {V}{F} : forall {t:Tree ??V}, ITree V F t -> Tree ??{ v:V & F v }.
    refine (fix rec t it := match it as IT return Tree ??{ v:V & F v } with
      | INone => T_Leaf None
      | ILeaf x y => T_Leaf (Some _)
      | IBranch _ _ b1 b2 => (rec _ b1),,(rec _ b2)
            end).
    exists x; auto.
    Defined.

  Definition fix_indexing X Y (J:X->Type)(t:Tree ??(X*Y))
    :  ITree (X * Y) (fun x => J (fst x))                                t
    -> ITree X       (fun x:X => J x)   (mapOptionTree (@fst _ _) t).
    intro it.
    induction it; simpl in *.
    apply INone.
    apply ILeaf.
    apply f.
    simpl; apply IBranch; auto.
    Defined.

  Definition fix2 {X}{F} : Tree ??{ x:X & FreshM (F x) } -> Tree ??(FreshM { x:X & F x }).
    refine (fix rec t := match t with
      | T_Leaf None => T_Leaf None
      | T_Leaf (Some x) => T_Leaf (Some _)
      | T_Branch b1 b2 => T_Branch (rec b1) (rec b2)
            end).
    destruct x as [x fx].
    refine (bind fx' = fx ; return _).
    apply FreshMon.
    exists x.
    apply fx'.
    Defined.

  Definition case_helper tc Γ Δ lev tbranches avars ξ :
    forall pcb:(StrongAltCon * Tree ??(LeveledHaskType Γ ★)),
     prod (judg2exprType (@pcb_judg tc Γ Δ lev tbranches avars (fst pcb) (snd pcb)))
     {vars' : Tree ??VV & (snd pcb) = mapOptionTree ξ vars'} ->
     ((fun sac => FreshM
       { scb : StrongCaseBranchWithVVs VV eqdec_vv tc avars sac
         & Expr (sac_gamma sac Γ) (sac_delta sac Γ avars (weakCK'' Δ)) (scbwv_xi scb ξ lev)
         (weakT' tbranches) (weakL' lev) }) (fst pcb)).
    intro pcb.
    intro X.
    simpl in X.
    simpl.
    destruct pcb as [sac pcb].
    simpl in *.

    destruct X.
    destruct s as [vars vars_pf].

    refine (bind localvars = fresh_lemma' _ (unleaves  (vec2list (sac_types sac _ avars))) vars
      (mapOptionTree weakLT' pcb) (weakLT' ○ ξ) (weakL' lev) _  ; _).
      apply FreshMon.
      rewrite vars_pf.
      rewrite <- mapOptionTree_compose.
      reflexivity.
      destruct localvars as [localvars [localvars_pf1 [localvars_pf2 localvars_dist ]]].
      set (mapOptionTree (@fst _ _) localvars) as localvars'.

    set (list2vec (leaves localvars')) as localvars''.
    cut (length (leaves localvars') = sac_numExprVars sac). intro H''.
      rewrite H'' in localvars''.
    cut (distinct (vec2list localvars'')). intro H'''.
    set (@Build_StrongCaseBranchWithVVs _ _ _ _ avars sac localvars'' H''') as scb.

    refine (bind q = (f (scbwv_xi scb ξ lev) (vars,,(unleaves (vec2list (scbwv_exprvars scb)))) _) ; return _).
      apply FreshMon.
      simpl.
      unfold scbwv_xi.
      rewrite vars_pf.
      rewrite <- mapOptionTree_compose.
      clear localvars_pf1.
      simpl.
      rewrite mapleaves'.

    admit.

    exists scb.
    apply ileaf in q.
    apply q.

    admit.
    admit.
    Defined.

  Definition gather_branch_variables
    Γ Δ
    (ξ:VV -> LeveledHaskType Γ ★) tc avars tbranches lev
    (alts:Tree ??(@StrongAltCon tc * Tree ??(LeveledHaskType Γ ★)))
    :
    forall vars,
    mapOptionTreeAndFlatten (fun x => snd x) alts = mapOptionTree ξ vars
    -> ITree Judg judg2exprType (mapOptionTree (fun x => @pcb_judg tc Γ Δ lev avars tbranches (fst x) (snd x)) alts)
    -> ITree _ (fun q => prod (judg2exprType (@pcb_judg tc Γ Δ lev avars tbranches (fst q) (snd q)))
      { vars' : _ & (snd q) = mapOptionTree ξ vars' })
  alts.
    induction alts;
    intro vars;
    intro pf;
    intro source.
    destruct a; [ idtac | apply INone ].
    simpl in *.
    apply ileaf in source.
    apply ILeaf.
    destruct p as [sac pcb].
    simpl in *.
    split.
    intros.
    eapply source.
    apply H.
    clear source.

    exists vars.
    auto.

    simpl in pf.
    destruct vars; try destruct o; simpl in pf; inversion pf.
    simpl in source.
    inversion source.
    subst.
    apply IBranch.
    apply (IHalts1 vars1 H0 X); auto.
    apply (IHalts2 vars2 H1 X0); auto.

    Defined.

  Lemma manyFresh : forall Γ Σ (ξ0:VV -> LeveledHaskType Γ ★),
    FreshM { vars : _ & { ξ : VV -> LeveledHaskType Γ ★ & Σ = mapOptionTree ξ vars } }.
    intros Γ Σ.
    induction Σ; intro ξ.
    destruct a.
    destruct l as [τ l].
    set (fresh_lemma' Γ [τ] [] [] ξ l (refl_equal _)) as q.
    refine (q >>>= fun q' => return _).
    apply FreshMon.
    clear q.
    destruct q' as [varstypes [pf1 [pf2 distpf]]].
    exists (mapOptionTree (@fst _ _) varstypes).
    exists (update_xi ξ l (leaves varstypes)).
    symmetry; auto.
    refine (return _).
    exists [].
    exists ξ; auto.
    refine (bind f1 = IHΣ1 ξ ; _).
    apply FreshMon.
    destruct f1 as [vars1 [ξ1 pf1]].
    refine (bind f2 = IHΣ2 ξ1 ; _).
    apply FreshMon.
    destruct f2 as [vars2 [ξ2 pf22]].
    refine (return _).
    exists (vars1,,vars2).
    exists ξ2.
    simpl.
    rewrite pf22.
    rewrite pf1.
    admit.         (* freshness assumption *)
    Defined.

  Definition rlet Γ Δ Σ₁ Σ₂ σ₁ σ₂ p :
    forall (X_ : ITree Judg judg2exprType
         ([Γ > Δ > Σ₁ |- [σ₁] @ p],, [Γ > Δ > [σ₁ @@  p],, Σ₂ |- [σ₂] @ p])),
   ITree Judg judg2exprType [Γ > Δ > Σ₁,, Σ₂ |- [σ₂] @ p].
    intros.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.

    refine (fresh_lemma _ ξ _ _ σ₁ p H2 >>>= (fun pf => _)).
    apply FreshMon.

    destruct pf as [ vnew [ pf1 pf2 ]].
    set (update_xi ξ p (((vnew, σ₁ )) :: nil)) as ξ' in *.
    inversion X_.
    apply ileaf in X.
    apply ileaf in X0.
    simpl in *.

    refine (X ξ vars1 _ >>>= fun X0' => _).
    apply FreshMon.
    simpl.
    auto.

    refine (X0 ξ' ([vnew],,vars2) _ >>>= fun X1' => _).
    apply FreshMon.
    simpl.
    rewrite pf2.
    rewrite pf1.
    reflexivity.
    apply FreshMon.

    apply ILeaf.
    apply ileaf in X1'.
    apply ileaf in X0'.
    simpl in *.
    apply ELet with (ev:=vnew)(tv:=σ₁).
    apply X0'.
    apply X1'.
    Defined.

  Definition vartree Γ Δ Σ lev ξ :
    forall vars, Σ @@@ lev = mapOptionTree ξ vars ->
    ITree (HaskType Γ ★) (fun t : HaskType Γ ★ => Expr Γ Δ ξ t lev) Σ.
    induction Σ; intros.
    destruct a.
    intros; simpl in *.
    apply ILeaf.
    destruct vars; try destruct o; inversion H.
    set (EVar Γ Δ ξ v) as q.
    rewrite <- H1 in q.
    apply q.
    intros.
    apply INone.
    intros.
    destruct vars; try destruct o; inversion H.
    apply IBranch.
    eapply IHΣ1.
    apply H1.
    eapply IHΣ2.
    apply H2.
    Defined.

  Definition rdrop  Γ Δ Σ₁ Σ₁₂ a lev :
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- a,,Σ₁₂ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- a @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *.
    intros.
    set (X ξ vars H) as q.
    simpl in q.
    refine (q >>>= fun q' => return _).
    apply FreshMon.
    inversion q'.
    apply X0.
    Defined.

  Definition rdrop'  Γ Δ Σ₁ Σ₁₂ a lev :
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- Σ₁₂,,a @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- a @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *.
    intros.
    set (X ξ vars H) as q.
    simpl in q.
    refine (q >>>= fun q' => return _).
    apply FreshMon.
    inversion q'.
    auto.
    Defined.

  Definition rdrop''  Γ Δ Σ₁ Σ₁₂ lev :
    ITree Judg judg2exprType [Γ > Δ > [],,Σ₁ |- Σ₁₂ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- Σ₁₂ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    eapply X with (vars:=[],,vars).
    rewrite H; reflexivity.
    Defined.

  Definition rdrop'''  Γ Δ a Σ₁ Σ₁₂ lev :
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |- Σ₁₂ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > a,,Σ₁ |- Σ₁₂ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.
    eapply X with (vars:=vars2).
    auto.
    Defined.

  Definition rassoc  Γ Δ Σ₁ a b c lev :
    ITree Judg judg2exprType [Γ > Δ > ((a,,b),,c) |- Σ₁ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > (a,,(b,,c)) |- Σ₁ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.
    destruct vars2; try destruct o; inversion H2.
    apply X with (vars:=(vars1,,vars2_1),,vars2_2).
    subst; reflexivity.
    Defined.

  Definition rassoc'  Γ Δ Σ₁ a b c lev :
    ITree Judg judg2exprType [Γ > Δ > (a,,(b,,c)) |- Σ₁ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > ((a,,b),,c) |- Σ₁ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.
    destruct vars1; try destruct o; inversion H1.
    apply X with (vars:=vars1_1,,(vars1_2,,vars2)).
    subst; reflexivity.
    Defined.

  Definition swapr  Γ Δ Σ₁ a b c lev :
    ITree Judg judg2exprType [Γ > Δ > ((a,,b),,c) |- Σ₁ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > ((b,,a),,c) |- Σ₁ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.
    destruct vars1; try destruct o; inversion H1.
    apply X with (vars:=(vars1_2,,vars1_1),,vars2).
    subst; reflexivity.
    Defined.

  Definition rdup  Γ Δ Σ₁ a  c lev :
    ITree Judg judg2exprType [Γ > Δ > ((a,,a),,c) |- Σ₁ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > (a,,c) |- Σ₁ @ lev].
    intros.
    apply ileaf in X.
    apply ILeaf.
    simpl in *; intros.
    destruct vars; try destruct o; inversion H.
    apply X with (vars:=(vars1,,vars1),,vars2).    (* is this allowed? *)
    subst; reflexivity.
    Defined.

  (* holy cow this is ugly *)
  Definition rcut Γ Δ  Σ₃ lev  Σ₁₂  :
    forall Σ₁ Σ₂,
    ITree Judg judg2exprType [Γ > Δ > Σ₁ |-  Σ₁₂ @ lev] ->
    ITree Judg judg2exprType [Γ > Δ >  Σ₁₂ @@@ lev,,Σ₂ |- [Σ₃] @ lev] ->
    ITree Judg judg2exprType [Γ > Δ > Σ₁,,Σ₂ |- [Σ₃] @ lev].

    induction Σ₁₂.
    intros.
    destruct a.

    eapply rlet.
    apply IBranch.
    apply X.
    apply X0.

    simpl in X0.
    apply rdrop'' in X0.
    apply rdrop'''.
    apply X0.

    intros.
    simpl in X0.
    apply rassoc in X0.
    set (IHΣ₁₂1 _ _ (rdrop  _ _ _ _ _ _ X) X0) as q.
    set (IHΣ₁₂2 _ (Σ₁,,Σ₂) (rdrop' _ _ _ _ _ _ X)) as q'.
    apply rassoc' in q.
    apply swapr in q.
    apply rassoc in q.
    set (q' q) as q''.
    apply rassoc' in q''.
    apply rdup in q''.
    apply q''.
    Defined.

  Definition rule2expr : forall h j (r:Rule h j), ITree _ judg2exprType h -> ITree _ judg2exprType j.

    intros h j r.

      refine (match r as R in Rule H C return ITree _ judg2exprType H -> ITree _ judg2exprType C with
      | RArrange a b c d e l r        => let case_RURule := tt        in _
      | RNote   Γ Δ Σ τ l n           => let case_RNote := tt         in _
      | RLit    Γ Δ l     _           => let case_RLit := tt          in _
      | RVar    Γ Δ σ         p       => let case_RVar := tt          in _
      | RGlobal Γ Δ σ l wev           => let case_RGlobal := tt       in _
      | RLam    Γ Δ Σ tx te     x     => let case_RLam := tt          in _
      | RCast   Γ Δ Σ σ τ γ     x     => let case_RCast := tt         in _
      | RAbsT   Γ Δ Σ κ σ a n         => let case_RAbsT := tt         in _
      | RAppT   Γ Δ Σ κ σ τ     y     => let case_RAppT := tt         in _
      | RAppCo  Γ Δ Σ κ σ₁ σ₂ γ σ l   => let case_RAppCo := tt        in _
      | RAbsCo  Γ Δ Σ κ σ  σ₁ σ₂  y   => let case_RAbsCo := tt        in _
      | RApp    Γ Δ Σ₁ Σ₂ tx te p     => let case_RApp := tt          in _
      | RCut    Γ Δ Σ Σ₁ Σ₁₂ Σ₂ Σ₃ l  => let case_RCut := tt          in _
      | RLeft   Γ Δ Σ₁ Σ₂  Σ     l    => let case_RLeft := tt in _
      | RRight  Γ Δ Σ₁ Σ₂  Σ     l    => let case_RRight := tt in _
      | RVoid   _ _ l                 => let case_RVoid := tt   in _
      | RBrak   Σ a b c n m           => let case_RBrak := tt         in _
      | REsc    Σ a b c n m           => let case_REsc := tt          in _
      | RCase   Γ Δ lev tc Σ avars tbranches alts => let case_RCase := tt         in _
      | RLetRec Γ Δ lri x y t         => let case_RLetRec := tt       in _
      end); intro X_; try apply ileaf in X_; simpl in X_.

    destruct case_RURule.
      apply ILeaf. simpl. intros.
      set (@urule2expr a b _ _ e l r0 ξ) as q.
      unfold ujudg2exprType.
      unfold ujudg2exprType in q.
      apply q with (vars:=vars).
      intros.
      apply X_ with (vars:=vars0).
      auto.
      auto.

  destruct case_RBrak.
    apply ILeaf; simpl; intros; refine (X_ ξ vars H >>>= fun X => return ILeaf _ _). apply FreshMon.
    apply EBrak.
    apply (ileaf X).

  destruct case_REsc.
    apply ILeaf; simpl; intros; refine (X_ ξ vars H >>>= fun X => return ILeaf _ _). apply FreshMon.
    apply EEsc.
    apply (ileaf X).

  destruct case_RNote.
    apply ILeaf; simpl; intros; refine (X_ ξ vars H >>>= fun X => return ILeaf _ _). apply FreshMon.
    apply ENote; auto.
    apply (ileaf X).

  destruct case_RLit.
    apply ILeaf; simpl; intros; refine (return ILeaf _ _).
    apply ELit.

  destruct case_RVar.
    apply ILeaf; simpl; intros; refine (return ILeaf _ _).
    destruct vars; simpl in H; inversion H; destruct o. inversion H1.
    set (@EVar _ _ _ Δ ξ v) as q.
    rewrite <- H2 in q.
    simpl in q.
    apply q.
    inversion H.

  destruct case_RGlobal.
    apply ILeaf; simpl; intros; refine (return ILeaf _ _).
    apply EGlobal.

  destruct case_RLam.
    apply ILeaf.
    simpl in *; intros.
    refine (fresh_lemma _ ξ vars _ tx x H >>>= (fun pf => _)).
    apply FreshMon.
    destruct pf as [ vnew [ pf1 pf2 ]].
    set (update_xi ξ x (((vnew, tx  )) :: nil)) as ξ' in *.
    refine (X_ ξ' (vars,,[vnew]) _ >>>= _).
    apply FreshMon.
    simpl.
    rewrite pf1.
    rewrite <- pf2.
    simpl.
    reflexivity.
    intro hyp.
    refine (return _).
    apply ILeaf.
    apply ELam with (ev:=vnew).
    apply ileaf in hyp.
    simpl in hyp.
    unfold ξ' in hyp.
    apply hyp.

  destruct case_RCast.
    apply ILeaf; simpl; intros; refine (X_ ξ vars H >>>= fun X => return ILeaf _ _). apply FreshMon.
    eapply ECast.
    apply x.
    apply ileaf in X. simpl in X.
    apply X.

  destruct case_RApp.
    apply ILeaf.
    inversion X_.
    inversion X.
    inversion X0.
    simpl in *.
    intros.
    destruct vars. try destruct o; inversion H.
    simpl in H.
    inversion H.
    set (X1 ξ vars1 H5) as q1.
    set (X2 ξ vars2 H6) as q2.
    refine (q1 >>>= fun q1' => q2 >>>= fun q2' => return _).
    apply FreshMon.
    apply FreshMon.
    apply ILeaf.
    apply ileaf in q1'.
    apply ileaf in q2'.
    simpl in *.
    apply (EApp _ _ _ _ _ _ q1' q2').

  destruct case_RCut.
    apply rassoc.
    apply swapr.
    apply rassoc'.

    inversion X_.
    subst.
    clear X_.

    apply rassoc' in X0.
    apply swapr in X0.
    apply rassoc in X0.

    induction Σ₃.
    destruct a.
    subst.
    eapply rcut.
    apply X.
    apply X0.

    apply ILeaf.
    simpl.
    intros.
    refine (return _).
    apply INone.
    set (IHΣ₃1 (rdrop  _ _ _ _ _ _ X0)) as q1.
    set (IHΣ₃2 (rdrop' _ _ _ _ _ _ X0)) as q2.
    apply ileaf in q1.
    apply ileaf in q2.
    simpl in *.
    apply ILeaf.
    simpl.
    intros.
    refine (q1 _ _ H >>>= fun q1' => q2 _ _ H >>>= fun q2' => return _).
    apply FreshMon.
    apply FreshMon.
    apply IBranch; auto.

  destruct case_RLeft.
    apply ILeaf.
    simpl; intros.
    destruct vars; try destruct o; inversion H.
    refine (X_ _ _ H2 >>>= fun X' => return _).
    apply FreshMon.
    apply IBranch.
    eapply vartree.
    apply H1.
    apply X'.

  destruct case_RRight.
    apply ILeaf.
    simpl; intros.
    destruct vars; try destruct o; inversion H.
    refine (X_ _ _ H1 >>>= fun X' => return _).
    apply FreshMon.
    apply IBranch.
    apply X'.
    eapply vartree.
    apply H2.

  destruct case_RVoid.
    apply ILeaf; simpl; intros.
    refine (return _).
    apply INone.

  destruct case_RAppT.
    apply ILeaf; simpl; intros; refine (X_ ξ vars H >>>= fun X => return ILeaf _ _). apply FreshMon.
    apply ETyApp.
    apply (ileaf X).

  destruct case_RAbsT.
    apply ILeaf; simpl; intros; refine (X_ (weakLT_ ○ ξ) vars _ >>>= fun X => return ILeaf _ _). apply FreshMon.
    rewrite mapOptionTree_compose.
    rewrite <- H.
    reflexivity.
    apply ileaf in X. simpl in *.
    apply (ETyLam _ _ _ _ _ _ n).
    apply X.

  destruct case_RAppCo.
    apply ILeaf; simpl; intros; refine (X_ ξ vars _ >>>= fun X => return ILeaf _ _). apply FreshMon.
    auto.
    eapply ECoApp.
    apply γ.
    apply (ileaf X).

  destruct case_RAbsCo.
    apply ILeaf; simpl; intros; refine (X_ ξ vars _ >>>= fun X => return ILeaf _ _). apply FreshMon.
    auto.
    eapply ECoLam.
    apply (ileaf X).

  destruct case_RLetRec.
    apply ILeaf; simpl; intros.
    refine (bind ξvars = fresh_lemma' _ y _ _ _ t H; _). apply FreshMon.
    destruct ξvars as [ varstypes [ pf1[ pf2 pfdist]]].
    refine (X_ ((update_xi ξ t (leaves varstypes)))
      ((mapOptionTree (@fst _ _) varstypes),,vars) _ >>>= fun X => return _); clear X_.  apply FreshMon.
    simpl.
    rewrite pf2.
    rewrite pf1.
    auto.
    apply ILeaf.
    inversion X; subst; clear X.

    apply (@ELetRec _ _ _ _ _ _ _ varstypes).
    auto.
    apply (@letrec_helper Γ Δ t varstypes).
    rewrite mapOptionTree_compose.
    rewrite mapOptionTree_compose.
    rewrite pf2.
    replace ((mapOptionTree unlev (y @@@ t))) with y.
      apply X0.
      clear pf1 X0 X1 pfdist pf2 vars varstypes.
      induction y; try destruct a; auto.
      rewrite IHy1 at 1.
      rewrite IHy2 at 1.
      reflexivity.
    apply ileaf in X1.
    simpl in X1.
    apply X1.

  destruct case_RCase.
    apply ILeaf; simpl; intros.
    inversion X_.
    clear X_.
    subst.
    apply ileaf in X0.
    simpl in X0.

    (* body_freevars and alts_freevars are the types of variables in the body and alternatives (respectively) which are free
     * from the viewpoint just outside the case block -- i.e. not bound by any of the branches *)
    rename Σ into body_freevars_types.
    rename vars into all_freevars.
    rename X0 into body_expr.
    rename X  into alts_exprs.

    destruct all_freevars; try destruct o; inversion H.
    rename all_freevars2 into body_freevars.
    rename all_freevars1 into alts_freevars.

    set (gather_branch_variables _ _ _ _ _ _ _ _ _ H1 alts_exprs) as q.
    set (itmap (fun pcb alt_expr => case_helper tc Γ Δ lev tbranches avars ξ pcb alt_expr) q) as alts_exprs'.
    apply fix_indexing in alts_exprs'.
    simpl in alts_exprs'.
    apply unindex_tree in alts_exprs'.
    simpl in alts_exprs'.
    apply fix2 in alts_exprs'.
    apply treeM in alts_exprs'.

    refine ( alts_exprs' >>>= fun Y =>
      body_expr ξ _ _
      >>>= fun X => return ILeaf _ (@ECase _ _ _ _ _ _ _ _ _ (ileaf X) Y)); auto.
      apply FreshMon.
      apply FreshMon.
      apply H2.
    Defined.

  Fixpoint closed2expr h j (pn:@SIND _ Rule h j) {struct pn} : ITree _ judg2exprType h -> ITree _ judg2exprType j :=
    match pn in @SIND _ _ H J return ITree _ judg2exprType H -> ITree _ judg2exprType J with
    | scnd_weak   _             => let case_nil    := tt in fun _ => INone _ _
    | scnd_comp   x h c cnd' r  => let case_rule   := tt in fun q => rule2expr _ _ r (closed2expr _ _ cnd' q)
    | scnd_branch _ _ _ c1 c2   => let case_branch := tt in fun q => IBranch _ _ (closed2expr _ _ c1 q) (closed2expr _ _ c2 q)
    end.

  Definition proof2expr Γ Δ τ l Σ (ξ0: VV -> LeveledHaskType Γ ★)
    {zz:ToString VV} : ND Rule [] [Γ > Δ > Σ |- [τ] @ l] ->
    FreshM (???{ ξ : _ & Expr Γ Δ ξ τ l}).
    intro pf.
    set (mkSIND systemfc_all_rules_one_conclusion _ _ _ pf (scnd_weak [])) as cnd.
    apply closed2expr in cnd.
    apply ileaf in cnd.
    simpl in *.
    clear pf.
    refine (bind ξvars = manyFresh _ Σ ξ0; _).
    apply FreshMon.
    destruct ξvars as [vars ξpf].
    destruct ξpf as [ξ pf].
    refine (cnd ξ vars _ >>>= fun it => _).
    apply FreshMon.
    auto.
    refine (return OK _).
    exists ξ.
    apply ileaf in it.
    simpl in it.
    apply it.
    apply INone.
    Defined.

End HaskProofToStrong.