Ninety-Nine F# Problems - Problems 90 - 94 - Miscellaneous problems]

These are F# solutions of Ninety-Nine Haskell Problems which are themselves translations of Ninety-Nine Lisp Problems and Ninety-Nine Prolog Problems. The solutions are hidden so you can try to solve them yourself.

Ninety-Nine F# Problems - Problems 90 - 94 - Miscellaneous problems

 1: /// Ninety-Nine F# Problems - Problems 90 - 94
 2: ///
 3: /// These are F# solutions of Ninety-Nine Haskell Problems 
 4: /// (http://www.haskell.org/haskellwiki/H-99:_Ninety-Nine_Haskell_Problems), 
 5: /// which are themselves translations of Ninety-Nine Lisp Problems
 6: /// (http://www.ic.unicamp.br/~meidanis/courses/mc336/2006s2/funcional/L-99_Ninety-Nine_Lisp_Problems.html)
 7: /// and Ninety-Nine Prolog Problems
 8: /// (https://sites.google.com/site/prologsite/prolog-problems).
 9: ///
10: /// If you would like to contribute a solution or fix any bugs, send 
11: /// an email to paks at kitiara dot org with the subject "99 F# problems". 
12: /// I'll try to update the problem as soon as possible.
13: ///
14: /// The problems have different levels of difficulty. Those marked with a single asterisk (*) 
15: /// are easy. If you have successfully solved the preceeding problems you should be able to 
16: /// solve them within a few (say 15) minutes. Problems marked with two asterisks (**) are of 
17: /// intermediate difficulty. If you are a skilled F# programmer it shouldn't take you more than 
18: /// 30-90 minutes to solve them. Problems marked with three asterisks (***) are more difficult. 
19: /// You may need more time (i.e. a few hours or more) to find a good solution
20: ///
21: /// Though the problems number from 1 to 99, there are some gaps and some additions marked with 
22: /// letters. There are actually only 88 problems.
23: ///

(**) Problem 90 : Eight queens problem

 1: /// This is a classical problem in computer science. The objective is to place eight queens on a 
 2: /// chessboard so that no two queens are attacking each other; i.e., no two queens are in the 
 3: /// same row, the same column, or on the same diagonal.
 4: ///  
 5: /// Hint: Represent the positions of the queens as a list of numbers 1..N. Example: 
 6: /// [4,2,7,3,6,8,5,1] means that the queen in the first column is in row 4, the queen in the 
 7: /// second column is in row 2, etc. Use the generate-and-test paradigm.
 8: ///  
 9: /// Example in F#: 
10: /// 
11: /// > queens 8 |> Seq.length;;
12: /// val it : int = 92
13: /// > queens 8 |> Seq.head;;
14: /// val it : int list = [1; 5; 8; 6; 3; 7; 2; 4]
15: /// > queens 20 |> Seq.head;;
16: /// val it : int list =
17: ///  [1; 3; 5; 2; 4; 13; 15; 12; 18; 20; 17; 9; 16; 19; 8; 10; 7; 14; 6; 11]
18: 
19: (Solution)

(**) Problem 91 : Knight's tour

 1: /// Another famous problem is this one: How can a knight jump on an NxN chessboard in such a way 
 2: /// that it visits every square exactly once? A set of solutions is given on the The_Knights_Tour
 3: /// page.
 4: ///  
 5: /// Hints: Represent the squares by pairs of their coordinates of the form X/Y, where both X and 
 6: /// Y are integers between 1 and N. (Note that '/' is just a convenient functor, not division!) 
 7: /// Define the relation jump(N,X/Y,U/V) to express the fact that a knight can jump from X/Y to U/V 
 8: /// on a NxN chessboard. And finally, represent the solution of our problem as a list of N*N knight
 9: /// positions (the knight's tour).
