Feeds:
Posts
Comments

Archive for the ‘F#’ Category

Here is a problem to solve:

Open windows notepad and start with a blank document. At one step, you can choose to type one of
the four below on the keyboard:
“A” “CTRL+A” “CTRL+C” “CTRL+V”

What is the maximal number of A’s you can have in the notepad after 10 steps?

Since each step has 4 options, 10 steps will generate 410 = 1,048,576 key stroke combinations. For each combination, we calculate the number of A’s, and find the combination that results in the maximal number.

In order to calculate the number of A’s for a combination, we need to maintain a state that consists of the current number of A’s, the number of A’s in the clipboard, and whether all text is selected.

For each key stroke in a combination, we determine the next state based on the current state and the key stroke. For example, when A is pressed, if the text is all selected, the number of A’s becomes 1 and the text is not all selected; if the text is not all selected, the number of A’s increases by 1 and the text becomes unselected.

We can define a function that takes a state and a key, and returns a new state.

type Key =
    | A
    | CtrlA
    | CtrlC
    | CtrlV

type State = { number: int; numberCopied: int; allSelected: bool }

let keyStroke state key =
    let a state =
        match state.allSelected with
        | true -> { number = 1; numberCopied = state.numberCopied; allSelected = false }
        | false -> { number = state.number + 1; numberCopied = state.numberCopied; allSelected = false }

    let ctrlA state =
        { number = state.number; numberCopied = state.numberCopied; allSelected = true }

    let ctrlC state =
        match state.allSelected with
        | true -> { number = state.number; numberCopied = state.number; allSelected = state.allSelected }
        | false -> { number = state.number; numberCopied = 0; allSelected = state.allSelected }

    let ctrlV state =
        match state.allSelected with
        | true -> { number = state.numberCopied; numberCopied = state.numberCopied; allSelected = false }
        | false -> { number = state.number + state.numberCopied; numberCopied = state.numberCopied; allSelected = false }

    match key with
    | A -> a state
    | CtrlA -> ctrlA state
    | CtrlC -> ctrlC state
    | CtrlV -> ctrlV state

We defined a sub-function for each key stroke option, and call them depending on the key passed in.

Given a combination of key strokes, how do we calculate how many A’s generated? We can use the fold function.

let evaluate combination =
    let state = combination |> List.fold (fun state k -> keyStroke state k) { number = 0; numberCopied = 0; allSelected = false }
    state.number

For each key stroke in the list, the keyStroke function is called to transit to the next state, with { number = 0; numberCopied = 0; allSelected = false } as the initial state. The number field of the last state will be the number of A’s accumulated.

Once we have the combinations, we can pipe the combinations into the Seq.fold function to find the answer. The curr value is the current combination which is a tuple of the key list and the number of A’s the key list generates. The max value is the combination that has the biggest number of A’s so far. The final output value will be the answer.

let answer = 
    combinations()
    |> Seq.fold 
        (fun max curr -> 
            let (_, number) = curr
            let (_, maxNumber) = max
            if maxNumber < number then
                curr
            else
                max
            ) ([], 0)

Now the only thing missing is how to generate those key stroke combinations. There are several options:

Option 1, using computation expression

We can define a workflow builder class, named Solver, that implements the Bind and Return methods.

type Solver() =
    member this.Bind(xs, f) =
        xs
        |> List.map (fun x -> f(x))
        |> List.concat
    member this.Return(x) = [x]
    member this.Delay(f) = f

The Bind method returns a new list by applying the f function to each element of the given list. The Return methods just convert an element to a list.

We can then find all combinations with the following code:

let keyOptions = [ A; CtrlA; CtrlC; CtrlV ]

let solver = Solver()

let combinations = solver {
    let! k0 = keyOptions
    let! k1 = keyOptions
    let! k2 = keyOptions
    let! k3 = keyOptions
    let! k4 = keyOptions
    let! k5 = keyOptions
    let! k6 = keyOptions
    let! k7 = keyOptions
    let! k8 = keyOptions
    let! k9 = keyOptions

    let keys = [k0;k1;k2;k3;k4;k5;k6;k7;k8;k9]
    let state = keys |> List.fold (fun state k -> keyStroke state k) { number = 0; numberCopied = 0; allSelected = false } 
    return (keys, state.number)
}

The code is pretty easy to read once you understand how computation expressions work. I don’t quite like the fact that I had to write 10 let! bindings.

Option 2, using 2 bits to represent a key option

Since there are 4 key options, we can 2 bits to represent all key options, and 20 bits to represent all key combinations meaning we can use the numbers from 0 to 0xfffff to represent all key combinations of 10 steps with each step having 4 options. In the following code, the toCombination function converts a given number of a list of Keys. For each number from 0 to 0xfffff, we call toCombination to convert the number to a list of Keys and generate a sequence of lists of Keys using the sequence expression.

