// F# Monadically label n-ary tree

let MMap f xs =

let rec MMap' (f, xs', out) =

state {

match xs' with

| h :: t -> let! h' = f(h)

return! MMap'(f, t, List.append out [h'])

| [] -> return out

}

MMap' (f, xs, [])

type 'a ntree = | NLeaf of 'a

| NNode of 'a ntree list

let rec private MNNode (x) =

match x with

| NLeaf(c) -> state { let! x = GetState

do! SetState (x + 1)

return NLeaf(c,x) }

| NNode(xs) -> state { let! xs' = MMap MNNode xs

return NNode(xs') }

let MNLabel x = Execute(MNNode(x))

## Saturday, 13 December 2008

### F# Monadically label n-ary tree

### F# State Monad

//F# State Monad

type State<'state, 'a> = State of ('state ->'a * 'state)

type StateMonad() =

member b.Bind(m, f) = State (fun s -> let r = match m with

| State f -> f s

match r with

| (v,s) -> match f v with

| State f -> f s)

member b.Return(x) = State (fun s -> x, s)

let state = StateMonad()

let GetState = State (fun s -> s, s)

let SetState s = State (fun _ -> (), s)

let Execute m s = match m with

| State f -> let r = f s

match r with

|(x,_) -> x

### F# Monadic tree labeller

open StateMonad

type 'a tree = | Leaf of 'a

| Node of 'a tree * 'a tree

// F# Monadic tree labeller

let rec private mNode x =

match x with

| Leaf(c) -> state { let! x = GetState

do! SetState (x + 1)

return Leaf(c,x) }

| Node(l,r) -> state { let! l = mNode(l)

let! r = mNode(r)

return Node(l,r) }

let mLabel x = Execute(mNode(x))

// F# Non-Monadic manual state passing tree labeller

let Label a s =

let rec Lab' a s =

match a with

|Leaf(c) -> (Leaf(c,s), s + 1)

|Node(l,r) -> let l' = Lab' l s

let r' = Lab' r (snd l')

(Node(fst l', fst r'), (snd r'))

fst (Lab' a s)

### The List Monad in F#

## Wednesday, 3 December 2008

### F# Monadic Parser - Calculator Example.

//F# Monadic Parser - Calculator Example :)))

// Grammar

//expr ::= expr addop term j term

//term ::= term mulop factor j factor

//factor ::= digit j ( expr )

//digit ::= 0 j 1 j : : : j 9

//addop ::= + j -

//mulop ::= * j /

let addOp = parser { let! _ = symb "+"

return (+) } +++ parser { let! _ = symb "-"

return (-) }

let mulOp = parser { let! _ = symb "*"

return (*) } +++ parser { let! _ = symb "/"

return (/) }

let digit = parser { let! x = token (sat (fun ch -> Char.IsDigit(ch)))

return Char.GetNumericValue(x) - Char.GetNumericValue('0') }

let rec expr = chainl1 term addOp

and term = chainl1 factor mulOp

and factor = digit +++ parser { let! _ = symb "("

let! n = expr

let! _ = symb ")"

return n }

let parse s = match apply expr s with

| [] -> failwith "failed to parse"

| (ret, _)::xs -> ret

parse "5 * (3 + 4)"

|> printf "%A"

### F# Parsers combinators.

// F# Parsers combinators :))

open System

//A parser which successfully consumes the first character

//if the argument string is non-empty, and fails otherwise.

let item = Parser (fun cs -> match cs with

| "" -> []

| cs -> [cs.[0], cs.Substring(1)])

//A combinator sat that takes a predicate, and yields a parser that

//consumes a single character if it satisfies the predicate, and fails otherwise.

let sat p = parser { let! c = item

if p c then

return c }

//A parser for specific characters

let char c = sat (fun s -> c = s)

//Parse a specific string

let rec stringp s = match s with

| "" -> parser { return [] }

| xs -> parser { let! c = char xs.[0]

let! cs = stringp (xs.Substring(1))

return c::cs }

//The many combinator permits zero

//or more applications of p, while many1 permits one or more.

let rec many1 p = parser { let! x = p

let! xs = many p

return (x::xs) }

and many p = (many1 p) +++ parser { return [] }

//Parse repeated applications of a parser p, separated by applications of a parser

//op whose result value is an operator that is assumed to associate to the left,

//and which is used to combine the results from the p parsers.

and chainl1 p op =

let rec rest a = parser { let! f = op

let! b = p

return! rest (f a b) } +++ parser { return a }

parser { let! a = p

return! rest a }

//Parse a string of spaces.

let space = many (sat (fun s -> Char.IsWhiteSpace s))

//Parse a token using a parser p, throwing away any trailing space.

let token p = parser { let! a = p

let! _ = space

return a }

//Parse a symbolic token:

let symb cs = token (stringp cs)

//Apply a parser p, throwing away any leading space:

let apply p = extract (parser { let! _ = space

let! r = p

return r })

### F# Parser Monad (http://www.cs.nott.ac.uk/~gmh/pearl.pdf)

// F# Parser Monad (http://www.cs.nott.ac.uk/~gmh/pearl.pdf)

type Parser<'a> = Parser of (string ->('a * string) list)

let extract(Parser(f)) = f

type ParserMonad() =

member b.Bind(p, f) = Parser (fun cs ->

let r = extract(p) cs

let r' = List.map (fun (a,cs') -> extract(f a) cs') r

List.concat r')

member b.Return(x) = Parser (fun cs -> [x,cs])

member b.Zero() = Parser (fun cs -> [])

let (++) p q = Parser(fun cs -> List.append (extract p cs) (extract q cs))

let (+++) p q = Parser(fun cs -> match (extract(p ++ q) cs) with

| [] -> []

| x::xs -> [x])

let parser = ParserMonad()

Subscribe to:
Posts (Atom)