Solving fun puzzles with F#

Do you need to convince your friends & family that programming can be fun? For the last Christmas, I got a puzzle as a gift. It is a number of small cubes, joined together, that can be rotated and folded to form a bigger (4x4x4) cube.

We spent the last few days of the year with family and a couple of friends and I left the puzzle on the table. Every time I walked around, someone was playing with it without much success. In the end, I said that if noone solves it until 31 December, I'll write a program to do it. Which I did between 7 PM and 8 PM and, voilĂ , here is what I got...

So, how do you solve a puzzle in about 1 hour on New Year's eve?

Modeling the problem

As with any problem in F#, we start by modeling the domain. The puzzle consists of parts (small cubes) that have two important properties:

type Color = Black | White
type Kind = Straight | Turn
type Part = Color * Kind

Each part has a color (black or white) and there are two kinds of parts. In one kind, the string connecting the parts goes straight through the part (and so it does not allow any useful rotation). In the other part, the string turns and so the next part can point in one of four directions. Assuming the previous part points from bottom to the top, we can now go to the front, back, left or right.

We'll also need to represent positions of the parts in the final cube and the direction in which a part is pointing:

type Position = int * int * int
type Direction = int * int * int

Here, the position will be integers from 0 to 3 and direction will always contain exactly one 1 or -1 value (with zeros for all other axes). We could make the model more precise, but this will make calculations easy (note that we only have 1 hour to finish :-)).

Now, the entire puzzle (first picture) is simply a list of parts:

type Shape = list<Part>

The model so far can actually be understood by non-programmers. It has been tested on humans (but only close relatives and friends!) and it worked fine :-). This is one of the key strengths of domain modeling with F#...

Implementing the algorithm

The algorithm we'll implement is quite straightforward backtracking. We'll simulate the different ways in which the puzzle can be folded (starting from 4 different positions as others would be symmetric). When we hit a state that would not be valid (there is a part already or the colors would not match), we'll go back and try another folding.

When we have a Straight part, the next part of the puzzle will always be one step further in the current direction. This is easy. The interesting thing is when we have a Turn part - in that case we can go in four different directions, which are calculated using the following functions:

/// Given 'Position' and 'Direction' calculate
/// a new position (by adding the offsets)
let move (x,y,z) (dx,dy,dz) = (x+dx, y+dy, z+dz)

/// For a 'Turn' part oriented in the given 'Direction'
/// generate a list of possible next Directions
let offsets (dx, dy, dz) = 
  [ if dx = 0 then for i in [-1;1] do yield i, 0, 0
    if dy = 0 then for i in [-1;1] do yield 0, i, 0
    if dz = 0 then for i in [-1;1] do yield 0, 0, i ]

/// Given a current 'Position' and 'Direction', get a list
/// of possible new Directions and corresponding Positions
let rotate position direction : list<Direction * Position> = 
  [ for offs in offsets direction -> 
      offs, move position offs ]

To understand this part, you still do not need to be a programmer. And the fact that we are writing just functions makes this quite easy too. However, you definitely need some mathematical background.

Checking valid moves

The next part of the preparation is to write a fucntion for checking whether a move is valid. There are two conditions:

  • A move is not valid if there is a part already at a given Position.
  • We can only put parts inside the range of the cube (all coordinates are within 0 .. 3)
  • The colors of the parts should match the pattern that you can see in the picture above.

We'll keep a set of occupied positions using immutable F# Set. For color patterns, we can build a simple dictionary with expected colors - as the pattern is regular, we can only store colors for smaller 2x2x2 cube (and then check using pos / 2.

/// A set of occupied positions
type CubeState = Set<Position>

/// Expected colors for each position
let colorMap = 
  [ (0,0,0), Black; (0,0,1), White;
    (0,1,0), White; (1,0,0), White;
    (1,1,1), White; (1,1,0), Black;
    (1,0,1), Black; (0,1,1), Black ] 
  |> dict