let keyOptions = [| A; CtrlA; CtrlC; CtrlV; |]

let toKey n =
    keyOptions |> Array.item n

let toCombination length number =
    let mask = 0x3
    [0..(length-1)] |> List.map (fun i -> ((number >>> i * 2) &&& mask |> toKey))

let allCombinations = seq {
    for i = 0 to 0xfffff do
        let c = toCombination 10 i
        yield (c, c |> evaluate)
}

The code is very simple, but what if, for example, there are 5 key options whereby using 3 bits is more than enough to represent 5 options?

Option 3, using a number system

We can generalize option 2 by using a number system with any base. Let’s say we want to have 10 steps and 5 key options, there will be totally 510 combinations. We convert each number from 0 to 510 to a base 5 number with 10 digits, each of which represents a key option.

let keyOptions = [| A; CtrlA; CtrlC; CtrlV; |]

let toKey n =
    keyOptions |> Array.item n

let toBase (b: int) (number: bigint) =
    let rec getDigits (n: bigint) digits =
        let bb = b |> bigint
        if n >= bb then
            let d = n % bb |> int
            let nn = n / bb
            getDigits nn (d::digits)
        else
            (n |> int)::digits

    getDigits number []
 
let toCombination b length (number: bigint) =
    let digits = toBase b number
    let diff = length - (digits |> List.length)
    match diff with
    | 0 -> digits
    | 1 -> 0::digits
    | _  -> [0 .. diff - 1] |> List.fold (fun s _ -> 0::s) digits

let allCombinations optionCount length = seq {
    let max = (double)optionCount ** (double)length |> bigint

    let _toCombination = toCombination optionCount length

    for i in 0I .. max do
        let c = _toCombination i |> List.map (fun i -> toKey i)
        yield (c, c |> evaluate)
}

The implementation is similar to option 2. The only difference is how to extract the digits from a number.

Conclusion

There are many ways to generating the key combinations. In fact, we can also use List.collect with List.map in a recursive function to generate the all combinations:

let allCombinations length options = seq {
    let rec expand currLength combinations =
        match currLength = length with
        | true -> combinations
        | false -> 
            expand (currLength + 1) (options |> List.collect (fun o -> combinations |> List.map (fun c -> o::c)))

    yield! expand 1 (options |> List.map (fun o -> [o])) 
}

I’ve gained more knowledge about F# and functional programming in general when I was exploring various solutions. I particularly like the fold function which allows me to mutate a state in purely functional way.

By the way, the answer of the problem is:

val answer : Key list * int =
([A; A; A; A; CtrlA; CtrlC; CtrlV; CtrlV; CtrlV; CtrlV], 16)

Thanks for reading!

Read Full Post »

I was given a puzzle to solve recently. The puzzles is a cryptarithmetic problem: 5’s twelve + thirty = ninety.

T W E L V E
T W E L V E
T W E L V E
T W E L V E
T W E L V E
T H I R T Y
————
N I N E T Y

Each letter represents a unique number from 0 to 9.

As a software engineer, I naturally wanted to solve this problem by writing a program, and I decided to use F#, in functional way.

Here is the code I wrote:

open System

let digits = [0..9] |> Set.ofList

let remainingDigits removedDigits =
    Set.difference digits (Set.ofList removedDigits)

let toNumber digits =
    digits |> List.fold (fun number i -> number * 10 + i) 0

type PuzzleSolver() =
    member this.Bind(xs, f) =
        xs
        |> Set.map (fun x -> f(x))
        |> Set.filter (fun x -> x |> List.isEmpty |> not)
        |> Set.toList
        |> List.concat

    member this.Return(x) = [x]
    member this.ReturnFrom(x) = x

let solver = PuzzleSolver()

let solutions = solver {
    let! t = remainingDigits [0]
    let! w = remainingDigits [t]
    let! e = remainingDigits [t; w]
    let! l = remainingDigits [t; w; e]
    let! v = remainingDigits [t; w; e; l]
    let! h = remainingDigits [t; w; e; l; v]
    let! i = remainingDigits [t; w; e; l; v; h]
    let! r = remainingDigits [t; w; e; l; v; h; i]
    let! y = remainingDigits [t; w; e; l; v; h; i; r]
    let! n = remainingDigits [t; w; e; l; v; h; i; r; y]

    let TWELVE = toNumber [t; w; e; l; v; e]
    let THIRTY = toNumber [t; h; i; r; t; y]
    let NINETY = toNumber [n; i; n; e; t; y]

    if (TWELVE * 5 + THIRTY = NINETY) then
        return! [ ("T", t); ("W", w); ("E", e); ("L", l); ("V", v); 
                  ("H", h); ("I", i); ("R", r); ("Y", y); ("N", n) ]
    else return! []
}

solutions |> List.iter (fun (l, v) -> printfn "%s = %d" l v)

And the following is the result copied from the F# Interactive console of Visual Studio:

T = 1
W = 3
E = 0
L = 7
V = 6
H = 9
I = 4
R = 2
Y = 5
N = 8

val digits : Set<int> = set [0; 1; 2; 3; 4; 5; 6; 7; 8; ...]
val remainingDigits : removedDigits:int list -> Set<int>
val toNumber : digits:int list -> int
type PuzzleSolver =
    class
        new : unit -> PuzzleSolver
        member
            Bind : xs:Set<'c> * f:('c -> 'd list) -> 'd list
                when 'c : comparison and 'd : comparison
        member Return : x:'b -> 'b list
        member ReturnFrom : x:'a -> 'a
end

val solver : PuzzleSolver

val solutions : (string * int) list =
[("T", 1); ("W", 3); ("E", 0); ("L", 7); ("V", 6); ("H", 9); ("I", 4);
("R", 2); ("Y", 5); ("N", 8)]
val it : unit = ()

Let’s look at the F# code. The digits value is a set of 10 integers from 0 to 9. The remainingDigits function removes the given integers from the digits set and returns the remaining digits. The toNumber function converts the given digits to an integer.

At the heart of the algorithm is the PuzzleSolver computation expression. The Bind method takes a Set and a function that maps a value to a list, and returns a list.

member this.Bind(xs, f) =
    xs
    |> Set.map (fun x -> f(x))
    |> Set.filter (fun x -> x |> List.isEmpty |> not)
    |> Set.toList
    |> List.concat

The Bind() method pipes the given set to the Set.map function to create a set of list by mapping each element in the set to a list by calling the f function passed in. It then pipes the set of lists to Set.filter to create a new set by removing all empty lists. The new set of lists is then converted to a list of lists, which is passed to List.concat to flatten to a list.

The Return method just wraps the given value as a list. And the ReturnFrom method just returns the given value.

With the PuzzleSolver computation expression, we can solve the puzzle with following code:

let solutions = solver {
    let! t = remainingDigits [0]
    let! w = remainingDigits [t]
    let! e = remainingDigits [t; w]
    let! l = remainingDigits [t; w; e]
    let! v = remainingDigits [t; w; e; l]
    let! h = remainingDigits [t; w; e; l; v]
    let! i = remainingDigits [t; w; e; l; v; h]
    let! r = remainingDigits [t; w; e; l; v; h; i]
    let! y = remainingDigits [t; w; e; l; v; h; i; r]
    let! n = remainingDigits [t; w; e; l; v; h; i; r; y]

    let TWELVE = toNumber [t; w; e; l; v; e]
    let THIRTY = toNumber [t; h; i; r; t; y]
    let NINETY = toNumber [n; i; n; e; t; y]

    if (TWELVE * 5 + THIRTY = NINETY) then
        return! [ ("T", t); ("W", w); ("E", e); ("L", l); ("V", v);
                  ("H", h); ("I", i); ("R", r); ("Y", y); ("N", n) ]
    else return! []
}

The code essentially says that:

Let the identifier t be one of the digits from 1 to 9,

Let the identifier w be one of the digits from 0 to 9 except for t,

We bind each of the 10 identifiers to a different digit, we then calculate the values of TWELVE, THIRTY, and NINETY, if the 3 values meet the condition, which is TWELVE * 5 + THIRTY = NINETY, we return a list of pairs of a letter and the digit it represents, otherwise, an empty list is returned.

The let! Expression is just a syntax sugar for the Bind method. So

let! t = remainingDigits [0]

is essentially translated into

solver.Bind(remainingDigits [0], (fun t -> …) )

And the whole solutions expression is translated into nested method calls to the solver.Bind() method:

let solutions =
    solver.Bind(remainingDigits [0], fun t ->
    solver.Bind(remainingDigits [t], fun w ->
    solver.Bind(remainingDigits [t; w], fun e ->
    solver.Bind(remainingDigits [t; w; e], fun l ->
    solver.Bind(remainingDigits [t; w; e; l], fun v ->
    solver.Bind(remainingDigits [t; w; e; l; v], fun h ->
    solver.Bind(remainingDigits [t; w; e; l; v; h], fun i ->
    solver.Bind(remainingDigits [t; w; e; l; v; h; i], fun r ->
    solver.Bind(remainingDigits [t; w; e; l; v; h; i; r], fun y ->
    solver.Bind(remainingDigits [t; w; e; l; v; h; i; r; y], fun n ->

    let TWELVE = toNumber [t; w; e; l; v; e]
    let THIRTY = toNumber [t; h; i; r; t; y]
    let NINETY = toNumber [n; i; n; e; t; y]

    if (TWELVE * 5 + THIRTY = NINETY) then
        solver.ReturnFrom([ ("T", t); ("W", w); ("E", e); ("L", l); ("V", v);
                            ("H", h); ("I", i); ("R", r); ("Y", y); ("N", n) ])
    else solver.ReturnFrom([])
))))))))))

