Skip to content

F# adder

This is a quite popular coding interview question: “Add two numbers without using arithmetic operators“. Solving it assumes candidate’s understanding (or just re-inventing) of how summation was implemented in early days of computer electronics – see how half-adder performs addition of two bits using XOR, AND, and SHIFT. F# one-liner implementing the same approach for adding two integers using just bit manipulations looks elegant enough to deserve a post:

let rec sum n = function 0 -> n | _ as n' -> sum (n^^^n') ((n&&&n')<<<1)

Just beautiful!

Advertisements

Project Euler Problem 90

Solving Project Euler Problem 90 in a pure functional manner is fun. First and foremost, when picking an approach, we may notice that there are only “6 of 10” different combinations exist for dices with numbers 0 to 9 on sides, which equals to 210. In turn, this gives only 44100 combinations for a pair of dices, so simple brute forcing the solution is feasible.

Let’s begin with the list of target squares. We represent it as a list squares of tuples (tens, ones) for all digit squares; also there is no need to differentiate 9 from 6, so the final list is

[(0, 1); (0, 4); (0, 6); (1, 6); (2, 5); (3, 6); (4, 6); (6, 4); (8, 1)]. This list is the key piece of function isValidArrangement that for two sets of digits representing a dice sides each determines if all elements of squares list can be represented by pair of sides given as arguments.

Then, function combinations yields all combinations of the given size from the given list ls, i.e. all possible dice side lists allDices would be contained in combinations 6 [0..9]. Finally, as we want to represent a dice as a set of its sides with the help of function asSetofSides we would turn 9 to 6 unless both these digits are present on the same dice.

The rest is trivial: build a sequence of all dice pairs allDicePairs where each pair is a tuple of side sets and count number of elements that are recognized as isValidArrangement. As each valid arrangement is duplicated by dice switch, the solution would be this number divided by 2.

let squares =
    [ for i in 1..9 -> i*i ]
    |> List.map (fun square -> let tens, ones = square/10, square%10 in
                                (tens, if ones = 9 then 6 else ones))

let isValidArrangement dice1 dice2 = 
    let rec scan = function
    | [] -> true
    | (tens,ones)::t -> if (Set.contains tens dice1 && Set.contains ones dice2) ||
                           (Set.contains tens dice2 && Set.contains ones dice1) then scan t
                        else false
    scan squares

let rec combinations size ls =
    let rec bead = function
    | [] -> []
    | h::t -> (h,t) :: [ for (l, ls) in bead t -> (l, ls) ]
    [match size with
     | 0 -> yield []
     | _ -> for (first, rest) in bead ls do
              for tail in combinations (size - 1) rest do
                  yield first::tail]                

let allDices = combinations 6 [0..9]

let asSetofSides dice =
    let sides = Set.ofList dice in
        if sides.Contains 9 && not (sides.Contains 6)
        then (sides.Remove 9).Add 6
        else sides

let allDicePairs = seq {
    for dice1 in allDices do
        for dice2 in allDices do
            yield (asSetofSides dice1, asSetofSides dice2)
    }

let problem090() =
    allDicePairs
    |> Seq.sumBy (fun (dice1, dice2) -> if isValidArrangement dice1 dice2 then 1 else 0)
    |> (/) <| 2

Project Euler Problem 89

Solving Problem 89 was easy. In fact, solving the problem does not require any conversion of the source data as the question is how much shorter the converted numbers are going to be. It can be derived from the problem outline that cases for the length reduction are IIII, VIIII, XXXX, LXXXX, CCCC, and DCCCC. As each reduction of these yields just two digits, correspondent reductions are going to be 2,3,2,3,2,3. Accumulating all reductions, being applied from the beginning of the file each time for the closest available reduction to the end will be the sought solution. Very simple recursive function reduce does exactly this.

open System.IO

let rec reduce saved (roman: string)  =
    match ([| "IIII"; "VIIII"; "XXXX"; "LXXXX"; "CCCC"; "DCCCC" |]
        |> Array.map (fun x -> (x, roman.IndexOf(x)))
        |> Array.filter (fun (x, i) -> i >= 0)) with
    | [||] -> saved
    | _ as a -> a |> Array.minBy(fun (x,i) -> i)
                  |> fun (x,i) -> reduce (saved + x.Length - 2) (roman.Substring(i + x.Length))

let problem089() =
    File.ReadAllText( @"..\..\..\Datafiles\Problem089.data") |> reduce 0

Project Euler Problem 88

After a quite long silence I’m back with F# solution to one of the relatively challenging (based on the number of people that solved it up to the date) Project Euler problems – Problem 88.

Two things are needed to be realized if approaching the solution from combinatorial search standpoint:

  1. Every number can be converted to a product-sum by the following simple operation – if a number n is represented by a set of f factors we can convert it to a product-sum by adding to f factors (n – sum(factors)) of 1s that increase sum part while keeping product part constant. The result set would be a product-sum (not necessarily minimal) of the set of size f + n – sum(factors).
  2. For pretty obvious reasons the minimal product-sum for some k is between k and 2k.

So, if we manage to factorize all numbers between 2 and 24000 this would give us an answer. However, we can approach the task from the opposite consideration. If we manage building all combinations of factors yielding product-sums for different k in the above range and select minimum for each particular k, then after adding together all distinct minimums we should arrive to the same result.

What would help us assessing the latter approach is finding few boundary conditions. First, the maximum factorization of two factors yielding result closest to 24000 is 154*155. Second, what would be the maximal number of factors yielding the same? Taking the minimal factor of 2 it is easy to find that this length is 14.

Now, equipped with all these consideration we can lay out the algorithm for finding the solution. We can build a factors generator yielding us all possible sets of factors limited from up by set power of 14 and the product of 24000. This is what the pair of functions prodSums and moveNext in the code below does: it first builds all lists of two factors from [2;2] to [155;154], then all lists of three factors [2;2;2] to [30;28;28], etc till the final list [2;2;2;2;2;2;2;2;2;2;2;2;2;2]. Using this sequence of factor lists prodSums we iterate thru it making a product-sum of each member and collecting correspondent minimums in array prodSumMins. Finally, we take a sum of each distinct number among all product-sum minimums for 2..12000, which gives us the answer.

let K = 12000
let K2 = K*2

module List =
    let mul xs =
        xs |> List.reduce (fun a x -> a * x)

let rec moveNext = function
    | h::t as x when x.Length = 14 -> if (h + 1) * (List.mul t) <= K2 then
                                        (h + 1) :: t
                                      else moveNext t
    | [] -> []
    | h::t -> let mutable candidate = []
              for i in 1 .. (14 - t.Length) do
                  candidate <- (h + 1)::candidate
              candidate <- candidate @ t
              if (List.mul candidate) <= K2 then
                  candidate
              else moveNext t

let prodSums = [2;2;1;1;1;1;1;1;1;1;1;1;1;1]
               |> Seq.unfold (fun state ->
                  if state = [] then None
                  else Some(state, moveNext(state)))
               |> Seq.map (List.filter ((<>) 1))

let prodSumMins = Array.init (K + 1) ((*) 2)
prodSumMins.[1] <- 0

let factorsProductSum xs =
    let sum, prod = List.sum xs, List.mul xs
    (xs.Length + prod - sum, prod)

let updateMins = function
    size,prodSum -> if size <= K && prodSum < prodSumMins.[size]  then
                        prodSumMins.[size] <- prodSum

let problem088() =
    prodSums |> Seq.iter (factorsProductSum >> updateMins)
    prodSumMins |> set |> Set.toArray |> Array.sum

Project Euler Problem 87

Solving Project Euler Problem 87 was very straightforward.
Reusing primes sequence from solution to Project Euler Problem 10 limit it from up by TOPPRIME. Then build arrays of squares, cubes and powers of 4, similarly limited by TOPSUM. Finally, produce all possible sums of elements of these arrays, one of each, that again are limited by TOPSUM, accounting for unique values with the help of HashSet unique. Power of unique gives the problem solution.

#nowarn "40"

let rec primes =
    Seq.cache <| seq { yield 2; yield! Seq.unfold nextPrime 3 }
and nextPrime n =
     if isPrime n then Some(n, n + 2) else nextPrime(n + 2)
and isPrime n =
    if n >= 2 then
        primes
        |> Seq.tryFind (fun x -> n % x = 0 || x * x > n)
        |> fun x -> x.Value * x.Value > n
    else false

let TOPSUM = 50000000L
let TOPPRIME = int(sqrt (float TOPSUM))

let problem087() =
    let candidates = primes |> Seq.takeWhile (fun x -> x <= TOPPRIME) |> Seq.map int64
    let squares = candidates |> Seq.map (fun x -> x * x) |> Seq.toArray
    let cubes =
        candidates
        |> Seq.map (fun x -> x * x * x)
        |> Seq.takeWhile (fun x -> x < TOPSUM) |> Seq.toArray
    let fours =
        squares
        |> Seq.map (fun x -> x * x)
        |> Seq.takeWhile (fun x -> x < TOPSUM) |> Seq.toArray

    let unique = System.Collections.Generic.HashSet()
    for i in [0..squares.Length-1] do
        for j in [0..cubes.Length-1] do
            for k in [0..fours.Length-1] do
                let sum = squares.[i] + cubes.[j] + fours.[k] in
                    if sum <= TOPSUM then unique.Add(sum) |> ignore
    unique.Count

Project Euler Problem 86

Solving Project Euler Problem 86 requires a single geometry-related “AHA”: the shortest path from one corner of a cuboid with sides l*w*h to the diagonally opposite one is the hypotenuse of right triangle with cathetes l and (w + h). The rest of the solution comes out quite straightforward: if we agree that 1<=h<=w<=l<=M, then for each l from 1 to M sum (h + w) runs from 2 to 2*M. For a sequence of growing ls we can find those sums (w + h) that yield positive integer of expression sqrt(l*l + (w + h)*(w + h)). Now the only thing is left to determine: how to for each suitable value (w + h) find the number of combinations of individual values w and h that are in line with 1<=h<=w<=l<=M. This is what function combinations detects in the code below.

With these prerequisites the solution is straightforward: from infinite sequence of growing Ms construct a sequence of tuples (l, (h + w)), then filter out all tuples, but those that yield integer hypotenuse lengths, then scan this filtered sequence into another sequence (paths, M), of which skip members until the first where paths >= 1000000. The associated M is the solution answer.

let combinations l ``h + w`` =
    if l >= ``h + w`` then ``h + w``/ 2
    else l - (``h + w`` + 1) / 2 + 1

let isIntegerHypotenuse (cathetus1,cathetus2) =
    let hypotenuse = sqrt (float (cathetus1 * cathetus1 + cathetus2 * cathetus2))
    hypotenuse = floor hypotenuse

let problem086() =
    Seq.initInfinite id
    |> Seq.collect (fun l ->
                        seq {for ``h + w`` in [2..2*l] -> (l,``h + w``)})
    |> Seq.filter isIntegerHypotenuse
    |> Seq.scan (fun (paths, M) (l, ``h + w``) ->
                     (paths + (combinations l ``h + w``), l))(0,0)
    |> Seq.skipWhile (fun (paths, M) -> paths < 1000000)     |> Seq.head
    |> snd

Running F# Interactive from Windows context menu

Today a question popped up on Stack Overflow on how to arrange running F# scripts from Windows context menu, but in case of abnormal termination still having opportunity to access diagnostics. Regular context menu item Run with F# interactive lacks the latter because interactive console window closes abruptly on script failure.

Although I gave an outline of the solution as Stack Overflow answer, it lacks level of details that those who want to use such feature may find useful. So, I decided to give here a more detailed description. I will show the implementation for my own work environment, which is Windows 7 Ultra x64 + VS2012 Ultra RC. Reproducing the approach for other environments may require trivial adjustments.

1. Let’s begin with spying the mechanics of stock context menu item Run with F# interactive… implementation. Let’s fire regedit in Run as Administrator mode and search through the registry for string value Run with F# interactive:

Context menu

Getting one level down to the subkey HKEY_CLASSES_ROOT\VisualStudio.fsx.11.0\shell\openRunFsi\command

Original command

we can see how exactly this context menu item is implemented on my box:

"C:\Program Files (x86)\Microsoft SDKs\F#\3.0\Framework\v4.0\Fsi.exe" --quiet --exec "%1"

Now the outline of an unobtrusive solution gets clear: let’s create a custom key similar to HKEY_CLASSES_ROOT\VisualStudio.fsx.11.0\shell\openRunFsi, but with our own context menu command having desired properties. In order to make interactive console window stay we can shoot out a shell cmd.exe with command key /k preventing the associated window from closing. However, it came out a problem: being offered the fsi.exe path regular cmd.exe shell cannot correctly interprete quoted string having both spaces and parentethes. In order to workaround this complication we may use as command our own shim batch script fsx.bat that will correctly process the path and pass the argument (.fsx script name) to fsi.exe. So, the context menu command is to be

c:\windows\system32\cmd.exe /Q /K %%USERPROFILE%%\fsx.bat "%1"

and the shim batch script fsx.bat that we’re going to place into the root of user’s directory would be

"C:\Program Files (x86)\Microsoft SDKs\F#\3.0\Framework\v4.0\Fsi.exe" --quiet --exec "%~1"

The only outstanding task to do is adding our custom keys to the registry:
HKEY_CLASSES_ROOT\VisualStudio.fsx.11.0\shell\openRunCmd
HKEY_CLASSES_ROOT\VisualStudio.fsx.11.0\shell\openRunCmd
and HKEY_CLASSES_ROOT\VisualStudio.fsx.11.0\shell\openRunCmd\command
HKEY_CLASSES_ROOT\VisualStudio.fsx.11.0\shell\openRunCmd\command

Finally, let’s check out how everything sticks together. A simplest script sample.fsx will do:

printfn "Let's crash..."
failwith "...but window stays" |> ignore

Let’s invoke it through context menu new item:

Invoke

getting as expected

Result

Voila!

Project Euler Problem 85

After detail-laden Problem 84 solving Project Euler Problem 85 is a breeze. Nevertheless, prior to coding we need to do some preparatory math.
For our grid of h*w cells a specific rectangle can be selected by crossing 2 horizontal lines with 2 vertical. We can pick 2 horizontal lines in (h + 1)!/2!*(h + 1 – 2)! ways (see combination for justification). Similar is true for vertical lines: (w + 1)!/2!*(w + 1 – 2)!. After simplification it comes out that the number of different rectangles on a grid of h*w cells is h*(h + 1)*w*(w + 1)/4.
Now, let’s express approximate value of w via h assuming that overall number of rectangles is less, than 2000000:
w = int(sqrt(float(8000000/(h*(h + 1))))). As we took w*w for w*(w + 1) approximation sometimes we may overshoot by 1; in these cases we would need to decrease w by 1.
The rest is quite simple: starting with h=1 and ending with largest h less, than w let’s find all pairs (w,h) that function rectangles w h yields value closest to 2000000. Of this sequence we select such area w*h that yields minimal difference with 2000000:

let rectangles w h = w * (w + 1) * h * (h + 1) / 4
let solutions =
    Seq.unfold(fun h ->
        let w = int(sqrt(float (8000000/(h*(h+1)))))
        let solution = if rectangles w h > 2000000 then (w - 1,h)
            else (w,h)
        if fst solution <= h then None else Some(solution, h + 1)) 1

let problem085() =
    solutions |> Seq.toList
    |> List.map (fun (w,h) -> (2000000 - (rectangles w h), w*h))
    |> List.sortBy (fun (diff,area) -> diff) |> List.head |> snd

Project Euler Problem 84

Project Euler Problem 84 is fun. Took some time to choose the approach to solve. After some amount of consideration I decided to go with straightforward MonteCarlo simulation.

The only mutable piece of information in the solution below is board array of counters, the rest is pure functional. The state is passed around as a 4-member tuple (boardPosition, chestCard, chanceCard, doubles) containing current main board position, community chest deck card position, chance deck card position, and subsequent double rolls.

Dices are rolled at rollDice function. If it anything, but triple double in row, the state is passed to ifChance function. There if the current position is on a chance square, chance is processed by processChanceCard, and then passed to ifChest, otherwise goes there directly. Similar approach is implemented for community chest squares with ifChest and processChestCard functions.

let [<Literal>]BOARDSIZE = 40
let [<Literal>]CCSIZE = 16
let [<Literal>]CHANCESIZE = 16
let [<Literal>]DICESIDES = 4

let [<Literal>]GO = 0
let [<Literal>]CC1 = 2
let [<Literal>]R1 = 5
let [<Literal>]CH1 = 7
let [<Literal>]JAIL = 10
let [<Literal>]C1 = 11
let [<Literal>]U1 = 12
let [<Literal>]R2 = 15
let [<Literal>]CC2 = 17
let [<Literal>]CH2 = 22
let [<Literal>]E3 = 24
let [<Literal>]R3 = 25
let [<Literal>]U2 = 28
let [<Literal>]G2J = 30
let [<Literal>]CC3 = 34
let [<Literal>]CH3 = 36
let [<Literal>]H2 = 39

let rand = System.Random()
let board = Array.zeroCreate<int> BOARDSIZE

type Doubles = ZeroDouble | OnceDouble | TwiceDouble

let nextRoll() = (rand.Next(DICESIDES) + 1, rand.Next(DICESIDES) + 1)

let (|Double|Ordinary|) roll =
    let sum = fst roll + snd roll in
    if fst roll = snd roll then Double sum else Ordinary sum

let forward boardPosition score = (boardPosition + score) % BOARDSIZE
    
let inc square =
    board.[square] <- board.[square] + 1

let processChestCard (boardPosition, chestCard, chanceCard, doubles) =
    let newChestCard = (chestCard + 1) % CCSIZE
    match newChestCard with
    | 0 -> inc GO; (GO, newChestCard, chanceCard, doubles)
    | 1 -> inc JAIL; (JAIL, newChestCard, chanceCard, doubles)
    | _ -> inc boardPosition; (boardPosition, newChestCard, chanceCard, doubles)

let ifChest (boardPosition, chestCard, chanceCard, doubles) =
    match boardPosition with
    | CC1 | CC2 | CC3 -> processChestCard (boardPosition, chestCard, chanceCard, doubles)
    | G2J -> inc JAIL; (JAIL, chestCard, chanceCard, doubles)
    | _ -> inc boardPosition; (boardPosition, chestCard, chanceCard, doubles)

let processChanceCard (boardPosition, chestCard, chanceCard, doubles) =
    let newChanceCard = (chanceCard + 1) % CHANCESIZE
    match newChanceCard with
    | 0 -> ifChest (GO, chestCard, newChanceCard, doubles)
    | 1 -> ifChest (JAIL, chestCard, newChanceCard, doubles)
    | 2 -> ifChest (C1, chestCard, newChanceCard, doubles)
    | 3 -> ifChest (E3, chestCard, newChanceCard, doubles)
    | 4 -> ifChest (H2, chestCard, newChanceCard, doubles)
    | 5 -> ifChest (R1, chestCard, newChanceCard, doubles)
    | 6 | 7 -> if boardPosition = CH1 then ifChest (R2, chestCard, newChanceCard, doubles)
               elif boardPosition = CH2 then ifChest (R3, chestCard, newChanceCard, doubles)
               elif boardPosition = CH3 then ifChest (R1, chestCard, newChanceCard, doubles)
               else ifChest (boardPosition, chestCard, newChanceCard, doubles)
    | 8 -> if boardPosition = CH2 then ifChest (U2, chestCard, newChanceCard, doubles)
           else ifChest (U1, chestCard, newChanceCard, doubles)
    | 9 -> ifChest (boardPosition - 3, chestCard, newChanceCard, doubles)
    | _ -> ifChest (boardPosition, chestCard, newChanceCard, doubles)

let ifChance (boardPosition, chestCard, chanceCard, doubles) =
    match boardPosition with
    | CH1 | CH2 | CH3 -> processChanceCard (boardPosition, chestCard, chanceCard, doubles)
    | _ -> ifChest (boardPosition, chestCard, chanceCard, doubles)

let rollDice (boardPosition, chestCard, chanceCard, doubles) =
    match nextRoll() with
    | Double score -> match doubles with
                      | ZeroDouble -> ifChance ((forward boardPosition score), chestCard, chanceCard, OnceDouble)
                      | OnceDouble -> ifChance ((forward boardPosition score), chestCard, chanceCard, TwiceDouble)
                      | TwiceDouble -> inc JAIL; (JAIL, chestCard, chanceCard, ZeroDouble)
    | Ordinary score -> ifChance ((forward boardPosition score), chestCard, chanceCard, ZeroDouble)
    
let problem084() =
    let _ = Seq.initInfinite id
            |> Seq.scan (fun (boardPosition, chestCard, chanceCard, doubles) x ->
                rollDice (boardPosition, chestCard, chanceCard, doubles)) (0,0,0,ZeroDouble)
            |> Seq.nth 1000000
    board
    |> Array.mapi (fun i x -> (-x,i))
    |> Array.sortBy(fun (x,y) -> x)
    |> Array.map (fun (x,y) -> y)
    |> Array.toSeq |> Seq.take 3
    |> Seq.fold (fun a x -> a + string x) ""

Few interesting F# features used are: active patterns for handling dice rolls, state passing thru arguments, literals for use in pattern matching. Also an interesting technique is applied with generation of potentially infinite sequence of states using Seq.scan function driven by simply infinite sequence of integers. Evaluating this state sequence to desired length yields the sought frequences for board squares.

Project Euler Problem 83

Although Project Euler Problem 83 seems further generalization of Problem 81 and Problem 82, solution is not based on any of those.

I came up with working solution in couple of minutes after reading thru A* Pathfinding for Beginners. The role of open list plays an F# PowerPack’s HashMultiMap carrying path cost as key and path end location as value. Closed list is a standard .NET HashSet carrying processed locations. We begin with placing left corner element with cost and coordinates into open list.

Each step is quite trivial – take one of the points with current minimal cost from open list; remove it from there; find all points reachable in one step from it; those of them that are not in closed list yet put into open list with newly calculated cost. If the just processed point is not a target point, place it into the closed list and repeat the step; otherwise finish, the cost associated with target point is the answer.

open System
open System.IO
open Microsoft.FSharp.Collections
open System.Collections.Generic

[<Literal>]
let SIDE = 80
let matrix: int[,] = Array2D.zeroCreate SIDE SIDE

let getData (path: string) =
    use sr = new StreamReader(path)
    let line, col = ref 0, ref 0
    while not sr.EndOfStream do
        col := 0
        sr.ReadLine().Split(',')
        |> Array.iter (fun x -> matrix.[!line, !col] <- int x; incr col)
        incr line

let findMinPath (matrix: int[,]) =
    let openList = new HashMultiMap<_,_>(HashIdentity.Structural)
    let closeList = HashSet<_>()
    openList.Add(matrix.[0, 0], (0,0))
    let rec step () =
        if openList.Count = 0 then failwith "No path exists"
        let minKey = openList.Fold (fun key _ acc ->
                if key < acc then key else acc) Int32.MaxValue
        let minElem = openList.FindAll minKey |> List.head
        let cost, (x,y) = minKey, minElem
        openList.Remove minKey
        [ (x-1,y); (x+1,y); (x,y-1); (x, y+1) ] // reachable from node
        |> List.filter (fun (x,y) -> x >= 0 && y >=0 && x < SIDE && y < SIDE)
        |> List.iter (fun (x,y) ->
            if not (closeList.Contains (x,y)) then
                    openList.Add(cost + matrix.[x, y], (x,y)))
        closeList.Add(x,y) |> ignore
        if (x,y) = (SIDE-1,SIDE-1) then cost else step()
    step()

let problem083() =
    getData @"..\..\..\Datafiles\Problem081.data" // same data P.81 & 82 & 83
    findMinPath matrix