10: ///  
11: /// There are two variants of this problem: 
12: /// 1. find a tour ending at a particular square 
13: /// 2. find a circular tour, ending a knight's jump from the start (clearly it doesn't matter where 
14: ///    you start, so choose (1,1))
15: ///  
16: /// Example in F#: 
17: /// 
18: /// > knightsTour 8 (1,1) |> Seq.head;;
19: /// val it : (int * int) list =
20: ///   [(4, 3); (6, 4); (5, 6); (4, 8); (3, 6); (5, 5); (6, 3); (4, 4); (2, 3);
21: ///    (1, 5); (3, 4); (5, 3); (6, 5); (4, 6); (2, 7); (3, 5); (5, 4); (6, 6);
22: ///    (4, 5); (2, 4); (1, 6); (2, 8); (4, 7); (6, 8); (8, 7); (7, 5); (8, 3);
23: ///    (7, 1); (5, 2); (3, 1); (1, 2); (3, 3); (4, 1); (2, 2); (1, 4); (2, 6);
24: ///    (1, 8); (3, 7); (5, 8); (7, 7); (8, 5); (7, 3); (8, 1); (6, 2); (7, 4);
25: ///    (8, 2); (6, 1); (4, 2); (2, 1); (1, 3); (2, 5); (1, 7); (3, 8); (5, 7);
26: ///    (7, 8); (8, 6); (6, 7); (8, 8); (7, 6); (8, 4); (7, 2); (5, 1); (3, 2);
27: ///    (1, 1)]
28: ///
29: /// > endKnightsTour 8 (4,2);;
30: /// val it : (int * int) list =
31: ///   [(4, 2); (2, 1); (1, 3); (3, 2); (1, 1); (2, 3); (1, 5); (2, 7); (4, 8);
32: ///    (6, 7); (8, 8); (7, 6); (6, 8); (8, 7); (7, 5); (8, 3); (7, 1); (5, 2);
33: ///    (3, 1); (1, 2); (2, 4); (1, 6); (2, 8); (4, 7); (2, 6); (1, 8); (3, 7);
34: ///    (5, 8); (7, 7); (8, 5); (7, 3); (8, 1); (6, 2); (4, 1); (2, 2); (1, 4);
35: ///    (3, 5); (5, 6); (4, 4); (2, 5); (1, 7); (3, 8); (5, 7); (7, 8); (8, 6);
36: ///    (7, 4); (6, 6); (4, 5); (3, 3); (5, 4); (4, 6); (6, 5); (8, 4); (7, 2);
37: ///    (6, 4); (4, 3); (5, 1); (6, 3); (8, 2); (6, 1); (5, 3); (3, 4); (5, 5);
38: ///    (3, 6)]
39: ///
40: /// > closedKnightsTour 8;;
41: /// val it : (int * int) list =
42: ///   [(2, 3); (4, 4); (6, 3); (5, 5); (4, 3); (6, 4); (5, 6); (4, 8); (3, 6);
43: ///    (1, 5); (3, 4); (5, 3); (6, 5); (4, 6); (2, 7); (3, 5); (5, 4); (6, 6);
44: ///    (4, 5); (2, 4); (1, 6); (2, 8); (4, 7); (6, 8); (8, 7); (7, 5); (8, 3);
45: ///    (7, 1); (5, 2); (3, 1); (1, 2); (3, 3); (4, 1); (2, 2); (1, 4); (2, 6);
46: ///    (1, 8); (3, 7); (5, 8); (7, 7); (8, 5); (7, 3); (8, 1); (6, 2); (7, 4);
47: ///    (8, 2); (6, 1); (4, 2); (2, 1); (1, 3); (2, 5); (1, 7); (3, 8); (5, 7);
48: ///    (7, 8); (8, 6); (6, 7); (8, 8); (7, 6); (8, 4); (7, 2); (5, 1); (3, 2);
49: ///    (1, 1)]
50: 
51: (Solution)

(***) Problem 92 : Von Koch's conjecture

 1: /// Several years ago I met a mathematician who was intrigued by a problem for which he didn't
 2: /// know a solution. His name was Von Koch, and I don't know whether the problem has been 
 3: /// solved since.
 4: ///  
 5: ///                                         6
 6: ///        (d)   (e)---(f)        (4)   (1)---(7)
 7: ///         |     |              1 |     | 5
 8: ///        (a)---(b)---(c)        (3)---(6)---(2)
 9: ///         |                    2 |  3     4