The following isValidPosition function takes a Position and a current CubeState and checks whether it is a valid position (we'll handle colors later):

/// Checks that the specified position is "inside" the
/// cube and there is no part already in that place
let isValidPosition position (state:CubeState) = 
  let x, y, z = position
  let free = not (state.Contains(position))
  let inRange = 
    x >= 0 && y >= 0 && z >= 0 && 
    x <= 3 && y <= 3 && z <= 3
  free && inRange

This ignores the color constraints. Mainly because I added this later when solving the puzzle. Surprisingly, it is quite important constraint - there are many more options without the restriction on colors. We'll put the check in the main algorithm later.

Generating moves

Before looking at the main part, there are two more functions we need. Given a part (which can be Straight or Turn), current position and direction and also the current state, we want to get all valid directions and locations for the next part:

/// Given a current Position & Direction and current
/// Part, get a list of next Positions & Directions
let getPositions position direction part = 
  match part with 
  | (_, Straight) -> [ direction, move position direction ]  
  | (_, Turn) -> rotate position direction

/// Get next valid positions (with directions)
let getValidPositions pos dir part state =
  [ for dir, pos in getPositions pos dir part do
      if isValidPosition pos state then yield dir, pos ]

Backtracking using recursion

So far, most of the code was quite easy. You can explain the type definitions to people without any technical skills. Understanding the main algorithm probably requires some programming background, but it is still surprisingly simple.

We write a recursive function solve that keeps the current position and direction (pos and dir), the current state of the cube (set of occupied positions) and a trace. The trace is a list of places where we put cubes earlier and this will contain the final result at the end.

The last parameter is shape which is the list of parts. As we iterate, we always take out the head of the list and call the function recursively for the tail (the rest of the list excluding the first part):

/// Recursive function that solves the puzzle using backtracking
let rec solve pos dir state trace (shape:Shape) = seq {
  match shape, pos with 
  | [part], _ -> 
      // We have reached the end. Return the trace!
      yield (List.rev trace)
  | part::shape, (x,y,z) when fst part = colorMap.[x/2,y/2,z/2] -> 
      // Current part has the rigth color, get valid 
      // positions for the next part & try all of them
      let moves = getValidPositions pos dir part state 
      for dir, pos in moves do
        let trace = pos::trace
        yield! solve pos dir (Set.add pos state) trace shape 
  | _ -> 
      // Current part does not have the right color
      // (so we have to go back and try another layout)
      () }

The solve function uses pattern matching to handle three different cases:

  • The pattern [part] checks that there is just one last part left. In that case, we have a solution - because we already checked that the position is legal. So, we just return the trace and reverse it to get the steps from the first to the last.

  • The pattern part::shape checks that we have one or more parts and gives us the first one as part. We also decompose the position into x,y,z so that we can check whether the color of the part matches the required color.

    If all conditions are satisfied, we call getValidPositions to get all valid positions for the next step, iterate over them and try to return all possible results using yield! (more about this later).

  • The last case represents the case when the colors do not match. In this situation, we just "do nothing" and return back to the previous step.

Note that the whole function is wrapped in the seq { .. } block. This means that we can generate all possible solutions (we return one using the yield keyword). In practice, it turns out that they are all symmetric, but this was an interesting experiment :-).

Solving the puzzle

So, we finally have all we need to solve the puzzle! Now comes the tedious part, which is looking at the puzzle and noting down the exact sequence of colors and kinds. I did this by writing down two strings:

let puzzle : Shape = 
  // Lookup tables for different colors/kinds
  let clrs  = dict ['b', Black; 'w', White]
  let kinds = dict ['s', Straight; 'r', Turn]
  // Read the string and build a list of 'Part' values
  ( "bbbwwwwwwwwbbbbwwwbbbbbbwwwbbwbbwbbwwwwwbbbbbbwbwwwbbbbwwwwwbbww",
    "srssrrrrrrrrrrsrrssrrrrssrsrrrrrrsrsrrrrrrrrrsrrsrrsrrssrrrsrrss" )
  ||> Seq.map2 (fun clr kind -> clrs.[clr], kinds.[kind])
  |> List.ofSeq

To my surprise, I actually wrote this down correctly at the first attempt! Now, we just call the solve function - we need to pick the first location and the first direction. It turns out that starting in one of the corners works fine. In that case, the direction does not matter (because they will all be symmetric):

// Pick starting location
let start = (0, 0, 0)
// Run the 'solve' function 
let res = solve start (0, 0, 1) (set [start]) [start] puzzle 

// Pick the first solution & print positions
let solution = Seq.head res 
solution |> Seq.iteri (fun i p -> 
  printfn "%d - %A" (i+1) p)

This prints a sequence of X, Y and Z coordinates of the parts. With a bit of effort, you can actually build the puzzle using this information, because you always know where the next part should go. This is what I did at first.

But then I realized that I could do one more step and make the demo really fun!

Building 3D visualization

Some time ago, I wrote a simple library for composing 3D objects and it turns out to be a perfect fit. The library provides a couple of primitve shapes like cube, cone and cylinder and combinators for putting them together. Here is a simple example:

// Reference OpenTK library & functional DSL
#r "OpenTK.dll"
#r "OpenTK.GLControl.dll"
#load "functional3d.fs"
open Functional3D
open System.Drawing

