test(tests/lean/run/quote_base): add example from Bas' paper

tests/lean/run/quote_bas.lean

@@ -0,0 +1,77 @@
+universes u v w
+
+inductive Expr (V : Type u)
+| One {}            : Expr
+| Var (v : V)       : Expr
+| Mult (a b : Expr) : Expr
+
+@[reducible] def Value := nat
+def Env (V : Type u) := V → Value
+
+open Expr
+
+def evalExpr {V} (vs : Env V) : Expr V → Value
+| One        := 1
+| (Var v)    := vs v
+| (Mult a b) := evalExpr a * evalExpr b
+
+def novars : Env empty :=
+empty.rec _
+
+def singlevar (x : Value) : Env unit :=
+λ _, x
+
+open sum
+
+def merge {A : Type u} {B : Type v} (a : Env A) (b : Env B) : Env (sum A B)
+| (inl j) := a j
+| (inr j) := b j
+
+def map_var {A : Type u} {B : Type v} (f : A → B) : Expr A → Expr B
+| One        := One
+| (Var v)    := Var (f v)
+| (Mult a b) := Mult (map_var a) (map_var b)
+
+def sum_assoc {A : Type u} {B : Type v} {C : Type w} : sum (sum A B) C → sum A (sum B C)
+| (inl (inl a)) := inl a
+| (inl (inr b)) := inr (inl b)
+| (inr c)       := inr (inr c)
+
+attribute [simp] evalExpr map_var sum_assoc merge
+
+@[simp] lemma eval_map_var_shift {A : Type u} {B : Type v} (v : Env A) (v' : Env B) (e : Expr A) : evalExpr (merge v v') (map_var inl e) = evalExpr v e :=
+begin
+  induction e,
+  reflexivity,
+  reflexivity,
+  simp_using_hs
+end
+
+@[simp] lemma eval_map_var_sum_assoc {A : Type u} {B : Type v} {C : Type w} (v : Env A) (v' : Env B) (v'' : Env C) (e : Expr (sum (sum A B) C)) :
+                             evalExpr (merge v (merge v' v'')) (map_var sum_assoc e) = evalExpr (merge (merge v v') v'') e :=
+begin
+  induction e,
+  reflexivity,
+  { cases v with v₁, cases v₁, all_goals {simp} },
+  { simp_using_hs }
+end
+
+class Quote {V : out_param (Type u)} (l : out_param (Env V)) (n : Value) {V' : out_param (Type v)} (r : out_param (Env V')) :=
+(quote      : Expr (sum V V'))
+(eval_quote : evalExpr (merge l r) quote = n)
+
+def quote {V : Type u} {l : Env V} (n : nat) {V' : Type v} {r : Env V'} [Quote l n r] : Expr (sum V V') :=
+Quote.quote l n r
+
+@[simp] lemma eval_quote {V : Type u} {l : Env V} (n : nat) {V' : Type v} {r : Env V'} [Quote l n r] : evalExpr (merge l r) (quote n) = n :=
+Quote.eval_quote l n r
+
+instance quote_one V (v : Env V) : Quote v 1 novars :=
+{ quote      := One,
+  eval_quote := rfl }
+
+instance quote_mul {V : Type u} (v : Env V) n {V' : Type v} (v' : Env V') m {V'' : Type w} (v'' : Env V'')
+                   [Quote v n v'] [Quote (merge v v') m v''] :
+                   Quote v (n * m) (merge v' v'') :=
+{ quote      := Mult (map_var sum_assoc (map_var inl (quote n))) (map_var sum_assoc (quote m)),
+  eval_quote := by simp }