10: ///        (g)                    (5)
11: ///
12: /// Anyway the puzzle goes like this: Given a tree with N nodes (and hence N-1 edges). Find a 
13: /// way to enumerate the nodes from 1 to N and, accordingly, the edges from 1 to N-1 in such 
14: /// a way, that for each edge K the difference of its node numbers equals to K. The conjecture 
15: /// is that this is always possible.
16: ///  
17: /// For small trees the problem is easy to solve by hand. However, for larger trees, and 14 is 
18: /// already very large, it is extremely difficult to find a solution. And remember, we don't 
19: /// know for sure whether there is always a solution!
20: ///  
21: /// Write a predicate that calculates a numbering scheme for a given tree. What is the solution
22: /// for the larger tree pictured below?
23: ///
24: ///     (i) (g)   (d)---(k)         (p)
25: ///        \ |     |                 |
26: ///         (a)---(c)---(e)---(q)---(n)
27: ///        / |     |           |
28: ///     (h) (b)   (f)         (m)
29: ///
30: /// Example in F#:  
31: /// > vonKoch (['d';'a';'g';'b';'c';'e';'f'],[('d', 'a');('a', 'g');('a', 'b');('b', 'e');
32: ///                ('b', 'c');('e', 'f')]) |> Seq.head;;
33: ///
34: /// val it : int list * (int * int * int) list =
35: ///   ([4; 3; 5; 6; 2; 1; 7],
36: ///    [(4, 3, 1); (3, 5, 2); (3, 6, 3); (6, 1, 5); (6, 2, 4); (1, 7, 6)])
37: ///
38: 
39: (Solution)

(***) Problem 93 : An arithmetic puzzle

 1: /// Given a list of integer numbers, find a correct way of inserting arithmetic signs (operators)
 2: /// such that the result is a correct equation. Example: With the list of numbers [2,3,5,7,11] we 
 3: /// can form the equations 2-3+5+7 = 11 or 2 = (3*5+7)/11 (and ten others!).
 4: ///  
 5: /// Division should be interpreted as operating on rationals, and division by zero should be 
 6: /// avoided.
 7: ///  
 8: /// Example in F#: 
 9: /// 
10: /// > solutions [2;3;5;7;11] |> List.iter (printfn "%s");;
11: /// 2 = 3 - (5 + (7 - 11))
12: /// 2 = 3 - ((5 + 7) - 11)
13: /// 2 = (3 - 5) - (7 - 11)
14: /// 2 = (3 - (5 + 7)) + 11
15: /// 2 = ((3 - 5) - 7) + 11
16: /// 2 = ((3 * 5) + 7) / 11
17: /// 2 * (3 - 5) = 7 - 11
18: /// 2 - (3 - (5 + 7)) = 11
19: /// 2 - ((3 - 5) - 7) = 11
20: /// (2 - 3) + (5 + 7) = 11
21: /// (2 - (3 - 5)) + 7 = 11
22: /// ((2 - 3) + 5) + 7 = 11
23: /// val it : unit = ()
24: ///
25: 
26: (Solution)

(***) Problem 94 : Generate K-regular simple graphs with N nodes

1: /// In a K-regular graph all nodes have a degree of K; i.e. the number of edges incident in each 
2: /// node is K. How many (non-isomorphic!) 3-regular graphs with 6 nodes are there?
3: 
4: (Solution needed)

// instead of solving the problem for 8 queens lets solve if for N queens.
// To solve the problem we are going to start with an empty board and then we're going
// add queen to it for each row. Elimitating invalid solutions. To do that we need a function
// (invalidPosition) that detects if one queen is in conflict with another one. And another
// function (validSolution) that would test if the queen that we're adding is not in
// conflict with any queen already on the board.
// Also, the solution is going to return a a sequence of solutions instead of a list.
// That way we can get one solution realy fast if that is only what we care. For example
// getting all the solutions for a 20x20 board would take a long time, but finding
// the first solution only takes 5 seconds.
//