// Create a yellow cylinder and compose it with
Fun.color Color.Yellow Fun.cylinder $
// a red cone that is translated in the Z direction
  (0.0, 0.0, -1.0)
  (Fun.color Color.Red Fun.cone)

In just a two lines of code (if you do not try to format things nicely for a blog), you can easily put together a simple tower!

By defualt, all objects are created in the middle of the world, so if we want to compose them, we have to use Fun.translate to move them around. Then you can use the $ operator to combine multiple shapes into a single one.

Visualizing cube puzzle

Building a visualization for the cube puzzle is quite simple. We write a function draw i that takes the first i elements of the trace, generates one cube for each of them and moves them to the right position:

/// Convert coordinate to float values
let fl (x,y,z) = 
  (float x, float y, float z)

/// Draw the first 'i' steps of the puzzle
let draw i =
  |> Seq.take i
  |> (fun ((x, y, z) as p) -> 
      // Get the expected color based on the color map
      let color = 
        if colorMap.[x/2,y/2,z/2] = Black then 
          Color.SaddleBrown else Color.BurlyWood
      // Create a cube, make it a bit smaller, change
      // its color and move it to the right position
      |> Fun.scale (0.95,0.95,0.95)
      |> Fun.color color
      |> Fun.translate (fl p) )
  |> Seq.reduce ($)

The function first generates a sequence of cubes and then composes them into a single big 3D shape using the Seq.reduce function. This applies the $ operator gradually to all parts building the final object.

Now we can call this from a simple asynchronous loop that adds steps one-by-one, with a 200ms delay between them:

Async.StartImmediate <| async { 
  for i in 1 .. 64 do 
    do! Async.Sleep(200) (draw i) }

The computation waits 200ms, then it builds the 3D model of the next step and displays it using We start the computation using Async.StartImmediate, which makes sure that all the processing is done on the main user-interface thread and so we can access the UI elements and actually update the control showing the visualization.


First of all, let the results speak for themselves:

I think it is quite amazing how much can be done in such a small number of lines of code in so little amount of time.

After watching people play with the puzzle for a couple of days, I wrote most of the code to solve the puzzle in about 1.5 hours during a New Year's afternoon and eve and the puzzle was solved! This alone would be quite nice, but the fact that I was able to add visualization in about 15 minutes made this really a nice example of why programming with F# is fun :-).

So, if you want to impress your family and friends with your programming skills, learning F# is most certainly the way to go!

type Color =
  | Black
  | White

Full name: Puzzling-fsharp_.Color
union case Color.Black: Color
union case Color.White: Color
type Kind =
  | Straight
  | Turn

Full name: Puzzling-fsharp_.Kind
union case Kind.Straight: Kind
union case Kind.Turn: Kind
type Part = Color * Kind

Full name: Puzzling-fsharp_.Part
type Position = int * int * int

Full name: Puzzling-fsharp_.Position
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name:

type int = int32

Full name:

type int<'Measure> = int

Full name:<_>
type Direction = int * int * int

Full name: Puzzling-fsharp_.Direction
type Shape = Part list

Full name: Puzzling-fsharp_.Shape
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
val move : x:int * y:int * z:int -> dx:int * dy:int * dz:int -> int * int * int

Full name: Puzzling-fsharp_.move

 Given 'Position' and 'Direction' calculate
 a new position (by adding the offsets)
val x : int
val y : int
val z : int
val dx : int
val dy : int
val dz : int
val offsets : dx:int * dy:int * dz:int -> (int * int * int) list

Full name: Puzzling-fsharp_.offsets

 For a 'Turn' part oriented in the given 'Direction'
 generate a list of possible next Directions
val i : int
val rotate : int * int * int -> int * int * int -> (Direction * Position) list

Full name: Puzzling-fsharp_.rotate

 Given a current 'Position' and 'Direction', get a list
 of possible new Directions and corresponding Positions
val position : int * int * int
val direction : int * int * int
val offs : int * int * int
type CubeState = Set<Position>

Full name: Puzzling-fsharp_.CubeState

 A set of occupied positions
Multiple items
module Set

from Microsoft.FSharp.Collections

type Set<'T (requires comparison)> =
  interface IComparable
  interface IEnumerable
  interface IEnumerable<'T>
  interface ICollection<'T>
  new : elements:seq<'T> -> Set<'T>
  member Add : value:'T -> Set<'T>
  member Contains : value:'T -> bool
  override Equals : obj -> bool
  member IsProperSubsetOf : otherSet:Set<'T> -> bool
  member IsProperSupersetOf : otherSet:Set<'T> -> bool

Full name: Microsoft.FSharp.Collections.Set<_>