This is not too difficult to understand compared to the nested for loops if we were to solve it in imperative way.

let solutions2 =
    for t in (remainingDigits [0]) do
    for w in (remainingDigits [t]) do
    for e in (remainingDigits [t; w]) do
    for l in (remainingDigits [t; w; e]) do
    for v in (remainingDigits [t; w; e; l]) do
    for h in (remainingDigits [t; w; e; l; v]) do
    for i in (remainingDigits [t; w; e; l; v; h]) do
    for r in (remainingDigits [t; w; e; l; v; h; i]) do
    for y in (remainingDigits [t; w; e; l; v; h; i; r]) do
    for n in (remainingDigits [t; w; e; l; v; h; i; r; y]) do

        let TWELVE = toNumber [t;w;e;l;v;e]
        let THIRTY = toNumber [t;h;i;r;t;y]
        let NINETY = toNumber [n;i;n;e;t;y]

        if (TWELVE * 5 + THIRTY = NINETY) then
            printfn "TWELVE=%d, THIRTY=%d, NINETY=%d" TWELVE THIRTY NINETY

Read Full Post »

These are the notes I took when reading the slides written by Scott Wlaschin.

Functional Design Patterns Scott Wlaschin

Read Full Post »

I’ve written a few compilers, the most visible one being the PowerBuilder .NET compiler that can compile a PowerBuilder application into either a .NET Windows Forms application or an ASP.NET application. We used ANTLR 2 as the parser generator, which works great for us except for one thing: the context sensitive keywords. PowerScript, the programming language provided by PowerBuilder, allows some keywords, e.g. the keyword “update” of embedded SQL, to be used as identifiers outside of embedded SQL statements. We had to introduce a member variable in the lexer class to specify the current context that parser is in in order for so the lexer to do the right thing in different contexts.

Later I discovered Irony from irony.codeplex.com, that allows you to write grammar in C# code directly, which eliminates the step to generate a lexer and a parser classes from a grammar specification. Irony also has a Grammar Explorer with which you can debug and test your grammar. However, since the tool is still in beta stage, I haven’t invested a lot of time in it.

ANTLR and Irony may look very different, they have at least one thing in common: they both have two distinct phases: scanning and parsing, which means that, by default, the scanner doesn’t know what context the parser is in, thus making it harder to have the lexer to different things in different contexts.

I kept searching for other solutions until I found FParsec, a parser combinator library for F#, a functional programming language from Microsoft. A parser takes a string as the input and generates some form of output, e.g. an AST. By definition, a parser is a function. And therefore it is very natural to write parsers using functional programming languages. FParsec provides some basic parsers, which can be combined to parse higher language constructs of a particular language, until the highest level parser is defined to parse the entire compilation unit. There isn’t a distinct between lexing and parsing. You define parsers to parse both terminals and non-terminals. At any point in parsing, you can decide exactly which parser to use to parse the next token, making it very easy to support context sensitive keywords.

The following F# code is what I’ve written to parse BarModel script, whose grammar is appended at the end.
 
Ast.fs defines the AST nodes
module Ast
 
type Position = Above | Below
type Side = Left | Right
type StrokeStyle = Solid | Dashed | Dotted
 
type Operator = Add | Subtract | Ratio
 
type Size =
    | Symbol of string
    | Value of double
 
type ShapeSpecifier =
    | BarAlias of string
    | BarIndex of int
    | BarRange of int * int
    | BoxAlias of string
    | Alias of string
    | EntireBar of int
    | BoxIndex of int * int
    | BoxRange of int * int * int
 
type Property =
    | TitleProperty of string
    | SizeProperty of Size
    | FillProperty of string
    | StrokeProperty of string
    | StrokeStyleProperty of StrokeStyle
    | PositionProperty of Position
 
type Expression =
    | Literal of double
    | Id of string
    | Box of ShapeSpecifier
    | Arithmetic of Expression * Operator * Expression
 
type Statement =
    | AddBar of Property * string option
    | AddBox of Property list * ShapeSpecifier * string option * Property list option
    | AddLabel of Property list * ShapeSpecifier
    | CutInto of ShapeSpecifier * int list
    | CutFrom of ShapeSpecifier * Side * Size
    | UpdateBox of ShapeSpecifier * Property list
    | ShiftBox of ShapeSpecifier * ShapeSpecifier
    | RatioConstraint of ShapeSpecifier list * int list
    | AdditiveConstraint of Expression * Expression
 
 
 
Parser.fs defines the parser
 
module Parser
 
open FParsec
open Ast
 
type Line = Blank | Statement of Statement
 