let queens n =
    let invalidPosition (x1, y1) (x2, y2) = (x1 = x2) || (y1 = y2) || abs (x1 - x2) = abs (y1 - y2)
    let validSolution (queen, board) = board |> Seq.exists (invalidPosition queen) |> not
    // With the function "loop", we're going to move one column at time, placing queens
    // on each row and creating new boards with only valid solutions.
    let rec loop boards y =
        if y = 0 then
            boards
        else
            let boards' = boards
                       |> Seq.collect(fun board -> [1 .. n] |> Seq.map(fun x -> (x,y),board))
                       |> Seq.filter validSolution
                       |> Seq.map(fun (pos, xs) -> pos::xs)
            loop boards' (y - 1)
    loop (Seq.singleton([])) n |> Seq.map (List.rev >> List.map fst)

// Wikipedia has a nice article about this problem http://en.wikipedia.org/wiki/Knights_tour
//
// The way this algorithm works is like this. We create a set (board) with all the positions
// in the board that have not being used. Also we have a function (moves) that returns a
// list of posible moves from the current position. The variable 'validMoves' is the result of
// removing all the positions returned by 'moves' that are not in the set 'board' (positions
// that are still available). If validMoves is empty, that means that we can not move
// anymore. If at that time the board is empty, we have a solution! Otherwise we remove the
// current position from the board add the curent position to the tour and continue to one
// of the valid moves.
// Now, the trick to make the algorithm converge is to move first to the valid position
// that has the less options once we move (Warnsdorff's rule).
//

let moves n (x,y) =
    [(x + 2, y + 1); (x + 2, y - 1); (x - 2, y + 1); (x - 2, y - 1); (x - 1, y + 2); (x - 1, y - 2); (x + 1, y + 2); (x + 1, y - 2) ]
    |> List.filter(fun (x,y) -> x > 0 && x <= n && y > 0 && y <= n)

let knightsTours n start =
    let board = [1 .. n] |> List.collect(fun x -> [1 .. n] |> List.map(fun y -> (x,y))) |> Set.ofList
    let rec loop tour board = seq {
        let validMoves = tour
                         |> List.head // the head of the tour is our current position
                         |> moves n
                         |> List.filter(fun p -> board |> Set.contains p)
        match validMoves with
            | [] -> if board |> Set.isEmpty then yield tour // we found a solution!
            | _ ->
                // the call to sortBy is what makes this algorithm converge fast.
                // We want to go first to the position with the less options
                // once we move (Warnsdorff's rule).
                for p in validMoves |> List.sortBy(moves n >> List.length) do
                    yield! loop (p::tour) <| Set.remove p board
    }
    loop [start] <| Set.remove start board

let closedKnightsTour n =
    let start = (1,1)
    let finish = moves n start |> Set.ofList
    let flip f a b = f b a
    // lets find the first solution that ends in a position next to the start
    knightsTours n start |> Seq.find(List.head >> flip Set.contains finish)

let endKnightsTour n finish =
    // just find a tour that starts with finish and reverse it!
    knightsTours n finish |> Seq.head |> List.rev

// After some searching on the internet I couldn't find an algorithm for Graceful labeling.
// So I decided to go the brute force route. I knew this would work with the first the example
// but I wasn't sure if it would work for the second tree (a tree with 14 Nodes means that we have
// 14! (87,178,291,200) posible ways to tag the tree).
// Luckly, it did!!

// To represent the trees, I decided to use a tuple with a list of nodes and a list of tuples with the edges
type 'a Graph = 'a list * ('a * 'a) list

// Here are the two examples above using that representation.
let g = (['d';'a';'g';'b';'c';'e';'f'],[('d', 'a');('a', 'g');('a', 'b');('b', 'e');('b', 'c');('e', 'f')])