new : elements:seq<'T> -> Set<'T>
val colorMap : System.Collections.Generic.IDictionary<(int * int * int),Color>

Full name: Puzzling-fsharp_.colorMap

 Expected colors for each position
val dict : keyValuePairs:seq<'Key * 'Value> -> System.Collections.Generic.IDictionary<'Key,'Value> (requires equality)

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.dict
val isValidPosition : int * int * int -> state:CubeState -> bool

Full name: Puzzling-fsharp_.isValidPosition

 Checks that the specified position is "inside" the
 cube and there is no part already in that place
val state : CubeState
val free : bool
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
member Set.Contains : value:'T -> bool
val inRange : bool
val getPositions : int * int * int -> int * int * int -> 'a * Kind -> ((int * int * int) * (int * int * int)) list

Full name: Puzzling-fsharp_.getPositions

 Given a current Position & Direction and current
 Part, get a list of next Positions & Directions
val part : 'a * Kind
val getValidPositions : int * int * int -> int * int * int -> 'a * Kind -> state:CubeState -> ((int * int * int) * (int * int * int)) list

Full name: Puzzling-fsharp_.getValidPositions

 Get next valid positions (with directions)
val pos : int * int * int
val dir : int * int * int
val solve : int * int * int -> int * int * int -> state:CubeState -> trace:(int * int * int) list -> shape:Shape -> seq<(int * int * int) list>

Full name: Puzzling-fsharp_.solve

 Recursive function that solves the puzzle using backtracking
val trace : (int * int * int) list
val shape : Shape
Multiple items
val seq : sequence:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Core.Operators.seq

type seq<'T> = System.Collections.Generic.IEnumerable<'T>

Full name: Microsoft.FSharp.Collections.seq<_>
val part : Part
Multiple items
module List

from Microsoft.FSharp.Collections

type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val rev : list:'T list -> 'T list

Full name: Microsoft.FSharp.Collections.List.rev
val shape : Part list
val fst : tuple:('T1 * 'T2) -> 'T1

Full name: Microsoft.FSharp.Core.Operators.fst
val moves : ((int * int * int) * (int * int * int)) list
val add : value:'T -> set:Set<'T> -> Set<'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Set.add
val puzzle : Shape

Full name: Puzzling-fsharp_.puzzle
val clrs : System.Collections.Generic.IDictionary<char,Color>
val kinds : System.Collections.Generic.IDictionary<char,Kind>
module Seq

