mirror of
https://github.com/achlipala/frap.git
synced 2024-11-12 17:17:50 +00:00
Update FirstClassFunctions_template from new source material
This commit is contained in:
parent
6f17daa2df
commit
af19eb9f42
1 changed files with 306 additions and 23 deletions
|
@ -1,21 +1,26 @@
|
||||||
Require Import Frap.
|
Require Import Frap Program.
|
||||||
|
|
||||||
|
|
||||||
(** * Some data fodder for us to compute with later *)
|
(** * Some data fodder for us to compute with later *)
|
||||||
|
|
||||||
|
(* Records are a handy way to define datatypes in terms of the named fields that
|
||||||
|
* each value must contain. *)
|
||||||
Record programming_language := {
|
Record programming_language := {
|
||||||
Name : string;
|
Name : string;
|
||||||
PurelyFunctional : bool;
|
PurelyFunctional : bool;
|
||||||
AppearedInYear : nat
|
AppearedInYear : nat
|
||||||
}.
|
}.
|
||||||
|
|
||||||
|
(* Here's a quick example of a set of programming languages, which we will use
|
||||||
|
* below in some example computations. *)
|
||||||
|
|
||||||
Definition pascal := {|
|
Definition pascal := {|
|
||||||
Name := "Pascal";
|
Name := "Pascal";
|
||||||
PurelyFunctional := false;
|
PurelyFunctional := false;
|
||||||
AppearedInYear := 1970
|
AppearedInYear := 1970
|
||||||
|}.
|
|}.
|
||||||
|
|
||||||
Definition c := {|
|
Definition clang := {|
|
||||||
Name := "C";
|
Name := "C";
|
||||||
PurelyFunctional := false;
|
PurelyFunctional := false;
|
||||||
AppearedInYear := 1972
|
AppearedInYear := 1972
|
||||||
|
@ -39,11 +44,16 @@ Definition ocaml := {|
|
||||||
AppearedInYear := 1996
|
AppearedInYear := 1996
|
||||||
|}.
|
|}.
|
||||||
|
|
||||||
Definition languages := [pascal; c; gallina; haskell; ocaml].
|
Definition languages := [pascal; clang; gallina; haskell; ocaml].
|
||||||
|
|
||||||
|
|
||||||
(** * Classic list functions *)
|
(** * Classic list functions *)
|
||||||
|
|
||||||
|
(* The trio of "map/filter/reduce" are commonly presented as workhorse
|
||||||
|
* *higher-order functions* for lists. That is, they are functions that take
|
||||||
|
* functions as arguments. *)
|
||||||
|
|
||||||
|
(* [map] runs a function on every position of a list to make a new list. *)
|
||||||
Fixpoint map {A B} (f : A -> B) (ls : list A) : list B :=
|
Fixpoint map {A B} (f : A -> B) (ls : list A) : list B :=
|
||||||
match ls with
|
match ls with
|
||||||
| nil => nil
|
| nil => nil
|
||||||
|
@ -51,7 +61,9 @@ Fixpoint map {A B} (f : A -> B) (ls : list A) : list B :=
|
||||||
end.
|
end.
|
||||||
|
|
||||||
Compute map (fun n => n + 2) [1; 3; 8].
|
Compute map (fun n => n + 2) [1; 3; 8].
|
||||||
|
(* Note the use of an *anonymous function* above via [fun]. *)
|
||||||
|
|
||||||
|
(* [filter] keeps only those elements of a list that pass a Boolean test. *)
|
||||||
Fixpoint filter {A} (f : A -> bool) (ls : list A) : list A :=
|
Fixpoint filter {A} (f : A -> bool) (ls : list A) : list A :=
|
||||||
match ls with
|
match ls with
|
||||||
| nil => nil
|
| nil => nil
|
||||||
|
@ -59,7 +71,12 @@ Fixpoint filter {A} (f : A -> bool) (ls : list A) : list A :=
|
||||||
end.
|
end.
|
||||||
|
|
||||||
Compute filter (fun n => if n <=? 3 then true else false) [1; 3; 8].
|
Compute filter (fun n => if n <=? 3 then true else false) [1; 3; 8].
|
||||||
|
(* The [if ... then true else false] bit might seem wasteful. Actually, the
|
||||||
|
* [<=?] operator has a fancy type that needs converting to [bool]. We'll get
|
||||||
|
* more specific about such types in a future class. *)
|
||||||
|
|
||||||
|
(* [fold_left], a relative of "reduce," repeatedly applies a function to all
|
||||||
|
* elements of a list. *)
|
||||||
Fixpoint fold_left {A B} (f : B -> A -> B) (ls : list A) (acc : B) : B :=
|
Fixpoint fold_left {A B} (f : B -> A -> B) (ls : list A) (acc : B) : B :=
|
||||||
match ls with
|
match ls with
|
||||||
| nil => acc
|
| nil => acc
|
||||||
|
@ -68,6 +85,7 @@ Fixpoint fold_left {A B} (f : B -> A -> B) (ls : list A) (acc : B) : B :=
|
||||||
|
|
||||||
Compute fold_left max [1; 3; 8] 0.
|
Compute fold_left max [1; 3; 8] 0.
|
||||||
|
|
||||||
|
(* Another way to see [fold_left] in action: *)
|
||||||
Theorem fold_left3 : forall {A B} (f : B -> A -> B) (x y z : A) (acc : B),
|
Theorem fold_left3 : forall {A B} (f : B -> A -> B) (x y z : A) (acc : B),
|
||||||
fold_left f [x; y; z] acc = f (f (f acc x) y) z.
|
fold_left f [x; y; z] acc = f (f (f acc x) y) z.
|
||||||
Proof.
|
Proof.
|
||||||
|
@ -75,13 +93,22 @@ Proof.
|
||||||
equality.
|
equality.
|
||||||
Qed.
|
Qed.
|
||||||
|
|
||||||
|
(* Let's use these classics to implement a few simple "database queries" on the
|
||||||
|
* list of programming languages. Note that each field name from
|
||||||
|
* [programming_language] is itself a first-class function, for projecting that
|
||||||
|
* field from any record! *)
|
||||||
|
|
||||||
Compute map Name languages.
|
Compute map Name languages.
|
||||||
|
(* names of languages *)
|
||||||
|
|
||||||
Compute map Name (filter PurelyFunctional languages).
|
Compute map Name (filter PurelyFunctional languages).
|
||||||
|
(* names of purely functional languages *)
|
||||||
|
|
||||||
Compute fold_left max (map AppearedInYear languages) 0.
|
Compute fold_left max (map AppearedInYear languages) 0.
|
||||||
|
(* maximum year in which a language appeared *)
|
||||||
|
|
||||||
Compute fold_left max (map AppearedInYear (filter PurelyFunctional languages)) 0.
|
Compute fold_left max (map AppearedInYear (filter PurelyFunctional languages)) 0.
|
||||||
|
(* maximum year in which a purely functional language appeared *)
|
||||||
|
|
||||||
(* To avoid confusing things, we'll revert to the standard library's (identical)
|
(* To avoid confusing things, we'll revert to the standard library's (identical)
|
||||||
* versions of these functions for the remainder. *)
|
* versions of these functions for the remainder. *)
|
||||||
|
@ -90,21 +117,8 @@ Reset map.
|
||||||
|
|
||||||
(** * Sorting, parameterized in a comparison operation *)
|
(** * Sorting, parameterized in a comparison operation *)
|
||||||
|
|
||||||
Fixpoint insert {A} (le : A -> A -> bool) (new : A) (ls : list A) : list A :=
|
Fixpoint insertion_sort {A} (le : A -> A -> bool) (ls : list A) : list A.
|
||||||
match ls with
|
Admitted.
|
||||||
| [] => [new]
|
|
||||||
| x :: ls' =>
|
|
||||||
if le new x then
|
|
||||||
new :: ls
|
|
||||||
else
|
|
||||||
x :: insert le new ls'
|
|
||||||
end.
|
|
||||||
|
|
||||||
Fixpoint insertion_sort {A} (le : A -> A -> bool) (ls : list A) : list A :=
|
|
||||||
match ls with
|
|
||||||
| [] => []
|
|
||||||
| x :: ls' => insert le x (insertion_sort le ls')
|
|
||||||
end.
|
|
||||||
|
|
||||||
Fixpoint sorted {A} (le : A -> A -> bool) (ls : list A) : bool :=
|
Fixpoint sorted {A} (le : A -> A -> bool) (ls : list A) : bool :=
|
||||||
match ls with
|
match ls with
|
||||||
|
@ -116,17 +130,22 @@ Fixpoint sorted {A} (le : A -> A -> bool) (ls : list A) : bool :=
|
||||||
end
|
end
|
||||||
end.
|
end.
|
||||||
|
|
||||||
Theorem insertion_sort_sorted : forall {A} (le : A -> A -> bool) ls,
|
(* Main theorem: [insertion_sort] produces only sorted lists. *)
|
||||||
sorted le (insertion_sort le ls) = true.
|
Theorem insertion_sort_sorted : forall {A} (le : A -> A -> bool),
|
||||||
|
forall ls,
|
||||||
|
sorted le (insertion_sort le ls) = true.
|
||||||
Proof.
|
Proof.
|
||||||
Admitted.
|
Admitted.
|
||||||
|
|
||||||
|
(* Let's do a quick example of using [insertion_sort] with a concrete
|
||||||
|
* comparator. *)
|
||||||
|
|
||||||
Definition not_introduced_later (l1 l2 : programming_language) : bool :=
|
Definition not_introduced_later (l1 l2 : programming_language) : bool :=
|
||||||
if AppearedInYear l1 <=? AppearedInYear l2 then true else false.
|
if AppearedInYear l1 <=? AppearedInYear l2 then true else false.
|
||||||
|
|
||||||
Compute insertion_sort
|
Compute insertion_sort
|
||||||
not_introduced_later
|
not_introduced_later
|
||||||
[gallina; pascal; c; ocaml; haskell].
|
[gallina; pascal; clang; ocaml; haskell].
|
||||||
|
|
||||||
Corollary insertion_sort_languages : forall langs,
|
Corollary insertion_sort_languages : forall langs,
|
||||||
sorted not_introduced_later (insertion_sort not_introduced_later langs) = true.
|
sorted not_introduced_later (insertion_sort not_introduced_later langs) = true.
|
||||||
|
@ -134,6 +153,272 @@ Proof.
|
||||||
Admitted.
|
Admitted.
|
||||||
|
|
||||||
|
|
||||||
|
(** * A language of functions and its interpreter *)
|
||||||
|
|
||||||
|
Inductive dyn :=
|
||||||
|
| Bool (b : bool)
|
||||||
|
| Number (n : nat)
|
||||||
|
| List (ds : list dyn).
|
||||||
|
|
||||||
|
Definition dmap (f : dyn -> dyn) (x : dyn) : dyn :=
|
||||||
|
match x with
|
||||||
|
| List ds => List (map f ds)
|
||||||
|
| _ => x
|
||||||
|
end.
|
||||||
|
|
||||||
|
Definition dfilter (f : dyn -> dyn) (x : dyn) : dyn :=
|
||||||
|
match x with
|
||||||
|
List ds => List (filter (fun arg => match f arg with
|
||||||
|
| Bool b => b
|
||||||
|
| _ => false
|
||||||
|
end) ds)
|
||||||
|
| _ => x
|
||||||
|
end.
|
||||||
|
|
||||||
|
Definition disZero (x : dyn) : dyn :=
|
||||||
|
match x with
|
||||||
|
| Number 0 => Bool true
|
||||||
|
| Number _ => Bool false
|
||||||
|
| _ => x
|
||||||
|
end.
|
||||||
|
|
||||||
|
Definition dnot (x : dyn) : dyn :=
|
||||||
|
match x with
|
||||||
|
| Bool b => Bool (negb b)
|
||||||
|
| x => x
|
||||||
|
end.
|
||||||
|
|
||||||
|
Inductive xform :=
|
||||||
|
| Identity
|
||||||
|
| Compose (xf1 xf2 : xform)
|
||||||
|
| Map (xf1 : xform)
|
||||||
|
| Filter (xf1 : xform)
|
||||||
|
|
||||||
|
| ConstantBool (b : bool)
|
||||||
|
| ConstantNumber (n : nat)
|
||||||
|
| IsZero
|
||||||
|
| Not.
|
||||||
|
|
||||||
|
Fixpoint transform (xf : xform) : dyn -> dyn :=
|
||||||
|
match xf with
|
||||||
|
| Identity => id
|
||||||
|
| Compose f1 f2 => compose (transform f1) (transform f2)
|
||||||
|
| Map f => dmap (transform f)
|
||||||
|
| Filter f => dfilter (transform f)
|
||||||
|
|
||||||
|
| ConstantBool b => fun _ => Bool b
|
||||||
|
| ConstantNumber n => fun _ => Number n
|
||||||
|
| IsZero => disZero
|
||||||
|
| Not => dnot
|
||||||
|
end.
|
||||||
|
|
||||||
|
Compute transform (Map IsZero) (List [Number 0; Number 1; Number 2; Number 0; Number 3]).
|
||||||
|
Compute transform (Filter IsZero) (List [Number 0; Number 1; Number 2; Number 0; Number 3]).
|
||||||
|
|
||||||
|
Fixpoint optimize (xf : xform) : xform.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
Theorem optimize_ok : forall xf x, transform (optimize xf) x = transform xf x.
|
||||||
|
Proof.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
(** ** Are these really optimizations? Can they ever grow a term's size? *)
|
||||||
|
|
||||||
|
Fixpoint size (xf : xform) : nat :=
|
||||||
|
match xf with
|
||||||
|
| Identity
|
||||||
|
| Not
|
||||||
|
| IsZero
|
||||||
|
| ConstantBool _
|
||||||
|
| ConstantNumber _ => 1
|
||||||
|
|
||||||
|
| Compose xf1 xf2 => 1 + size xf1 + size xf2
|
||||||
|
| Map xf
|
||||||
|
| Filter xf => 1 + size xf
|
||||||
|
end.
|
||||||
|
|
||||||
|
Theorem optimize_optimizes : forall xf, size (optimize xf) <= size xf.
|
||||||
|
Proof.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
(** ** More interestingly, the same is true of the action of these
|
||||||
|
transformations on concrete values! *)
|
||||||
|
|
||||||
|
Fixpoint sum (ls : list nat) : nat :=
|
||||||
|
match ls with
|
||||||
|
| nil => 0
|
||||||
|
| x :: ls' => x + sum ls'
|
||||||
|
end.
|
||||||
|
|
||||||
|
Fixpoint dsize (d : dyn) : nat :=
|
||||||
|
match d with
|
||||||
|
| Bool _
|
||||||
|
| Number _ => 1
|
||||||
|
| List ds => 1 + sum (map dsize ds)
|
||||||
|
end.
|
||||||
|
|
||||||
|
Theorem neverGrow : forall xf x,
|
||||||
|
dsize (transform xf x) <= dsize x.
|
||||||
|
Proof.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
|
||||||
|
(** * Combinators for syntax-tree transformations *)
|
||||||
|
|
||||||
|
(* Let's reprise the imperative language from the end of Interpreters. *)
|
||||||
|
|
||||||
|
Inductive arith : Set :=
|
||||||
|
| Const (n : nat)
|
||||||
|
| Var (x : var)
|
||||||
|
| Plus (e1 e2 : arith)
|
||||||
|
| Minus (e1 e2 : arith)
|
||||||
|
| Times (e1 e2 : arith).
|
||||||
|
|
||||||
|
Definition valuation := fmap var nat.
|
||||||
|
|
||||||
|
Fixpoint interp (e : arith) (v : valuation) : nat :=
|
||||||
|
match e with
|
||||||
|
| Const n => n
|
||||||
|
| Var x =>
|
||||||
|
match v $? x with
|
||||||
|
| None => 0
|
||||||
|
| Some n => n
|
||||||
|
end
|
||||||
|
| Plus e1 e2 => interp e1 v + interp e2 v
|
||||||
|
| Minus e1 e2 => interp e1 v - interp e2 v
|
||||||
|
| Times e1 e2 => interp e1 v * interp e2 v
|
||||||
|
end.
|
||||||
|
|
||||||
|
Inductive cmd :=
|
||||||
|
| Skip
|
||||||
|
| Assign (x : var) (e : arith)
|
||||||
|
| Sequence (c1 c2 : cmd)
|
||||||
|
| Repeat (e : arith) (body : cmd).
|
||||||
|
|
||||||
|
Fixpoint selfCompose {A} (f : A -> A) (n : nat) : A -> A :=
|
||||||
|
match n with
|
||||||
|
| O => fun x => x
|
||||||
|
| S n' => fun x => selfCompose f n' (f x)
|
||||||
|
end.
|
||||||
|
|
||||||
|
Lemma selfCompose_extensional : forall {A} (f g : A -> A) n x,
|
||||||
|
(forall y, f y = g y)
|
||||||
|
-> selfCompose f n x = selfCompose g n x.
|
||||||
|
Proof.
|
||||||
|
induct n; simplify; try equality.
|
||||||
|
|
||||||
|
rewrite H.
|
||||||
|
apply IHn.
|
||||||
|
trivial.
|
||||||
|
Qed.
|
||||||
|
|
||||||
|
Fixpoint exec (c : cmd) (v : valuation) : valuation :=
|
||||||
|
match c with
|
||||||
|
| Skip => v
|
||||||
|
| Assign x e => v $+ (x, interp e v)
|
||||||
|
| Sequence c1 c2 => exec c2 (exec c1 v)
|
||||||
|
| Repeat e body => selfCompose (exec body) (interp e v) v
|
||||||
|
end.
|
||||||
|
|
||||||
|
Fixpoint seqself (c : cmd) (n : nat) : cmd :=
|
||||||
|
match n with
|
||||||
|
| O => Skip
|
||||||
|
| S n' => Sequence c (seqself c n')
|
||||||
|
end.
|
||||||
|
|
||||||
|
(* Now consider a more abstract way of describing optimizations concisely. *)
|
||||||
|
|
||||||
|
Record rule := {
|
||||||
|
OnCommand : cmd -> cmd;
|
||||||
|
OnExpression : arith -> arith
|
||||||
|
}.
|
||||||
|
|
||||||
|
Fixpoint bottomUp (r : rule) (c : cmd) : cmd :=
|
||||||
|
match c with
|
||||||
|
| Skip => r.(OnCommand) Skip
|
||||||
|
| Assign x e => r.(OnCommand) (Assign x (r.(OnExpression) e))
|
||||||
|
| Sequence c1 c2 => r.(OnCommand) (Sequence (bottomUp r c1) (bottomUp r c2))
|
||||||
|
| Repeat e body => r.(OnCommand) (Repeat (r.(OnExpression) e) (bottomUp r body))
|
||||||
|
end.
|
||||||
|
|
||||||
|
Definition crule (f : cmd -> cmd) : rule :=
|
||||||
|
{| OnCommand := f; OnExpression := fun e => e |}.
|
||||||
|
Definition erule (f : arith -> arith) : rule :=
|
||||||
|
{| OnCommand := fun c => c; OnExpression := f |}.
|
||||||
|
Definition andThen (r1 r2 : rule) : rule.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
Definition plus0 := erule (fun e =>
|
||||||
|
match e with
|
||||||
|
| Plus e' (Const 0) => e'
|
||||||
|
| _ => e
|
||||||
|
end).
|
||||||
|
Definition unrollLoops := crule (fun c =>
|
||||||
|
match c with
|
||||||
|
| Repeat (Const n) body => seqself body n
|
||||||
|
| _ => c
|
||||||
|
end).
|
||||||
|
|
||||||
|
Compute bottomUp plus0
|
||||||
|
(Sequence (Assign "x" (Plus (Var "x") (Const 0)))
|
||||||
|
(Assign "y" (Var "x"))).
|
||||||
|
|
||||||
|
Compute bottomUp unrollLoops
|
||||||
|
(Repeat (Plus (Const 2) (Const 0))
|
||||||
|
(Sequence (Assign "x" (Plus (Var "x") (Const 0)))
|
||||||
|
(Assign "y" (Var "x")))).
|
||||||
|
|
||||||
|
Compute bottomUp (andThen plus0 unrollLoops)
|
||||||
|
(Repeat (Plus (Const 2) (Const 0))
|
||||||
|
(Sequence (Assign "x" (Plus (Var "x") (Const 0)))
|
||||||
|
(Assign "y" (Var "x")))).
|
||||||
|
|
||||||
|
Definition correct (r : rule) : Prop.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
Theorem crule_correct : forall f,
|
||||||
|
(forall c v, exec (f c) v = exec c v)
|
||||||
|
-> correct (crule f).
|
||||||
|
Proof.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
Theorem erule_correct : forall f,
|
||||||
|
(forall e v, interp (f e) v = interp e v)
|
||||||
|
-> correct (erule f).
|
||||||
|
Proof.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
Theorem andThen_correct : forall r1 r2,
|
||||||
|
correct r1
|
||||||
|
-> correct r2
|
||||||
|
-> correct (andThen r1 r2).
|
||||||
|
Proof.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
Theorem bottomUp_correct : forall r,
|
||||||
|
correct r
|
||||||
|
-> forall c v, exec (bottomUp r c) v = exec c v.
|
||||||
|
Proof.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
Definition rBottomUp (r : rule) : rule.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
Theorem rBottomUp_correct : forall r,
|
||||||
|
correct r
|
||||||
|
-> correct (rBottomUp r).
|
||||||
|
Proof.
|
||||||
|
Admitted.
|
||||||
|
|
||||||
|
Definition zzz := Assign "x" (Plus (Plus (Plus (Var "x") (Const 0)) (Const 0)) (Const 0)).
|
||||||
|
|
||||||
|
Compute bottomUp plus0 zzz.
|
||||||
|
Compute bottomUp (rBottomUp plus0) zzz.
|
||||||
|
Compute bottomUp (rBottomUp (rBottomUp plus0)) zzz.
|
||||||
|
Compute bottomUp (rBottomUp (rBottomUp (rBottomUp plus0))) zzz.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(** * Motivating continuations with search problems *)
|
(** * Motivating continuations with search problems *)
|
||||||
|
|
||||||
Fixpoint allSublists {A} (ls : list A) : list (list A) :=
|
Fixpoint allSublists {A} (ls : list A) : list (list A) :=
|
||||||
|
@ -146,8 +431,6 @@ Fixpoint allSublists {A} (ls : list A) : list (list A) :=
|
||||||
|
|
||||||
Compute allSublists [1; 2; 3].
|
Compute allSublists [1; 2; 3].
|
||||||
|
|
||||||
Definition sum ls := fold_left plus ls 0.
|
|
||||||
|
|
||||||
Fixpoint sublistSummingTo (ns : list nat) (target : nat) : option (list nat) :=
|
Fixpoint sublistSummingTo (ns : list nat) (target : nat) : option (list nat) :=
|
||||||
match filter (fun ns' => if sum ns' ==n target then true else false) (allSublists ns) with
|
match filter (fun ns' => if sum ns' ==n target then true else false) (allSublists ns) with
|
||||||
| ns' :: _ => Some ns'
|
| ns' :: _ => Some ns'
|
||||||
|
|
Loading…
Reference in a new issue