type BarModelParser () =
 
    let ws : Parser< unit, unit> = skipMany (pchar ‘ ‘ <|> pchar ‘\t’)
 
    let str_ws c = pstring c .>> ws
    let strCI_ws c = pstringCI c .>> ws
 
    // Tokens
    let addToken : Parser< string, unit> = strCI_ws “add”
    let cutToken : Parser< string, unit> = strCI_ws “cut”
    let shiftToken : Parser< string, unit> = strCI_ws “shift”
    let updateToken : Parser< string, unit> = strCI_ws “update”
 
    let barToken : Parser< string, unit> = strCI_ws “bar”
    let boxToken : Parser< string, unit> = strCI_ws “box”
    let labelToken : Parser< string, unit> = strCI_ws “label”
 
    let titleToken : Parser< string, unit> = strCI_ws “title”
    let sizeToken : Parser< string, unit> = strCI_ws “size”
    let fillToken : Parser< string, unit> = strCI_ws “fill”
    let strokeToken : Parser< string, unit> = strCI_ws “stroke”
    let strokeStyleToken : Parser< string, unit> = strCI_ws “stroke-style”
    let positionToken : Parser< string, unit> = strCI_ws “position”
 
    let toToken : Parser< string, unit> = strCI_ws “to”
    let asToken : Parser< string, unit> = strCI_ws “as”
    let byToken : Parser< string, unit> = strCI_ws “by”
    let intoToken : Parser< string, unit> = strCI_ws “into”
    let fromToken : Parser< string, unit> = strCI_ws “from”
    let withToken : Parser< string, unit> = strCI_ws “with”
 
    let leftToken : Parser< string, unit> = strCI_ws “left”
    let rightToken : Parser< string, unit> = strCI_ws “right”
 
    let aboveToken : Parser< string, unit> = strCI_ws “above”
    let belowToken : Parser< string, unit> = strCI_ws “below”
 
    // Identifier
    let identifier =
        let isValidFirstChar c = isLetter c || c = ‘_’
        let isValidChar c = isLetter c || isDigit c || c = ‘_’
        many1Satisfy2L isValidFirstChar isValidChar “identifier”
 
    // Literals
    let floatNumber = pfloat .>> ws
    let intNumber = pint32 .>> ws
 
    let number : Parser< double, unit> = floatNumber <|> (intNumber |>> fun i -> (float i))
 
    let numberString : Parser< string, unit> =
        (floatNumber |>> fun f -> (string f)) <|>
        (intNumber |>> fun i -> (string i))
 
    let doubleQuoteStringLiteral = between (pstring “\””) (pstring “\”” ) (manySatisfy ((<>) ‘\”‘ ))
    let singleQuoteStringLiteral = between (pstring “\'”) (pstring “\'” ) (manySatisfy ((<>) ‘\” ))
   
    let stringLiteral = doubleQuoteStringLiteral <|> singleQuoteStringLiteral
 
    let hexColor = pstring “#” >>. many1Satisfy isHex |>> fun c -> (“#” + c)
    let color = identifier <|> hexColor <|> stringLiteral
 
    let strokeStyle =
        (strCI_ws “solid” >>% Solid) <|>
        (strCI_ws “dotted” >>% Dotted) <|>
        (strCI_ws “dashed” >>% Dashed)
 
    let position = (aboveToken >>% Above) <|> (belowToken >>% Below)
 
    // Properties
    let titleProperty =
        titleToken >>. str_ws “=” >>. (stringLiteral <|> identifier <|> numberString) .>> ws
        |>> fun s -> TitleProperty(s)
 
    let sizeValue =
        (identifier |>> fun i -> Symbol(i)) <|>
        (stringLiteral |>> fun s -> Symbol(s)) <|>
        (number |>> fun n -> Value(n))
 
    let sizeProperty = sizeToken >>. str_ws “=” >>. sizeValue .>> ws |>> fun s -> SizeProperty(s)
 
    let fillProperty = fillToken >>. str_ws “=” >>. color .>> ws |>> fun c -> FillProperty(c)
    let strokeProperty = strokeToken >>. str_ws “=” >>. color .>> ws |>> fun c -> StrokeProperty(c)
 
    let strokeStyleProperty = strokeStyleToken >>. str_ws “=” >>. strokeStyle .>> ws |>> fun s -> StrokeStyleProperty(s)
 
    let boxProperty = sizeProperty <|> fillProperty <|> strokeProperty <|> strokeStyleProperty
    let boxProperties = many boxProperty
    let boxProperties1 = many1 boxProperty
 
    let positionProperty = positionToken >>. str_ws “=” >>. position .>> ws |>> fun p -> PositionProperty(p)
 
    let labelProperties = many1 (titleProperty <|> positionProperty)
 
    // Bar Specifier
    let barAlias = identifier |>> fun i -> BarAlias(i)
 
    let singleBarIndex =
        intNumber |>> fun i -> BarIndex(i)
 
    let rangeBarIndex =
        (pipe3 intNumber toToken intNumber ( fun i _ j -> BarRange(i,j)))
 
    let barIndex =
        barToken >>.
        between (str_ws “[“) (str_ws “]” ) (attempt rangeBarIndex <|> singleBarIndex)
 
    let barSpec = (attempt barIndex <|> barAlias) .>> ws
 
    // Box Specifier
    let entireBar =
        intNumber |>> fun i -> EntireBar(i)
   
    let singleBoxIndex =
        pipe3 intNumber (str_ws “,”) intNumber (fun i _ j -> BoxIndex(i, j))
 
    let rangeBoxIndex = 
        pipe5 intNumber (str_ws “,”) intNumber toToken intNumber (fun i _ j _ k -> BoxRange(i,j,k))
 
    let boxAlias = (identifier .>> ws) |>> fun i -> BoxAlias(i)
 
    let boxIndex =
        boxToken >>.
        between (str_ws “[“) (str_ws “]” )
            (
                attempt rangeBoxIndex <|>
                attempt singleBoxIndex <|>
                entireBar
            )
 
    let boxSpec = (attempt boxIndex <|> boxAlias) .>> ws
 
    let toBar = toToken >>. barSpec
    let toBox = toToken >>. boxSpec
 
    let toBarOrBox =
        toToken >>.
        (
            attempt boxIndex <|>
            attempt barIndex <|>
            boxAlias
        )
 
    let asBarAlias = asToken >>. identifier
    let asBoxAlias = asToken >>. identifier
 
    // Statements
    let addBar = pipe3 barToken titleProperty (opt asBarAlias) ( fun _ title alias -> AddBar(title, alias))
 
    let withLabelKeywords = withToken .>>. labelToken
    let withLabel = withLabelKeywords >>. labelProperties
 
    let addBox = pipe5 boxToken boxProperties toBar (opt asBoxAlias) (opt withLabel) (fun _ props bar alias label -> AddBox(props, bar, alias, label))
 
    let addLabel =
        pipe3 labelToken labelProperties toBarOrBox ( fun _ props shape -> AddLabel(props, shape))
 
    let addStatement =
        addToken >>.
        (
            addBar <|>
            addBox <|>
            addLabel
        )
 
    let ratios = sepBy1 intNumber (str_ws “:”)
    let cutBoxIntoRatios = pipe3 boxSpec intoToken ratios ( fun box _ r -> CutInto(box, r))
 
    let side = (leftToken >>% Left) <|> (rightToken >>% Right)
    let cutBoxFrom = pipe5 boxSpec fromToken side byToken sizeValue ( fun box _ side _ size -> CutFrom(box, side, size))
 
    let cutBox =
        cutToken >>.
        (
            attempt cutBoxIntoRatios  <|>
            cutBoxFrom
        )
 
    let shiftBox = pipe4 shiftToken boxSpec toToken barSpec ( fun _ box _ bar -> ShiftBox(box, bar))
 
    let updateBox = pipe3 updateToken boxSpec boxProperties1 ( fun _ box props -> UpdateBox(box, props))
 
    let primitive =
        (boxSpec |>> fun b -> Box(b)) <|>
        (floatNumber |>> fun f -> Literal(f)) <|>
        (identifier |>> fun id -> Id(id))
 
    let boxes = sepBy1 boxSpec (str_ws “:”)
    let ratioConstraint = pipe3 boxes (str_ws “=”) ratios (fun b _ r -> RatioConstraint(b, r))
 
    let oppa = new OperatorPrecedenceParser< Expression, unit , unit >()
    let arithmetic = oppa.ExpressionParser
    let terma = primitive .>> ws
    do oppa.TermParser <- terma
    do oppa.AddOperator( InfixOperator(“+” , ws, 1, Associativity .Left, fun x y ->Arithmetic(x, Add, y)))
    do oppa.AddOperator( InfixOperator(“-“ , ws, 1, Associativity .Left, fun x y ->Arithmetic(x, Subtract, y)))
 
    let additiveConstraint = pipe3 arithmetic (str_ws “=”) arithmetic (fun left _ right -> AdditiveConstraint(left, right))
 
    let statement =
        addStatement <|>
        cutBox <|>
        shiftBox <|>
        updateBox <|>
        attempt ratioConstraint <|>
        attempt additiveConstraint
 
    let pcomment = pchar ‘#’ >>. skipManySatisfy ( fun c -> c <> ‘\n’) >>. pchar ‘\n’
    let peol = pcomment <|> (pchar ‘\n’)
 
    let pline = spaces >>. statement .>> peol |>> ( fun i -> Statement i)
    let pblank = spaces >>. peol |>> ( fun _ -> Blank)
    let plines = many (pline <|> pblank) .>> eof
 
    member this.parse (program: string) =   
        match run plines program with
        | Success(result, s, p) ->
            let r = result |> List.choose ( function Statement i -> Some i | Blank -> None)
            Success(r, s, p)
        | Failure(errorMsg, e, s) -> Failure(errorMsg, e, s)
 
 
 
 
ParserTester.fs defines the unit tests for the Parser
 
module ParserTester
 
open FParsec
open Ast
open Parser
open FsUnit
open FsUnit.MsTest
open Microsoft.VisualStudio.TestTools.UnitTesting
 
[<TestClass>]
type “Add bar“ () =
   
    [<TestMethod>]
    member x.“Add a bar with a title.“() =
        let parser = new BarModelParser()
        parser.parse “add bar title=apple\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [AddBar(TitleProperty(title), _)] -> title |> should equal “apple”
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(e, _, _) -> e |> should throw typeof<System. Exception>
   
    [<TestMethod>]
    member x.“Add a bar as alias“() =
        let parser = new BarModelParser()
        parser.parse “add bar title=orange as bar1\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [AddBar(TitleProperty(title), Some(alias))] ->
                title |> should equal “orange”
                alias |> should equal “bar1”
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(e, _, _) -> e |> should throw typeof<System. Exception>
   
    [<TestMethod>]
    member x.“Add a box“() =
        let parser = new BarModelParser()
        parser.parse “add box to bar[1]\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [AddBox(props, BarIndex(i), alias, label)] ->
                props |> List.length |> should equal 0
                i |> should equal 1
                alias.IsNone |> should equal true
                label.IsNone |> should equal true
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(e, _, _) -> e |> should throw typeof<System. Exception>
   
    [<TestMethod>]
    member x.“Add a box with size“() =
        let parser = new BarModelParser()
        parser.parse “add box size=100 to bar1\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [AddBox(props, BarAlias(a), alias, label)] ->
                props |> List.length |> should equal 1
 
                match props.Head with
                | SizeProperty(Value(size)) -> size |> should equal 100.0
                | _ -> “size property” |> should throw typeof<System.Exception >
 
                a |> should equal “bar1”
                alias.IsNone |> should equal true
                label.IsNone |> should equal true
 
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(e, _, _) -> e |> should throw typeof<System. Exception>
   
    [<TestMethod>]
    member x.“Add a box with size fill stroke“() =
        let parser = new BarModelParser()
        parser.parse “add box size = 100 fill= red stroke =#ababab to bar1\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [AddBox(props, BarAlias(a), alias, label)] ->
                props |> List.length |> should equal 3
 
                match props.Head with
                | SizeProperty(Value(size)) -> size |> should equal 100.0
                | _ -> “size property” |> should throw typeof<System.Exception >
 
                match props.Tail.Head with
                | FillProperty(color) -> color |> should equal “red”
                | _ -> “fill property” |> should throw typeof<System.Exception >
 
                match props.Tail.Tail.Head with
                | StrokeProperty(rgb) -> rgb |> should equal “#ababab”
                | _ -> “stroke property” |> should throw typeof<System.Exception >
 
                a |> should equal “bar1”
                alias.IsNone |> should equal true
                label.IsNone |> should equal true
 
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(e, _, _) -> e |> should throw typeof<System. Exception>
   
    [<TestMethod>]
    member x.“Add label to a box“() =
        let parser = new BarModelParser()
        parser.parse “add label title=\”tree\” position=above to box[2, 1 to 6]\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [AddLabel(props, box)] ->
                props |> List.length |> should equal 2
 
                match props.Head with
                | TitleProperty(title) -> title |> should equal “tree”
                | _ -> “title” |> should throw typeof<System.Exception >
 
                match props.Tail.Head with
                | PositionProperty(pos) -> pos |> should equal Above
                | _ -> “position” |> should throw typeof<System.Exception >
 
            | _ -> “properties” |> should throw typeof<System.Exception >
        | Failure(err, _, _) -> err |> should throw typeof<System. Exception>
 
    [<TestMethod>]
    member x.“Add label to bars“() =
        let parser = new BarModelParser()
        parser.parse “add label title=300 to bar[1 to 6]\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [AddLabel(props, bar)] ->
                props |> List.length |> should equal 1
 
                match props.Head with
                | TitleProperty(title) -> title |> should equal “300”
                | _ -> “title” |> should throw typeof<System.Exception >
 
            | _ -> “properties” |> should throw typeof<System.Exception >
        | Failure(err, _, _) -> err |> should throw typeof<System. Exception>
 
    [<TestMethod>]
    member x.“Cut box into equal units“() =
        let parser = new BarModelParser()
        parser.parse “cut box[1, 10] into 9 \n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [CutInto(BoxIndex(bar, box), ratios)] ->
                bar |> should equal 1
                box |> should equal 10
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(err, _, _) -> err |> should throw typeof<System. Exception>
 
    [<TestMethod>]
    member x.“Cut box into ratios“() =
        let parser = new BarModelParser()
        parser.parse “cut box[1, 10] into 2 : 3 : 4 \n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [CutInto(BoxIndex(bar, box), ratios)] ->
                bar |> should equal 1
                box |> should equal 10
 
                List.length ratios |> should equal 3
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(err, _, _) -> err |> should throw typeof<System. Exception>
 
    [<TestMethod>]
    member x.“Cut box from left“() =
        let parser = new BarModelParser()
        parser.parse “cut box[1, 10] from left by 300\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [CutFrom(BoxIndex(bar, box), side, Value(sz))] ->
                bar |> should equal 1
                box |> should equal 10
                side |> should equal Left
                sz |> should equal 300.0
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(err, _, _) -> err |> should throw typeof<System. Exception>
 
    [<TestMethod>]
    member x.“Cut box from right“() =
        let parser = new BarModelParser()
        parser.parse “cut box[5] from right by 300\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [CutFrom(EntireBar(bar), side, Value(size))] ->
                bar |> should equal 5
                side |> should equal Right
                size |> should equal 300.0
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(err, _, _) -> err |> should throw typeof<System. Exception>
 
    [<TestMethod>]
    member x.“Shift box“() =
        let parser = new BarModelParser()
        parser.parse “shift box[1, 1] to bar[4]\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [ShiftBox(BoxIndex(bar, box), BarIndex(bar2))] ->
                bar |> should equal 1
                box |> should equal 1
                bar2 |> should equal 4
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(err, _, _) -> err |> should throw typeof<System. Exception>
 
    [<TestMethod>]
    member x.“Update box“() =
        let parser = new BarModelParser()
        parser.parse “update box[1, 1] fill=blue\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [UpdateBox(BoxIndex(bar, box), props)] ->
                bar |> should equal 1
                box |> should equal 1
                props.Length |> should equal 1
                match props.Head with
                | FillProperty(c) -> c |> should equal “blue”
                | _ -> “error” |> should throw typeof<System.Exception >
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(err, _, _) -> err |> should throw typeof<System. Exception>
 
    [<TestMethod>]
    member x.“Additive constraint“() =
        let parser = new BarModelParser()
        parser.parse “box[1, 1]+box[2] – box[3, 2 to 7] = 210\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [AdditiveConstraint(left, right)] ->
                match left with
                | Arithmetic(Arithmetic(Box(BoxIndex(bar1, box1)), op1, Box(EntireBar(bar2))), op2, Box(BoxRange(bar3, box31, box32))) ->
                    bar1 |> should equal 1
                    box1 |> should equal 1
                    op1 |> should equal Add
                    bar2 |> should equal 2
                    bar3 |> should equal 3
                    box31 |> should equal 2
                    box32 |> should equal 7
                | _ -> “error” |> should throw typeof<System.Exception >
 
                match right with
                | Literal(value) -> value |> should equal 210.0
                | _ -> “error” |> should throw typeof<System.Exception >
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(err, _, _) -> err |> should throw typeof<System. Exception>
 
    [<TestMethod>]
    member x.“Ratio constraint“() =
        let parser = new BarModelParser()
        parser.parse “box[1, 1]:box[2] : box[3, 2 to 7] = 5 :4: 3\n” |> function
        | Success(s, _, _) ->
            s |> List.length |> should equal 1
            match s with
            | [RatioConstraint(boxes, ratios)] ->
                List.length boxes |> should equal 3
                List.length ratios |> should equal 3
            | _ -> “error” |> should throw typeof<System.Exception >
        | Failure(err, _, _) -> err |> should throw typeof<System. Exception>
The grammar of BarModel script:
addBar := “add” “bar” titleProperty (“as” barAlias)?
addBox := “add” “box” boxProperty* (“as” boxAlias)?
addLabel := “add” “label” labelProperty* to (boxSpec | barSpec)
cutBoxInto := “cut” boxSpec “into” ratios
cutBoxFrom := “cut” boxSpec “from” (“left” | “right”) “by” size
shiftBox := “shift” boxSpec “to” barSpec
updateBox := “update” boxSpec boxProperty*
additiveConstraint := boxSpec (“+”|”-“ boxSpec)+ “=” number
ratioConstraint := boxSpec (“:” boxSpec)+ “=” ratios
ratios := number (“:” number)*
titleProperty := “title” “=” string
boxProperty :=
   (sizeProperty | fillProperty | strokeProperty |strokeStyleProperty)+
sizeProperty := “size” “=” (identifier | number)
fillProperty := “fill” “=” color
strokeProperty := “stroke” “=” color
strokeStyleProperty := “stroke-style” “=” (“solid” | “dashed” | “dotted”)
labelProperty := (titleProperty | positionProperty)+
positionProperty := “position” “=” (“above” | “below”)
barSpec := (“bar” “[“ intNumber (“,” intNumber)? “]”) | barAlias
barSpec :=
    (“box” “[“ intNumber (“,” intNumber (“to” intNumber)? )? ) | boxAlias

Read Full Post »

 

 

 

 

The following are the notes I took (using XMind) when reading the “Thinking Functionally” series on F# for fun and profit.
Thinking Functionally

Read Full Post »