$\newcommand{\defeq}{\mathrel{\mathop:}=}$

2007/07/06

Some Folds & Unfolds

(* some helper functions *)

let null = function [] -> true | x :: xs -> false

let first = function (x, y) -> x

let second = function (x, y) -> y

(* foldr and unfoldr on lists *)

let rec foldr f e xs =
match xs with
[] -> e
| x :: xs -> f x (foldr f e xs)

let rec unfoldr p f s =
if p s then [] else let (x, ns) = f s in x :: unfoldr p f ns

(* now folds and unfolds follow *)

let sum = foldr (fun x y -> x + y) 0

let map f = foldr (fun x xs -> f x :: xs) []

let couple xs ys = unfoldr
(function ([], ys) -> true | (xs, []) -> true | (xs, ys) -> false)
(function (x :: xs, y :: ys) -> ((x, y), (xs, ys)))
(xs, ys)

let allpairs xs ys =
let rec aps = function
([], y :: ys, zs) -> aps (zs, ys, zs)
| (x :: xs, y :: ys, zs) -> ((x, y), (xs, y :: ys, zs))
in
unfoldr (function ([], y :: [], zs) -> true
| (xs, ys, zs) -> (null ys) || (null zs)) aps (xs, ys, xs)

let innerproduct xs ys =
foldr (fun (x, y) n -> x * y + n) 0 (couple xs ys)

let transpose =
let rec t xs yss =
match (xs, yss) with
([], yss) -> []
| (x :: xs, []) -> [x] :: t xs []
| (x :: xs, ys :: yss) -> (x :: ys) :: t xs yss
in
foldr t []


let multiply a b =
sum (map (fun (x, y) -> innerproduct x y) (allpairs a (transpose b)))


--

let allpairs xs ys =
let a x xs =
foldr (fun y ys -> (x, y) :: ys) [] ys @ xs
in
foldr a [] xs

let transpose =
let t = fun xs -> function
[] -> foldr (fun x xss -> [x] :: xss) [] xs
| yss -> map (fun (x, xs) -> x :: xs) (couple xs yss)
in foldr t []


transpose 的改良很容易。t xsyss case 看得出來是 hylomorphism，目前在 unfold/fold 之間會產生一個 temporary list。解決辦法當然是明確引進 hylomorphism：

(* hylor f e p g s = foldr f e (unfoldr p g s) *)
let rec hylor f e p g s =
if p s then e else let (x, ns) = g s in f x (hylor f e p g ns)


let hasnull =
(function ([], ys) -> true | (xs, []) -> true | (xs, ys) -> false)

let couple xs ys = unfoldr
hasnull
(fun (x :: xs, y :: ys) -> ((x, y), (xs, ys)))
(xs, ys)


foldr (fun (x, xs) xss -> (x :: xs) :: xss) []
(unfoldr nullpair (function (x :: xs, y :: ys) -> ((x, y), (xs, ys))) (xs, yss))


let transpose =
let t = fun xs -> function
[] -> foldr (fun x xss -> [x] :: xss) [] xs
| yss -> hylor (fun (x, xs) xss -> (x :: xs) :: xss)
[]
hasnull
(fun (x :: xs, y :: ys) -> ((x, y), (xs, ys)))
(xs, yss)
in foldr t []


let innerproduct xs ys = hylor
(fun (x, y) n -> x * y + n)
0
hasnull
fun (x :: xs, y :: ys) -> ((x, y), (xs, ys)))
(xs, ys)


--

allpairs 比較礙眼的地方是那個 @，雖然對時間複雜度沒有影響，但常數能消還是盡量消。其實用直覺很快，不過我照規矩來做一次 XD。首先，@ 也是一個 fold，let cons x xs = x :: xs，從定義容易推得

a @ b = foldr cons b a


  foldr cons xs (f x y ys)
= { definition of f }
foldr cons xs ((x, y) :: ys)
= { definition of foldr }
cons (x, y) (foldr cons xs ys)
= { definition of cons }
(x, y) :: foldr cons xs ys
= { definition of f (!!) }
f x y (foldr cons xs ys)


  foldr (f x) [] ys @ xs
= { @ is a fold }
foldr cons xs (foldr (f x) [] ys)
= { fold fusion }
foldr (f x) (foldr cons xs []) ys
= { definition of foldr }
foldr (f x) xs ys


let allpairs xs ys =
let a x xs =
foldr (fun y ys -> (x, y) :: ys) xs ys
in
foldr a [] xs


--

a @ b = foldr cons b a 其實也可以用（很簡單的）fold fusion 得到。除了 id 以外的所有（簡單的）folds 都可以這麼做，即利用 "id is a fold" 的性質。邏輯上可以先確立 id 是 fold，其他所有的（簡單的）folds 就可以用 fold fusion 導出其 fold 形式。把 @ b 視為一個 function of type 'a list -> 'a list，如下推導：

  a @ b
= { identity function }
(id a) @ b
= { id is a fold }
(foldr cons [] a) @ b
= { fold fusion, see below }
foldr cons ([] @ b) a
= { definition of @ }
foldr cons b a

(* condition check for fold fusion *)

(cons x xs) @ b
= { definition of cons }
(x :: xs) @ b
= { definition of @ }
x :: (xs @ b)
= { definition of cons }
cons x (xs @ b)


    h = foldr f e    for some f, e
iff h xs = h ys ==> h (x :: xs) = h (x :: ys)


Labels: ,

Anonymous7/07/2007 12:58 am 說：

Weijin改用blogger了...為啥我都不知道