let g' = (['i';'h';'g';'a';'b';'d';'c';'f';'k';'e';'q';'m';'p';'n'],[('i', 'a');('h', 'a');('a', 'b');('a', 'g');('a', 'c');('c', 'f');('c','d');('d','k');('c','e');('e','q');('q','m');('q','n');('n','p')])

// Now I knew how to generate permutations in F# from this snippet: http://fssnip.net/48
// But the problem was, that implementation was using lists and it would not work to generate the
// 87 billion permutations for the 14 node tree. Then I remember the LazyList type in the F#
// Power Pack. Now I can generate the permutations in a lazy way and pray that a solution
// can be found fast.
// Here is the implemetation of using LazyList.

#if INTERACTIVE
#r "FSharp.PowerPack.dll"
#endif

open Microsoft.FSharp.Collections

// the term interleave x ys returns a list of all possible ways of inserting
// the element x into the list ys.
let rec interleave x = function
    | LazyList.Nil -> LazyList.ofList [ LazyList.ofList [x]]
    | LazyList.Cons(y,ys) -> LazyList.ofSeq (seq { yield LazyList.cons x (LazyList.cons y ys)
                                                   for zs in interleave x ys do
                                                       yield LazyList.cons y zs })

// the function perms returns a lazy list of all permutations of a list.
let rec perms = function
    | LazyList.Nil -> LazyList.ofList [LazyList.empty]
    | LazyList.Cons(x,xs) -> LazyList.concat ( LazyList.map (interleave x) (perms xs))

// Now with the problem of generating all the permutations solved.
// It's time to tackle the real problem.
let vonKoch (nodes, edges) =
    // diff is used to compute the edge difference acording the the map m
    let diff (m : Map<_, _>) (a,b) = abs <| m.[a] - m.[b]
    let size = nodes |> List.length
    let edgSize = edges |> List.length
    match nodes with
        | [] -> failwith "Empty graph!!"
        | _ when size <> (edgSize + 1) -> // make sure that we have a valid tree
            failwith "The tree doesn't have N - 1 egdes. Where N is the number of nodes"
        | _ ->
            seq {
            for p in perms <| LazyList.ofList [1 .. size] do
                let sol = LazyList.toList p
                let m = sol |> List.zip nodes |> Map.ofList
                // I'm using Set here to filter out any duplicates.
                // It's faster than Seq.distinct
                let count = edges |> List.map (diff m) |> Set.ofList |> Set.count
                // if the number of distint differences is equal to the number
                // of edges, we found a solution!
                if count = edgSize then
                    yield (sol, edges |> List.map (fun ((a,b) as e) -> m.[a], m.[b], diff m e))
            }

// This is similar to "The countdow problem" on chapter 11 in the book
// Programming in Haskell by Graham Hutton

// First let's define our operations. The ToString override is there to help
// on printing the solutions later on.
type Op = Add | Sub | Mult | Div
    with override op.ToString() =
            match op with
            | Add -> "+"
            | Sub -> "-"
            | Mult -> "*"
            | Div -> "/"

// Here we define wich opertaions are valid.
// For Add or Sub there is no problem
// For Mult we dont want trivial mutiplications by 1. Although the
// problem statement is not clear if that is an issue.
// For Div we don't want division by 0, by 1 or fractions
let valid op x y =
    match op with
        | Add -> true
        | Sub -> true
        | Mult -> x <> 1 && y <> 1
        | Div -> y <> 0 && y <> 1 && x % y = 0

// this is function applies the operation to the x and y arguments
let app op x y =
    match op with
        | Add -> x + y
        | Sub -> x - y
        | Mult -> x * y
        | Div -> x / y

// Now, we define our expresions. This is how are we going to build the
// solutions
type Expr = Val of int | App of Op * Expr * Expr

// Just for fun, I implemented the fold function for our expresions.
// There was no need since we only use it once on the toString function.
let foldExpr fval fapp expr =
    let rec loop expr cont =
        match expr with
            | Val n -> cont <| fval n
            | App(op, l, r) -> loop l <| fun ls -> loop r <| fun rs -> cont <| fapp op ls rs
    loop expr id