from Microsoft.FSharp.Collections
val map2 : mapping:('T1 -> 'T2 -> 'U) -> source1:seq<'T1> -> source2:seq<'T2> -> seq<'U>

Full name: Microsoft.FSharp.Collections.Seq.map2
val clr : char
val kind : char
val ofSeq : source:seq<'T> -> 'T list

Full name: Microsoft.FSharp.Collections.List.ofSeq
val start : int * int * int

Full name: Puzzling-fsharp_.start
val res : seq<(int * int * int) list>

Full name: Puzzling-fsharp_.res
val set : elements:seq<'T> -> Set<'T> (requires comparison)

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.set
val solution : (int * int * int) list

Full name: Puzzling-fsharp_.solution
val head : source:seq<'T> -> 'T

Full name: Microsoft.FSharp.Collections.Seq.head
val iteri : action:(int -> 'T -> unit) -> source:seq<'T> -> unit

Full name: Microsoft.FSharp.Collections.Seq.iteri
val p : int * int * int
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
module Functional3D
namespace System
namespace System.Drawing
module Fun

from Functional3D
val color : clr:Color -> Drawing3D -> Drawing3D

Full name: Functional3D.Fun.color

 Set color to be used when drawing the specified 3D objects
type Color =
    member A : byte
    member B : byte
    member Equals : obj:obj -> bool
    member G : byte
    member GetBrightness : unit -> float32
    member GetHashCode : unit -> int
    member GetHue : unit -> float32
    member GetSaturation : unit -> float32
    member IsEmpty : bool
    member IsKnownColor : bool

Full name: System.Drawing.Color
property Color.Yellow: Color
val cylinder : Drawing3D

Full name: Functional3D.Fun.cylinder

 Generates a 3D cylinder object of a unit size
val translate : x:float * y:float * z:float -> Drawing3D -> Drawing3D

Full name: Functional3D.Fun.translate

 Move the specified object by the provided offsets
property Color.Red: Color
val cone : Drawing3D

Full name: Functional3D.Fun.cone

 Generate the sphere
 Generates a 3D cylinder object of a unit size
val fl : x:int * y:int * z:int -> float * float * float

Full name: Puzzling-fsharp_.fl

 Convert coordinate to float values
Multiple items
val float : value:'T -> float (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.float

type float = System.Double

Full name: Microsoft.FSharp.Core.float

type float<'Measure> = float

Full name: Microsoft.FSharp.Core.float<_>
val draw : i:int -> Drawing3D

Full name: Puzzling-fsharp_.draw

 Draw the first 'i' steps of the puzzle
val take : count:int -> source:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Collections.Seq.take
val map : mapping:('T -> 'U) -> source:seq<'T> -> seq<'U>

Full name:
val color : Color
property Color.SaddleBrown: Color
property Color.BurlyWood: Color
val cube : Drawing3D

Full name: Functional3D.Fun.cube

 Creates a 3D cube of unit size using the current color
val scale : x:float * y:float * z:float -> Drawing3D -> Drawing3D

Full name: Functional3D.Fun.scale

 Scale the specified 3D object by the specified scales along the 3 axes
val reduce : reduction:('T -> 'T -> 'T) -> source:seq<'T> -> 'T

Full name: Microsoft.FSharp.Collections.Seq.reduce
Multiple items
type Async
static member AsBeginEnd : computation:('Arg -> Async<'T>) -> ('Arg * AsyncCallback * obj -> IAsyncResult) * (IAsyncResult -> 'T) * (IAsyncResult -> unit)
static member AwaitEvent : event:IEvent<'Del,'T> * ?cancelAction:(unit -> unit) -> Async<'T> (requires delegate and 'Del :> Delegate)
static member AwaitIAsyncResult : iar:IAsyncResult * ?millisecondsTimeout:int -> Async<bool>
static member AwaitTask : task:Task<'T> -> Async<'T>
static member AwaitWaitHandle : waitHandle:WaitHandle * ?millisecondsTimeout:int -> Async<bool>
static member CancelDefaultToken : unit -> unit
static member Catch : computation:Async<'T> -> Async<Choice<'T,exn>>
static member FromBeginEnd : beginAction:(AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg:'Arg1 * beginAction:('Arg1 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg1:'Arg1 * arg2:'Arg2 * beginAction:('Arg1 * 'Arg2 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg1:'Arg1 * arg2:'Arg2 * arg3:'Arg3 * beginAction:('Arg1 * 'Arg2 * 'Arg3 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromContinuations : callback:(('T -> unit) * (exn -> unit) * (OperationCanceledException -> unit) -> unit) -> Async<'T>
static member Ignore : computation:Async<'T> -> Async<unit>
static member OnCancel : interruption:(unit -> unit) -> Async<IDisposable>
static member Parallel : computations:seq<Async<'T>> -> Async<'T []>
static member RunSynchronously : computation:Async<'T> * ?timeout:int * ?cancellationToken:CancellationToken -> 'T
static member Sleep : millisecondsDueTime:int -> Async<unit>
static member Start : computation:Async<unit> * ?cancellationToken:CancellationToken -> unit
static member StartAsTask : computation:Async<'T> * ?taskCreationOptions:TaskCreationOptions * ?cancellationToken:CancellationToken -> Task<'T>
static member StartChild : computation:Async<'T> * ?millisecondsTimeout:int -> Async<Async<'T>>
static member StartChildAsTask : computation:Async<'T> * ?taskCreationOptions:TaskCreationOptions -> Async<Task<'T>>
static member StartImmediate : computation:Async<unit> * ?cancellationToken:CancellationToken -> unit
static member StartWithContinuations : computation:Async<'T> * continuation:('T -> unit) * exceptionContinuation:(exn -> unit) * cancellationContinuation:(OperationCanceledException -> unit) * ?cancellationToken:CancellationToken -> unit
static member SwitchToContext : syncContext:SynchronizationContext -> Async<unit>
static member SwitchToNewThread : unit -> Async<unit>
static member SwitchToThreadPool : unit -> Async<unit>
static member TryCancelled : computation:Async<'T> * compensation:(OperationCanceledException -> unit) -> Async<'T>
static member CancellationToken : Async<CancellationToken>
static member DefaultCancellationToken : CancellationToken

Full name: Microsoft.FSharp.Control.Async

type Async<'T>

Full name: Microsoft.FSharp.Control.Async<_>
static member Async.StartImmediate : computation:Async<unit> * ?cancellationToken:System.Threading.CancellationToken -> unit
val async : AsyncBuilder

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.async
static member Async.Sleep : millisecondsDueTime:int -> Async<unit>
val show : drawing:Drawing3D -> unit

Full name:

 Display the specified 3D object on a form

Discuss on twitter, .
Send corrections via GitHub pull requests.