Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Experiments with fusable functional vectors in Standard ML
  • Loading branch information
melsman committed Aug 15, 2012
1 parent 51b4bb3 commit 23c459c
Show file tree
Hide file tree
Showing 12 changed files with 381 additions and 0 deletions.
8 changes: 8 additions & 0 deletions AmrPutVec.mlb
@@ -0,0 +1,8 @@
local
$(SML_LIB)/basis/basis.mlb
in
vec/vec.mlb
AmrPut.sml
AmrPutVec.sml
AmrPutVecTest.sml
end
70 changes: 70 additions & 0 deletions AmrPutVec.sml
@@ -0,0 +1,70 @@
functor AmrPutVec(V : VEC) =
struct

fun curry f x y = f(x,y)

(* Pointwise manipulation of vectors-slices and scalars *)
infix ^*^ ^+^ -^ *^

fun v1 ^*^ v2 = V.map2 (curry op*) v1 v2
fun v1 ^+^ v2 = V.map2 (curry op+) v1 v2
fun c -^ v = V.map (fn x => c - x) v
fun c *^ v = V.map (fn x => c * x) v

fun pmax v c = V.map (fn x => Real.max(x, c)) v
fun ppmax v1 v2 = V.map2 (curry Real.max) v1 v2

fun vtail v = V.dr 1 v
fun vinit v = V.tk (V.length v - 1) v

fun binom expiry =
let (* standard econ parameters *)
val strike = 100.0
val bankDays = 252
val s0 = 100.0
val r = 0.03 val alpha = 0.07 val sigma = 0.20

val n = expiry*bankDays
val dt = real expiry / real n
val u = Math.exp(alpha*dt+sigma* Math.sqrt dt)
val d = Math.exp(alpha*dt-sigma* Math.sqrt dt)
val stepR = Math.exp(r*dt)
val q = (stepR-d)/(u-d)
val qUR = q/stepR val qDR = (1.0-q)/stepR

val uPow = V.tabulate (n+1) (fn i => Math.pow(u, real i))
val uPow = V.memoize uPow
val dPow = V.tabulate (n+1) (fn i => Math.pow(d, real (n-i)))
val dPow = V.memoize dPow

val st = s0 *^ (uPow ^*^ dPow)
val finalPut = pmax (strike -^ st) 0.0

(* for (i in n:1) {
St<-S0*u.pow[1:i]*d.pow[i:1]
put[1:i]<-pmax(strike-St,(qUR*put[2:(i+1)]+qDR*put[1:i]))
}
*)
fun prevPut (i, put) =
let val st = s0 *^ ((V.tk i uPow) ^*^ (V.dr (n+1-i) dPow))
val put = V.memoize put
in ppmax(strike -^ st) ((qUR *^ vtail put) ^+^ (qDR *^ vinit put))
end
val first = V.foldl prevPut finalPut (V.tabulate n (fn i => n-i))

in V.sub (first, 0)
end

(* Expected results for binom:
expiry price
1 6.74543295135838
8 13.94568883837488
16 16.22259138591852
30 17.65370590709356
64 18.42993156506373
128 18.573732615311993
*)


end
13 changes: 13 additions & 0 deletions AmrPutVecTest.sml
@@ -0,0 +1,13 @@
(*
structure AP = AmrPutVec(Fvec)
structure AP = AmrPutVec(ListVec)
*)
structure AP = AmrPut

fun pr n =
let val _ = print ("AmrPut.binom(" ^ Int.toString n ^ ") = ")
val r = AP.binom n
in print (Real.toString r ^ "\n")
end

val _ = List.app pr [1,8,16,30,64,128]
19 changes: 19 additions & 0 deletions Makefile
@@ -0,0 +1,19 @@

#MLKITLIB=$(HOME)/mlkit-4.3.6
#MLCOMP=SML_LIB=$(MLKITLIB)/lib/mlkit $(MLKITLIB)/bin/mlkit
MLCOMP=mlton