// Once we have fold over expresions impelmenting toString is a one-liner.
// The code after the fold is just to remove the outher parentesis.
let toString exp =
    let str = exp |> foldExpr string (fun op l r -> "(" + l + " " + string op + " " + r + ")")
    if str.StartsWith("(") then
        str.Substring(1,str.Length - 2)
    else
        str

// The 'eval' function returns a sigleton list with the result of the evaluation.
// If the expresion is not valid, returns the empty list ([])
let rec eval = function
    | Val n -> [n]
    | App(op, l, r) ->
        [for x in eval l do
            for y in eval r do
                if valid op x y then
                    yield app op x y]

// The function 'init', 'inits', 'tails' are here to help implement the
// function splits and came from haskell

// the function inits accepts a list and returns the list without its last item
let rec init = function
    | [] -> failwith "empty list!"
    | [_] -> []
    | x::xs -> x :: init xs

// The function inits returns the list of all initial segments
// of a list , in order of increasing length.
// Example:
// > inits [1..4];;
// val it : int list list = [[]; [1]; [1; 2]; [1; 2; 3]; [1; 2; 3; 4]]
let rec inits = function
    | [] -> [[]]
    | x::xs -> [ yield []
                 for ys in inits xs do
                     yield x::ys]

// the function tails returns the list of initial segments
// of its argument list, shortest last
// Example:
// > tails [1..4];;
// val it : int list list = [[1; 2; 3; 4]; [2; 3; 4]; [3; 4]; [4]; []]
let rec tails = function
    | [] -> [[]]
    | x::xs as ls ->
        [ yield ls
          for ys in tails xs do
              yield ys ]

// this is what drives the solution to this problem and
// came from the haskell solution.
// Here is an example of its use:
// > splits [1..4];;
// val it : (int list * int list) list =
// [([1], [2; 3; 4]); ([1; 2], [3; 4]); ([1; 2; 3], [4])]
// As you can see, it returs all the ways we can split a list.
let splits xs = List.tail (init (List.zip (inits xs) (tails xs)))

// Now that we're armed with all these functions, we're ready to tackle the real problem.

// The goal of the function expressions is to build all valid expressions and its value given a
// list of numbers. First we split the list in all posible ways (1). Then we take
// the left side of the split and build all the valid expresions (2). We do the same for the
// right side (3). Now we combine the two expresions with all the operators (4). If the operation
// is valid, we add it to the list of expressions (5,6).
let rec expressions = function
    | [x] -> [(Val x, x)]
    | xs -> [ for xsl, xsr in splits xs do (* 1 *)
                for (expl, vall) in expressions xsl do (* 2 *)
                    for (expr, valr) in expressions xsr do (* 3 *)
                        for op in [Add; Sub; Mult; Div] do (* 4 *)
                            if valid op vall valr then (* 5 *)
                                yield (App (op, expl, expr) ,app op vall valr) (* 6 *)]

// Now that we have a way of generating valid expressions, it's time to
// generate the equaions. Again, we split the list of numbers (1). Then we generate the
// list of expressions from the left side of the split (2). Same with the right side (3).
// If both expressions have the same value, add it to our soutions (4,5).
let equations = function
    | [] -> failwith "error: empty list"
    | [_] -> failwith "error: singleton list"
    | xs -> [for xsl, xsr in splits xs do (* 1 *)
                for el, vl in expressions xsl do (* 2 *)
                    for er, vr in expressions xsr do (* 3 *)
                        if vl = vr then (* 4 *)
                            yield (el, er) (* 5 *)]

// Go thought the list of equations a pretty-print them.
let solutions = equations >> List.map(fun (exp1, exp2) -> toString exp1 + " = " + toString exp2)

let solution94 = "your solution here!!"

More information

Link:	http://fssnip.net/aw
Posted:	1 years ago
Author:	Cesar Mendoza (website)
Tags:	Ninety-Nine F# Problems, tutorial, F#