adamc@223: (* Copyright (c) 2008-2009, Adam Chlipala
adamc@182:  * 
adamc@182:  * This work is licensed under a
adamc@182:  * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
adamc@182:  * Unported License.
adamc@182:  * The license text is available at:
adamc@182:  *   http://creativecommons.org/licenses/by-nc-nd/3.0/
adamc@182:  *)
adamc@182: 
adamc@257: (* begin hide *)
adamc@258: Require Import Arith List.
adamc@257: 
adamc@257: Require Import Axioms DepList Tactics.
adamc@257: 
adamc@257: Set Implicit Arguments.
adamc@257: (* end hide *)
adamc@257: 
adamc@184: 
adamc@182: (** %\chapter{Intensional Transformations}% *)
adamc@182: 
adamc@257: (* begin hide *)
adamc@257: 
adamc@257: Inductive type : Type :=
adamc@257: | Nat : type
adamc@257: | Arrow : type -> type -> type.
adamc@257: 
adamc@257: Infix "-->" := Arrow (right associativity, at level 60).
adamc@257: 
adamc@257: Fixpoint typeDenote (t : type) : Set :=
adamc@257:   match t with
adamc@257:     | Nat => nat
adamc@257:     | t1 --> t2 => typeDenote t1 -> typeDenote t2
adamc@257:   end.
adamc@257: 
adamc@257: Module Phoas.
adamc@257:   Section vars.
adamc@257:     Variable var : type -> Type.
adamc@257: 
adamc@257:     Inductive exp : type -> Type :=
adamc@257:     | Var : forall t,
adamc@257:       var t
adamc@257:       -> exp t
adamc@257: 
adamc@257:     | Const : nat -> exp Nat
adamc@257:     | Plus : exp Nat -> exp Nat -> exp Nat
adamc@257: 
adamc@257:     | App : forall t1 t2,
adamc@257:       exp (t1 --> t2)
adamc@257:       -> exp t1
adamc@257:       -> exp t2
adamc@257:     | Abs : forall t1 t2,
adamc@257:       (var t1 -> exp t2)
adamc@257:       -> exp (t1 --> t2).
adamc@257:   End vars.
adamc@257: 
adamc@257:   Definition Exp t := forall var, exp var t.
adamc@257: 
adamc@257:   Implicit Arguments Var [var t].
adamc@257:   Implicit Arguments Const [var].
adamc@257:   Implicit Arguments Plus [var].
adamc@257:   Implicit Arguments App [var t1 t2].
adamc@257:   Implicit Arguments Abs [var t1 t2].
adamc@257: 
adamc@257:   Notation "# v" := (Var v) (at level 70).
adamc@257: 
adamc@257:   Notation "^ n" := (Const n) (at level 70).
adamc@257:   Infix "+^" := Plus (left associativity, at level 79).
adamc@257: 
adamc@257:   Infix "@" := App (left associativity, at level 77).
adamc@257:   Notation "\ x , e" := (Abs (fun x => e)) (at level 78).
adamc@257:   Notation "\ ! , e" := (Abs (fun _ => e)) (at level 78).
adamc@257: 
adamc@257:   Fixpoint expDenote t (e : exp typeDenote t) : typeDenote t :=
adamc@257:     match e with
adamc@257:       | Var _ v => v
adamc@257:         
adamc@257:       | Const n => n
adamc@257:       | Plus e1 e2 => expDenote e1 + expDenote e2
adamc@257:         
adamc@257:       | App _ _ e1 e2 => (expDenote e1) (expDenote e2)
adamc@257:       | Abs _ _ e' => fun x => expDenote (e' x)
adamc@257:     end.
adamc@257: 
adamc@257:   Definition ExpDenote t (e : Exp t) := expDenote (e _).
adamc@257: 
adamc@257:   Section exp_equiv.
adamc@257:     Variables var1 var2 : type -> Type.
adamc@257: 
adamc@257:     Inductive exp_equiv : list { t : type & var1 t * var2 t }%type
adamc@257:       -> forall t, exp var1 t -> exp var2 t -> Prop :=
adamc@257:     | EqVar : forall G t (v1 : var1 t) v2,
adamc@257:       In (existT _ t (v1, v2)) G
adamc@257:       -> exp_equiv G (#v1) (#v2)
adamc@257: 
adamc@257:     | EqConst : forall G n,
adamc@257:       exp_equiv G (^n) (^n)
adamc@257:     | EqPlus : forall G x1 y1 x2 y2,
adamc@257:       exp_equiv G x1 x2
adamc@257:       -> exp_equiv G y1 y2
adamc@257:       -> exp_equiv G (x1 +^ y1) (x2 +^ y2)
adamc@257: 
adamc@257:     | EqApp : forall G t1 t2 (f1 : exp _ (t1 --> t2)) (x1 : exp _ t1) f2 x2,
adamc@257:       exp_equiv G f1 f2
adamc@257:       -> exp_equiv G x1 x2
adamc@257:       -> exp_equiv G (f1 @ x1) (f2 @ x2)
adamc@257:     | EqAbs : forall G t1 t2 (f1 : var1 t1 -> exp var1 t2) f2,
adamc@257:       (forall v1 v2, exp_equiv (existT _ t1 (v1, v2) :: G) (f1 v1) (f2 v2))
adamc@257:       -> exp_equiv G (Abs f1) (Abs f2).
adamc@257:   End exp_equiv.
adamc@258: 
adamc@258:   Definition Wf t (E : Exp t) := forall var1 var2, exp_equiv nil (E var1) (E var2).
adamc@257: End Phoas.
adamc@257: (* end hide *)
adamc@257: 
adamc@257: Module DeBruijn.
adamc@257:   Inductive exp : list type -> type -> Type :=
adamc@257:     | Var : forall G t,
adamc@257:       member t G
adamc@257:       -> exp G t
adamc@257: 
adamc@257:     | Const : forall G, nat -> exp G Nat
adamc@257:     | Plus : forall G, exp G Nat -> exp G Nat -> exp G Nat
adamc@257: 
adamc@257:     | App : forall G t1 t2,
adamc@257:       exp G (t1 --> t2)
adamc@257:       -> exp G t1
adamc@257:       -> exp G t2
adamc@257:     | Abs : forall G t1 t2,
adamc@257:       exp (t1 :: G) t2
adamc@257:       -> exp G (t1 --> t2).
adamc@257: 
adamc@257:   Implicit Arguments Const [G].
adamc@257: 
adamc@257:   Fixpoint expDenote G t (e : exp G t) : hlist typeDenote G -> typeDenote t :=
adamc@257:     match e with
adamc@257:       | Var _ _ v => fun s => hget s v
adamc@257:         
adamc@257:       | Const _ n => fun _ => n
adamc@257:       | Plus _ e1 e2 => fun s => expDenote e1 s + expDenote e2 s
adamc@257:         
adamc@257:       | App _ _ _ e1 e2 => fun s => (expDenote e1 s) (expDenote e2 s)
adamc@257:       | Abs _ _ _ e' => fun s x => expDenote e' (x ::: s)
adamc@257:     end.
adamc@257: End DeBruijn.
adamc@257: 
adamc@257: Import Phoas DeBruijn.
adamc@257: 
adamc@257: 
adamc@257: (** * From De Bruijn to PHOAS *)
adamc@257: 
adamc@257: Section phoasify.
adamc@257:   Variable var : type -> Type.
adamc@257: 
adamc@257:   Fixpoint phoasify G t (e : DeBruijn.exp G t) : hlist var G -> Phoas.exp var t :=
adamc@257:     match e with
adamc@257:       | Var _ _ v => fun s => #(hget s v)
adamc@257: 
adamc@257:       | Const _ n => fun _ => ^n
adamc@257:       | Plus _ e1 e2 => fun s => phoasify e1 s +^ phoasify e2 s
adamc@257: 
adamc@257:       | App _ _ _ e1 e2 => fun s => phoasify e1 s @ phoasify e2 s
adamc@257:       | Abs _ _ _ e' => fun s => \x, phoasify e' (x ::: s)
adamc@257:     end.
adamc@257: End phoasify.
adamc@257: 
adamc@257: Definition Phoasify t (e : DeBruijn.exp nil t) : Phoas.Exp t :=
adamc@257:   fun _ => phoasify e HNil.
adamc@257: 
adamc@257: Theorem phoasify_sound : forall G t (e : DeBruijn.exp G t) s,
adamc@257:   Phoas.expDenote (phoasify e s) = DeBruijn.expDenote e s.
adamc@257:   induction e; crush; ext_eq; crush.
adamc@257: Qed.
adamc@257: 
adamc@257: Section vars.
adamc@257:   Variables var1 var2 : type -> Type.
adamc@257: 
adamc@257:   Fixpoint zip G (s1 : hlist var1 G) : hlist var2 G -> list {t : type & var1 t * var2 t}%type :=
adamc@257:     match s1 with
adamc@257:       | HNil => fun _ => nil
adamc@257:       | HCons _ _ v1 s1' => fun s2 => existT _ _ (v1, hhd s2) :: zip s1' (htl s2)
adamc@257:     end.
adamc@257: 
adamc@257:   Lemma In_zip : forall t G (s1 : hlist _ G) s2 (m : member t G),
adamc@257:     In (existT _ t (hget s1 m, hget s2 m)) (zip s1 s2).
adamc@257:     induction s1; intro s2; dep_destruct s2; intro m; dep_destruct m; crush.
adamc@257:   Qed.
adamc@257: 
adamc@257:   Lemma unsimpl_zip : forall t (v1 : var1 t) (v2 : var2 t)
adamc@257:     G (s1 : hlist _ G) s2 t' (e1 : Phoas.exp _ t') e2,
adamc@257:    exp_equiv (zip (v1 ::: s1) (v2 ::: s2)) e1 e2
adamc@257:    -> exp_equiv (existT _ _ (v1, v2) :: zip s1 s2) e1 e2.
adamc@257:     trivial.
adamc@257:   Qed.
adamc@257: 
adamc@257:   Hint Resolve In_zip unsimpl_zip.
adamc@257: 
adamc@257:   Theorem phoasify_wf : forall G t (e : DeBruijn.exp G t) s1 s2,
adamc@257:     exp_equiv (zip s1 s2) (phoasify e s1) (phoasify e s2).
adamc@257:     Hint Constructors exp_equiv.
adamc@257:     
adamc@257:     induction e; crush.
adamc@257:   Qed.
adamc@257: End vars.
adamc@257: 
adamc@258: Theorem Phoasify_wf : forall t (e : DeBruijn.exp nil t),
adamc@258:   Wf (Phoasify e).
adamc@258:   unfold Wf, Phoasify; intros;
adamc@258:     apply (phoasify_wf e (HNil (B := var1)) (HNil (B := var2))).
adamc@258: Qed.
adamc@258: 
adamc@257: 
adamc@257: (** * From PHOAS to De Bruijn *)
adamc@258: 
adamc@258: Fixpoint lookup (G : list type) (n : nat) : option type :=
adamc@258:   match G with
adamc@258:     | nil => None
adamc@258:     | t :: G' => if eq_nat_dec n (length G') then Some t else lookup G' n
adamc@258:   end.
adamc@258: 
adamc@258: Infix "##" := lookup (left associativity, at level 1).
adamc@258: 
adamc@258: Fixpoint wf (ts : list type) t (e : Phoas.exp (fun _ => nat) t) : Prop :=
adamc@258:   match e with
adamc@258:     | Phoas.Var t n => ts ## n = Some t
adamc@258:     | Phoas.Const _ => True
adamc@258:     | Phoas.Plus e1 e2 => wf ts e1 /\ wf ts e2
adamc@258:     | Phoas.App _ _ e1 e2 => wf ts e1 /\ wf ts e2
adamc@258:     | Phoas.Abs t1 _ e1 => wf (t1 :: ts) (e1 (length ts))
adamc@258:   end.
adamc@258: 
adamc@258: Fixpoint makeG (ts : list type) : list { t : type & nat * nat }%type :=
adamc@258:   match ts with
adamc@258:     | nil => nil
adamc@258:     | t :: ts' => existT _ t (length ts', length ts') :: makeG ts'
adamc@258:   end.
adamc@258: 
adamc@258: Opaque eq_nat_dec.
adamc@258: Hint Extern 1 (_ >= _) => omega.
adamc@258: 
adamc@258: Lemma lookup_contra' : forall t ts n,
adamc@258:   ts ## n = Some t
adamc@258:   -> n >= length ts
adamc@258:   -> False.
adamc@258:   induction ts; crush;
adamc@258:     match goal with
adamc@258:       | [ _ : context[if ?E then _ else _] |- _ ] => destruct E; crush
adamc@258:     end; eauto.
adamc@258: Qed.
adamc@258: 
adamc@258: Lemma lookup_contra : forall t ts,
adamc@258:   ts ## (length ts) = Some t
adamc@258:   -> False.
adamc@258:   intros; eapply lookup_contra'; eauto.
adamc@258: Qed.
adamc@258: 
adamc@258: Hint Resolve lookup_contra.
adamc@258: 
adamc@258: Lemma lookup_In : forall t v1 v2 ts,
adamc@258:   In (existT (fun _ : type => (nat * nat)%type) t (v1, v2)) (makeG ts)
adamc@258:   -> ts ## v1 = Some t.
adamc@258:   induction ts; crush;
adamc@258:     match goal with
adamc@258:       | [ |- context[if ?E then _ else _] ] => destruct E; crush
adamc@258:     end; elimtype False; eauto.
adamc@258: Qed.
adamc@258: 
adamc@258: Hint Resolve lookup_In.
adamc@258: 
adamc@258: Hint Extern 1 (_ :: _ = makeG (_ :: _)) => reflexivity.
adamc@258: 
adamc@258: Lemma Wf_wf' : forall G t e1 (e2 : Phoas.exp (fun _ => nat) t),
adamc@258:   exp_equiv G e1 e2
adamc@258:   -> forall ts, G = makeG ts
adamc@258:     -> wf ts e1.
adamc@258:   induction 1; crush; eauto.
adamc@258: Qed.
adamc@258: 
adamc@258: Lemma Wf_wf : forall t (E : Exp t),
adamc@258:   Wf E
adamc@258:   -> wf nil (E (fun _ => nat)).
adamc@258:   intros; eapply Wf_wf'; eauto.
adamc@258: Qed.