UTEST_FILES=$(shell ls utest/*.{sig,sml,mlb})
VEC_FILES=$(shell ls vec/*.{sig,sml,mlb})
.PHONY: all
all: runvec

runvec: $(VEC_FILES) $(UTEST_FILES)
$(MLCOMP) -output $@ vec/vec.mlb

AmrPutVec: AmrPutVec.sml AmrPutVecTest.sml $(VEC_FILES) $(UTEST_FILES)
$(MLCOMP) -output $@ AmrPutVec.mlb

clean:
find . -name MLB | xargs rm -rf
rm -f runvec apl AmrPutVec *~ vec/*~ utest/*~
6 changes: 6 additions & 0 deletions utest/utest.mlb
@@ -0,0 +1,6 @@
local
$(SML_LIB)/basis/basis.mlb
in
utest.sig
utest.sml
end
9 changes: 9 additions & 0 deletions utest/utest.sig
@@ -0,0 +1,9 @@
(* Auxiliary functions for test cases *)

signature UTEST = sig
val start : string -> string -> unit
val finish : unit -> unit
val tst : string -> (unit -> bool) -> unit
val tstopt : string -> (unit -> string option) -> unit
val all : string -> ('a -> bool) -> 'a list -> unit
end
45 changes: 45 additions & 0 deletions utest/utest.sml
@@ -0,0 +1,45 @@
structure UTest :> UTEST = struct

val counts = {ok=ref 0, wrong=ref 0, exn=ref 0}
fun incr l =
let val r = l counts
in r := !r + 1
end
fun ok() = (incr #ok; "OK")
fun wrong s = (incr #wrong; if s = "" then "WRONG" else "WRONG - " ^ s)
fun exn() = (incr #exn; "EXN")
fun check f =
(case f () of SOME s => wrong s
| NONE => ok())
handle e => (exn() ^ General.exnMessage e)

fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n")
fun tstopt s f = tst0 s (check f)
fun tst s f = tst0 s (check (fn x => if f() then NONE else SOME""))
fun all s f xs =
tst s (fn() => List.all f xs)

val data : (string*string) option ref = ref NONE
fun start f s =
(data := SOME (f,s);
#ok counts := 0;
#wrong counts := 0;
#exn counts := 0;
print ("[File " ^ f ^ ": Testing " ^ s ^ "...]\n"))

fun finish () =
let val ok = ! (#ok counts)
val wrong = ! (#wrong counts)
val exn = ! (#exn counts)
in
case !data of
NONE => print "[Test not properly started]\n"
| SOME (f,s) =>
(print ("[Finished testing file " ^ f ^ " - " ^ s ^ "]\n");
if wrong = 0 andalso exn = 0 then
print ("[Successfully ran all " ^ Int.toString ok ^ " tests]\n")
else
print ("[Failure during tests - ok: " ^ Int.toString ok ^ ", wrong: " ^ Int.toString wrong ^ ", exn: " ^ Int.toString exn ^ "]\n")
)
end
end
81 changes: 81 additions & 0 deletions vec/fvec.sml
@@ -0,0 +1,81 @@
(* Fusable vectors *)

structure Fvec :> VEC = struct

type 'a t = int * (int -> 'a)

fun fromList (l:'a list) : 'a t =
let val a = Vector.fromList l
in (Vector.length a, fn i => Vector.sub(a,i))
end

fun map f (n,g) = (n, f o g)

fun fmap a v = map (fn f => f v) a

fun iter (n,e,f) =
let fun loop (i,a) =
if i >= n then a
else loop (i+1, f(i,a))
in loop(0,e)
end

fun iter' (n,e,f) =
let fun loop (i,a) =
if i <= 0 then a
else let val i2 = i-1
in loop (i2, f(i2,a))
end
in loop(n,e)
end

fun foldl f e (n,g) = iter(n,e, fn (i,a) => f(g i,a))
fun foldr f e (n,g) = iter'(n,e, fn (i,a) => f(g i,a))

fun emp _ = raise Fail "impossible"
fun empty () = (0, emp)

fun tk n (a as (m,g)) =
if n >= m then a
else (n,g)

fun dr n (m,g) =
if n >= m then empty()
else (m-n,fn i => g(i+n))

fun tabulate n f = (n,f)

fun list a = foldr (op ::) nil a

fun length (n,_) = n

fun map2 f (n1,f1) (n2,f2) =
if n1 <> n2 then raise Fail "map2 applied to vectors of different lengths"
else (n1,fn i => f(f1 i)(f2 i))

fun single x = fromList [x]

fun eq beq (a1,a2) =
length a1 = length a2 andalso
(foldl(fn (x,a) => x andalso a) true
(map2 (fn x => fn y => beq(x,y)) a1 a2))

fun concat (n1,f1) (n2,f2) =
(n1+n2, fn i => if i < n1 then f1 i else f2 (i-n1))

fun flatten v =
let val len = foldl (fn (a,l) => length a + l) 0 v
val f = foldr (fn ((n,f),g) =>
fn i => if i < n then f i else g (i-n)) emp v
in (len,f)
end

fun sub ((n,f),i) =
if i > n-1 orelse i < 0 then raise Subscript
else f i

fun memoize (n,f) =
let val v = Vector.tabulate(n,f)
in (n, fn i => Vector.sub(v,i))
end
end
42 changes: 42 additions & 0 deletions vec/list_vec.sml
@@ -0,0 +1,42 @@
structure ListVec : VEC = struct
type 'a t = 'a list

fun eq beq (nil,nil) = true
| eq beq (x::xs, y::ys) = beq(x, y) andalso eq beq (xs,ys)
| eq beq _ = false

val empty = fn () => []
val single = fn x => [x]

fun dr 0 l = l
| dr n [] = []
| dr n (x::l) = dr (n-1) l

fun tk 0 l = []
| tk n [] = []
| tk n (x::l) = x :: tk (n-1) l

val list = fn x => x
val fromList = fn x => x
open List
val concat = fn x => fn y => x @ y
fun map2 f _ nil = nil
| map2 f nil _ = nil
| map2 f (x::xs) (y::ys) = f x y :: map2 f xs ys
fun fmap gs x =
let fun loop [] = []
| loop (g::gs) = g x :: loop gs
in loop gs
end
fun tabulate n f =
let fun gen x = if x >= n then []
else f x :: gen (x+1)
in gen 0
end
fun flatten nil = nil
| flatten (x::xs) = x @ flatten xs

val sub = List.nth

val memoize = fn x => x
end
55 changes: 55 additions & 0 deletions vec/test_vec.sml
@@ -0,0 +1,55 @@
(* Simple unit tests for the vector library *)

functor Test(structure V : VEC
val name : string) = struct

open UTest

val () = start "test_vec.sml" ("structure " ^ name)

local
val is_debug = false
in
fun debug s = if is_debug then print s
else ()
end

fun tsta s f =
tst s (fn () =>
let val (a1 : int V.t,a2) = f()
in V.eq (op =) (a1, a2)
end)

val a0 = V.tabulate 3 (fn x => x)
val a1 = V.map (fn x => x + 1) a0
val _ = tsta "map1" (fn () => (a1, V.fromList[1,2,3]))

val _ = tsta "concat" (fn () => (V.concat a0 a1, V.fromList[0,1,2,1,2,3]))

val _ = tsta "tk0" (fn () => (V.tk 0 a1, V.empty()))
val _ = tsta "tk1" (fn () => (V.tk 2 a1, V.fromList[1,2]))
val _ = tsta "tk2" (fn () => (V.tk 3 a1, a1))
val _ = tsta "dr0" (fn () => (V.dr 0 a1, a1))
val _ = tsta "dr1" (fn () => (V.dr 1 a1, V.fromList[2,3]))
val _ = tsta "dr2" (fn () => (V.dr 3 a1, V.empty()))

val _ = tsta "map2" (fn () => (V.map2 (fn x => fn y => x * y) a0 a1, V.fromList[0,2,6]))

val f2 = V.fromList[fn x => x * x, fn x => x + x]
val _ = tsta "fmap" (fn () => (V.fmap f2 5, V.fromList[25,10]))
val _ = tsta "empty" (fn () => (V.empty(), V.fromList[]))
val _ = tsta "single" (fn () => (V.single 8, V.fromList[8]))
val _ = tst "length" (fn () => V.length a0 = 3 andalso V.length(V.empty()) = 0)
val _ = tst "list" (fn () => V.list a1 = [1,2,3])
val _ = tst "foldl" (fn () => V.foldl (op +) 0 a1 = 6)
val _ = tsta "flatten" (fn () => (V.flatten(V.fromList[a0,a1,V.empty(),a1]), V.fromList[0,1,2,1,2,3,1,2,3]))

val () = finish()

end

local
structure X = Test(structure V = ListVec val name = "ListVec")
structure Y = Test(structure V = Fvec val name = "Fvec")
in
end
10 changes: 10 additions & 0 deletions vec/vec.mlb
@@ -0,0 +1,10 @@
local
$(SML_LIB)/basis/basis.mlb
in
vec.sig
list_vec.sml
fvec.sml
(* ../utest/utest.mlb
test_vec.sml
*)
end
23 changes: 23 additions & 0 deletions vec/vec.sig
@@ -0,0 +1,23 @@
(* Basic vectors *)

signature VEC = sig
type 'a t
val eq : ('a * 'a -> bool) -> 'a t * 'a t -> bool
val single : 'a -> 'a t
val empty : unit -> 'a t
val fromList : 'a list -> 'a t
val tk : int -> 'a t -> 'a t
val dr : int -> 'a t -> 'a t
val length : 'a t -> int
val foldl : ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
val foldr : ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
val map : ('a -> 'b) -> 'a t -> 'b t
val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
val fmap : ('a -> 'b) t -> 'a -> 'b t
val list : 'a t -> 'a list
val concat : 'a t -> 'a t -> 'a t
val flatten : 'a t t -> 'a t
val tabulate : int -> (int -> 'a) -> 'a t
val sub : 'a t * int -> 'a
val memoize : 'a t -> 'a t
end

0 comments on commit 23c459c

Please sign in to comment.