Added Petricek's samples

2015_03_26_Tomas_Petricek_Domain_Specific_Languages_FSharp/Classifiers/1 Pricing.fsx

@@ -0,0 +1,127 @@
+#load "Classifiers.fsx"
+
+open System
+open System.Net
+open System.Windows
+open System.Threading
+open Classifiers
+
+// -------------------------------------------------------
+// Create classifier window
+// -------------------------------------------------------
+
+let win = new ClassifierWindow(TopMost = true)
+win.Run("MSFT")
+
+// Add some simple pattern classifiers (always rising never occurs!)
+win.Add("Always up", Price.rising)
+win.Add("Mostly up", Price.regression Price.rising)
+win.Add("Mostly down", Price.regression Price.declining)
+win.Add("Average", Price.average)
+
+// Compose pattern for detecting the "V" pattern
+let mostlyUp = Price.regression Price.rising
+let mostlyDown = Price.regression Price.declining
+win.Add("V pattern", Price.sequenceAnd mostlyDown mostlyUp)
+
+// Pattern that detects when price is going up and is above given limit
+let highAndRising limit = 
+  Price.both
+    Price.average
+    mostlyUp
+  |> Price.map (fun (avg, up) ->
+      avg > limit && up)
+
+win.Add("High & rising", highAndRising 30.0)
+
+
+
+
+
+
+// ------------------------------------------------------------------
+// Simple pattern classifiers
+
+open Classifiers.Price
+
+// Price is always rising (rarely happens)
+win.Add("Always rising", rising)
+
+// Price rising over a linear regression
+win.Add("Mostly rising", regression rising)
+win.Add("Mostly declining", regression declining)
+
+
+// Classifiers for calculating numeric indicators
+
+// Basic classifiers extract min, max, avg
+win.Add("Minimum", minimum)
+win.Add("Maximum", maximum)
+win.Add("Average", average)
+
+// Calculate difference between min and max
+let diff = both minimum maximum |> map (fun (l, h) -> h - l)
+win.Add("Difference", diff)
+
+// Detecting interesting patterns 
+
+// Inverse "V" pattern (price goes up, then down)
+let upDown = sequenceAnd (regression rising) (regression declining)
+win.Add("Up & Down", upDown)
+
+// Classifier checks whether average is less than specified
+let averageLessThan lo =
+  average |> map (fun v -> v < lo)
+
+// Classifier detects rising price with avg under 26
+let risingUnder26 = 
+  bothAnd (regression rising) (averageLessThan 26.0)
+win.Add("Rising <26", risingUnder26)
+
+// True when difference is greater than specified
+let differsBy limit = 
+  both minimum maximum |> map (fun (l, h) -> h - l > limit)
+
+// The price is mostly rising and the difference is more than 3
+let risingFast = bothAnd (regression rising) (differsBy 3.0)
+win.Add("Rising fast", risingFast)
+
+
+// Computation expression examples
+
+// Price is declining and average is more than 27
+let downOver27 = classify { 
+  // Calculate average over the range
+  let! avg = average
+  // Test if the price is mostly declining
+  let! down = regression declining
+  // Evaluate the condition 
+  return down && (avg >= 27.0) }
+
+win.Add("Down >27", downOver27)
+
+
+// Detecting the "L" patterns & some helpers
+
+// Get the min-max range 
+let range = both minimum maximum
+// Left side is going down
+let leftDown = bothAnd (regression declining) always
+win.Add("Left down", leftDown)
+
+// Detect the "L" pattern 
+// (Left side goes down & the right side keeps low
+// - in range 1/3 from minimum of left side)
+let patternL = classify {
+  // Get ranges for left & right parts
+  let! (lmin, lmax), (rmin, rmax) = sequence range range
+  // The left part is declining
+  let! decl = leftDown
+  
+  // The right part keeps in a range
+  // (lo +/- of 1/3 difference)
+  let offs = (lmax - lmin) / 3.0
+  let inRange v = v >= lmin - offs && v <= lmin + offs
+  return decl && inRange rmin && inRange rmax } 
+
+win.Add("L pattern", patternL)

2015_03_26_Tomas_Petricek_Domain_Specific_Languages_FSharp/Classifiers/Classifiers.fsx

@@ -0,0 +1,255 @@
+open System
+open System.Net
+open System.Windows
+open System.Threading
+
+// ------------------------------------------------------------------
+// Domain-specific language for creating classifiers
+
+/// Represents a classifier that produces a value 'T
+type Classifier<'T> = PT of ((DateTime * float)[] -> 'T)
+
+
+/// Simple classifiers that extract value or check property
+module Price =
+
+  // ----------------------------------------------------------------
+  // Basic functions for composition
+
+  /// Runs a classifier and transforms the result using a specified function
+  let map g (PT f) = PT (f >> g)
+
+  /// Classifier that alwasy succeeds & returns the specified value
+  let unit v = PT (fun _ -> v)
+  /// Classifier that applies two classifiers in sequence
+  let bind f (PT g) = PT (fun values -> 
+    let (PT r) = f (g values) in r values)
+
+  /// Simple classifier that always returns true
+  let always = unit true
+
+  /// Creates a classifier that combines the result of two classifiers using a tuple
+  let both (PT f) (PT g) = PT (fun values -> f values, g values)
+
+  /// Checks two properties of subsequent parts of the input
+  let sequence (PT f1) (PT f2) = PT (fun input ->
+    let length = input.Length
+    let input1 = input.[0 .. length/2 - (if length%2=0 then 1 else 0)]
+    let input2 = input.[length/2 .. length-1]
+    (f1 input1, f2 input2))
+
+  /// Gets the minimum over the whole range
+  let reduce f = PT (fun input ->
+    input |> Seq.map snd |> Seq.reduce f)
+
+  // ----------------------------------------------------------------
+  // Primitive classifiers
+
+  /// Checks whether the price is rising over the whole checked range
+  let rising = PT (fun input ->
+    input |> Seq.pairwise |> Seq.forall (fun ((_, a), (_, b)) -> b >= a))
+
+  /// Checks whether the price is declining over the whole checked range
+  let declining = PT (fun input ->
+    input |> Seq.pairwise |> Seq.forall (fun ((_, a), (_, b)) -> b <= a))
+
+  /// Gets the minimum over the whole range
+  let minimum = reduce min |> map (fun v -> Math.Round(v, 2))
+
+  /// Gets the maximum over the whole range
+  let maximum = reduce max |> map (fun v -> Math.Round(v, 2))
+
+  /// Gets the maximum over the whole range
+  let average = PT (fun input ->
+    Math.Round(input |> Seq.map snd |> Seq.average, 2) )
+
+  /// Checks that the price is at least the specified value in the whole range
+  let atLeast min = PT (Seq.forall (fun (_, v) -> v >= min))
+
+  /// Checks that the price is at most the specified value in the whole range
+  let atMost max = PT (Seq.forall (fun (_, v) -> v <= max))
+
+  // ----------------------------------------------------------------
+  // Advanced combinators
+
+  /// Checks that two properties hold for subsequent parts of the input
+  let sequenceAnd a b = sequence a b |> map (fun (a, b) -> a && b)
+  /// Checks that two properties hold for the same input
+  let bothAnd a b = both a b |> map (fun (a, b) -> a && b)
+  /// Checks that one of the properties holds for subsequent parts of the input
+  let sequenceOr a b = sequence a b |> map (fun (a, b) -> a || b)
+  /// Checks that one of the properties holds for the same input
+  let bothOr a b = both a b |> map (fun (a, b) -> a || b)
+
+  /// Checks that the price is withing a specified range over the whole input
+  let inRange min max = bothAnd (atLeast min) (atMost max)
+
+  /// Checks that the property holds over an approximation 
+  /// obtained using linear regression
+  let regression (PT f) = PT (fun values ->
+    // TODO: Use date time in case it is not linear
+    let xavg = float (values.Length - 1) / 2.0
+    let yavg = Seq.averageBy snd values
+    let sums = values |> Seq.mapi (fun x (_, v) -> 
+      (float x - xavg) * (v - yavg), pown (float x - xavg) 2)
+    let v1 = Seq.sumBy fst sums
+    let v2 = Seq.sumBy snd sums
+    let a = v1 / v2
+    let b = yavg - a * xavg 
+    values |> Array.mapi (fun x (dt, _) -> (dt, a * (float x) + b)) |> f)
+
+/// Computation expression builder for building classifiers
+type ClassifierBuilder() = 
+  member x.Return(v) = Price.unit v
+  member x.Bind(c, f) = Price.bind f c
+
+/// Instance of computation expression builder for classifiers
+let classify = ClassifierBuilder()
+
+/// Does the property hold over the entire data set?
+let run (PT f) (data:(DateTime * float)[]) = 
+  f data
+
+
+// ------------------------------------------------------------------
+// Downloading stock prices from Yahoo
+
+
+/// Asynchronously downloads stock prices from Yahoo
+let downloadPrices from stock = async {
+  // Download price from Yahoo
+  let wc = new WebClient()
+  let url = "http://ichart.finance.yahoo.com/table.csv?s=" + stock
+  let! html = wc.AsyncDownloadString(Uri(url)) 
+  let lines = html.Split([|'\n'; '\r'|], StringSplitOptions.RemoveEmptyEntries)
+  let lines = lines |> Seq.skip 1 |> Array.ofSeq |> Array.rev
+
+  // Return sequence that reads the prices
+  let data = seq { 
+    while true do
+      for line in lines do
+        let infos = (line:string).Split(',')
+        let dt = DateTime.Parse(infos.[0])
+        let op = float infos.[1] 
+        if dt > from then yield dt, op } 
+
+  return data }
+
+// ------------------------------------------------------------------
+// Visualizing stock prices using FSharpChart
+
+#load "lib\\FSharpChart.fsx"
+open MSDN.FSharp.Charting
+open ChartData
+
+open System.Windows.Forms
+open System.Drawing
+
+type ClassifierWindow() = 
+  inherit Form(Visible=true, Width=800, Height=500)
+
+  /// List of update functions to be called from GUI
+  let updates = ResizeArray<((DateTime * float)[] -> unit) * (unit -> unit)>()
+  let cleanup = ref ignore
+
+  // Current cancellation token
+  let tok = ref <| new CancellationTokenSource()
+
+  let grid = System.Windows.Forms.DataVisualization.Charting.Grid(LineColor=System.Drawing.Color.DimGray)
+  let ds = new OneValue()
+  let ch = 
+    FSharpChart.Line [ 0.0 .. 100.0 ]
+    |> FSharpChart.WithArea.AxisY(MajorGrid=grid)
+    |> FSharpChart.WithArea.AxisX(MajorGrid=grid)
+
+  let chart = new ChartControl(ch, Dock = DockStyle.Fill)
+  let chartArea = (chart.Controls.[0] :?> System.Windows.Forms.DataVisualization.Charting.Chart).ChartAreas.[0]
+  do chartArea.BackColor <- Color.Black
+  do chartArea.AxisX.TitleForeColor <- Color.White
+  do chartArea.AxisY.TitleForeColor <- Color.White
+  do chart.BackColor <- Color.Black
+  do base.BackColor <- Color.Black
+  do base.ForeColor <- Color.White
+  do ((chart.Controls.[1] :?> System.Windows.Forms.PropertyGrid).SelectedObject :?> System.Windows.Forms.DataVisualization.Charting.Chart).BackColor  <- System.Drawing.Color.Black
+  do chartArea.AxisX.LineColor <- System.Drawing.Color.White
+  do chartArea.AxisY.LineColor <- System.Drawing.Color.White
+  do chartArea.AxisX.LabelStyle.ForeColor <- System.Drawing.Color.White
+  do chartArea.AxisY.LabelStyle.ForeColor <- System.Drawing.Color.White
+
+  let split = new SplitContainer(Dock = DockStyle.Fill)
+  do 
+    base.Controls.Add(split)
+    split.SplitterDistance <- 520
+    split.Panel1.Controls.Add(chart)
+  do ds.BindSeries(chart.ChartSeries)
+
+  /// Add classifier to list & create GUI
+  let addBoolClassifier name (cls:Classifier<bool>) = 
+    let cont = new Panel(Anchor = (AnchorStyles.Left ||| AnchorStyles.Right ||| AnchorStyles.Top), Height=50, Width=split.Panel2.Width, Top=split.Panel2.Controls.Count*50)
+    let box = new Panel(Width = 60, Height = 30, Top = 10, Left = 10, BackColor=Color.LightGray)
+    cont.Controls.Add(box)
+    split.Panel2.Controls.Add(cont)
+    let block = new Label(Text = name, Height=50, Left=80, Width=split.Panel2.Width-60,Anchor = (AnchorStyles.Left ||| AnchorStyles.Right), TextAlign = ContentAlignment.MiddleLeft)
+    block.Font <- new System.Drawing.Font("Calibri", 15.0f)
+    cont.Controls.Add(block)
+
+    let update data =
+      box.BackColor <- if run cls data then Color.YellowGreen else Color.DimGray
+    let clear () = 
+      split.Panel2.Controls.Remove(cont)
+    updates.Add( (update, clear) ) 
+
+  /// Add classifier to list & create GUI
+  let addFloatClassifier name (cls:Classifier<float>) = 
+    let cont = new Panel(Anchor = (AnchorStyles.Left ||| AnchorStyles.Right ||| AnchorStyles.Top), Height=50, Width=split.Panel2.Width, Top=split.Panel2.Controls.Count*50)
+    let box = new Label(Width = 60, Height = 30, Top = 10, Left = 10, TextAlign = ContentAlignment.MiddleCenter)
+    cont.Controls.Add(box)
+    split.Panel2.Controls.Add(cont)
+    let block = new Label(Text = name, Height=50, Left=80, Width=split.Panel2.Width-60,Anchor = (AnchorStyles.Left ||| AnchorStyles.Right), TextAlign = ContentAlignment.MiddleLeft)
+    block.Font <- new System.Drawing.Font("Calibri", 15.0f)
+    box.Font <- new System.Drawing.Font("Calibri", 15.0f)
+    cont.Controls.Add(block)
+
+    let update data =
+      box.Text <- string (run cls data)
+    let clear () = 
+      split.Panel2.Controls.Remove(cont)
+    updates.Add( (update, clear) ) 
+
+  /// Main loop
+  let mainLoop stock = async {
+    let! prices = downloadPrices (DateTime(2009, 1, 1)) stock
+    let blocks = prices |> Seq.windowed 30
+    let en = blocks.GetEnumerator()
+
+    while en.MoveNext() do
+      do! Async.Sleep(125)
+      for fn, _ in updates do fn en.Current
+
+      let lo = Seq.min (Seq.map snd en.Current)
+      let hi = Seq.max (Seq.map snd en.Current)
+      let diff = (hi - lo) / 6.0
+      chartArea.AxisY.Maximum <- ceil (hi + diff)
+      chartArea.AxisY.Minimum <- floor (lo - diff)
+      ds.SetData(Array.map snd en.Current)  } 
+
+  member x.Run(stock) =
+    let cts = new CancellationTokenSource()
+    x.Closing.Add(fun _ -> cts.Cancel())
+    tok := cts
+    Async.StartImmediate(mainLoop stock, cts.Token)
+
+  member x.Add(name, cls) =
+    addBoolClassifier name cls
+
+  member x.Add(name, cls) =
+    addFloatClassifier name cls
+
+  member x.Clear() = 
+    for _, clean in updates do clean ()
+    updates.Clear() 
+
+  member x.Stop() = 
+    (!tok).Cancel()
+
+  member x.Chart = chart

2015_03_26_Tomas_Petricek_Domain_Specific_Languages_FSharp/Functional3D/1 Samples.fsx

@@ -0,0 +1,162 @@
+#r "references/OpenTK.dll"
+#r "references/OpenTK.GLControl.dll"
+#load "functional3d.fs"
+
+open Functional3D
+open System.Drawing
+
+// ------------------------------------------------------------------
+
+( Fun.color Color.Yellow Fun.cylinder ) $
+( Fun.cone
+  |> Fun.color Color.Red 
+  |> Fun.translate (0.0, 0.0, -1.0) )
+
+// ------------------------------------------------------------------
+
+let tower x z = 
+  (Fun.cylinder
+     |> Fun.scale (1.0, 1.0, 3.0) 
+     |> Fun.translate (0.0, 0.0, 1.0)
+     |> Fun.color Color.DarkGoldenrod ) $ 
+  (Fun.cone 
+     |> Fun.scale (1.3, 1.3, 1.3) 
+     |> Fun.translate (0.0, 0.0, -1.0)
+     |> Fun.color Color.Red )
+  |> Fun.rotate (90.0, 0.0, 0.0)
+  |> Fun.translate (x, 0.5, z)
+
+// Create one tower
+tower 0.0 0.0
+
+// Now we can easily compose towers!
+tower -2.0 0.0 $ tower 2.0 0.0
+                                                                                                                                
+// ------------------------------------------------------------------
+
+let sizedCube height = 
+  Fun.cube 
+  |> Fun.scale (0.5, height, 1.0) 
+  |> Fun.translate (-0.5, height/2.0 - 1.0, 0.0)
+
+let twoCubes =
+  sizedCube 0.8 $ (sizedCube 1.0 |> Fun.translate (0.5, 0.0, 0.0))
+
+let block = 
+  [ for offset in -4.0 .. +4.0 ->
+      twoCubes |> Fun.translate (offset, 0.0, 0.0) ]
+  |> Seq.reduce ($)
+  |> Fun.scale (0.5, 2.0, 0.3)
+  |> Fun.color Color.DarkGray
+  
+// ------------------------------------------------------------------
+
+let wall offs rotate = 
+  let rotationArg = if rotate then (0.0, 90.0, 0.0) else (0.0, 0.0, 0.0)
+  let translationArg = if rotate then (offs, 0.0, 0.0) else (0.0, 0.0, offs)
+  block |> Fun.rotate rotationArg |> Fun.translate translationArg
+
+tower -2.0 -2.0 $ tower 2.0 -2.0 $ 
+  tower -2.0 2.0 $ tower 2.0 2.0 $
+  wall -2.0 true $ wall 2.0 true $
+  wall -2.0 false $ wall 2.0 false
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+// ------------------------------------------------------------------
+// Recursion 
+// ------------------------------------------------------------------
+
+let pattern = 
+  [| [| [| 1; 1; 1; |]; [| 1; 0; 1 |]; [| 1; 1; 1 |] |]
+     [| [| 1; 0; 1; |]; [| 0; 0; 0 |]; [| 1; 0; 1 |] |]
+     [| [| 1; 1; 1; |]; [| 1; 0; 1 |]; [| 1; 1; 1 |] |] |]
+  |> Array3D.fromCube
+
+let rec generate depth = 
+  [ for x in -1 .. 1 do
+    for y in -1 .. 1 do
+    for z in -1 .. 1 do
+      if pattern.[x, y, z] = 1 then 
+        let size = 3.0 ** float depth
+        let ofs = float x * size, float y * size, float z * size
+        let sub = if depth = 0 then Fun.cube
+                  else generate (depth - 1) 
+        yield Fun.translate ofs sub ]
+  |> List.reduce ($)
+  |> Fun.color Color.ForestGreen
+
+// Generate fractal with various level of detail
+  
+Fun.setDistance(-20.0)
+
+generate 0
+generate 1
+
+Fun.setDistance(-60.0)
+generate 2
+
+// ------------------------------------------------------------------
+// Trees are an example of recursive structure
+// ------------------------------------------------------------------
+
+let random = System.Random()
+
+let noise k x =
+  x + (k * x * (random.NextDouble() - 0.5))
+
+let color() = 
+  [| Color.Red; Color.Orange; 
+     Color.Yellow |].[random.Next 3]
+
+let trunk (width,length) = 
+  Fun.cylinder
+  |> Fun.translate (0.0,0.0,0.5) |> Fun.scale (width,width,length)  
+        
+let fruit (size) = 
+  Fun.sphere
+  |> Fun.color (color()) |> Fun.scale (size,size,size)
+
+let example = trunk (1.0,5.0) $ fruit 2.0
+
+
+// Recursive tree
+let rec tree trunkLength trunkWidth w n = 
+  let moveToEndOfTrunk = Fun.translate (0.0,0.0,trunkLength)
+  if n <= 1 then
+    trunk (trunkWidth,trunkLength) $  // branch and end with
+    (fruit (3.0 * trunkWidth) |> moveToEndOfTrunk)  // fruit
+  else 
+    // generate branch
+    let branch angleX angleY = 
+      let branchLength = trunkLength * 0.92 |> noise 0.2  // reduce length
+      let branchWidth  = trunkWidth  * 0.65 |> noise 0.2  // reduce width
+      tree branchLength branchWidth w (n-1) 
+      |> Fun.rotate (angleX,angleY,0.0) |> moveToEndOfTrunk
+      
+    trunk (trunkWidth,trunkLength)  // branch and follow by several
+      $ branch  w  0.0              // smaller branches with rotation +/- w
+      $ branch -w  0.0
+      $ branch 0.0   w
+      $ branch 0.0  -w
+
+let plant = 
+  tree 4.0(*long*) 0.8(*wide*) 40.0(*angle*) 4(*levels*)
+  |> Fun.rotate (90.0, 180.0, 90.0)
+  |> Fun.translate (0.0, -6.0, 0.0)
+
+
+Fun.resetRotation()

2015_03_26_Tomas_Petricek_Domain_Specific_Languages_FSharp/Functional3D/2 Puzzle.fsx

@@ -0,0 +1,152 @@
+#r "references/OpenTK.dll"
+#r "references/OpenTK.GLControl.dll"
+#load "functional3d.fs"
+
+open Functional3D
+open System.Drawing
+
+// ------------------------------------------------------------------
+// Modelling the puzzle
+// ------------------------------------------------------------------
+
+type Color = Black | White
+type Kind = Straight | Turn
+type Part = Color * Kind
+
+type Position = int * int * int
+type Direction = int * int * int
+
+type Shape = list<Part>
+
+// ------------------------------------------------------------------
+// Implementing the algorithm
+// ------------------------------------------------------------------
+
+/// 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 ]
+
+// ------------------------------------------------------------------
+// Checking valid moves
+// ------------------------------------------------------------------
+
+/// 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
+
+/// 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
+
+// ------------------------------------------------------------------
+// Generating moves
+// ------------------------------------------------------------------
+
+/// 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 ]
+
+/// 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)
+      () }
+
+// ------------------------------------------------------------------
+// Solving the puzzle
+// ------------------------------------------------------------------
+
+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
+
+// 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)
+
+// ------------------------------------------------------------------
+// Building 3D visualization
+// ------------------------------------------------------------------
+
+/// 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 =
+  solution 
+  |> Seq.take i
+  |> Seq.map (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 coloured small cube & move it 
+      Fun.cube
+      |> Fun.scale (0.95,0.95,0.95)
+      |> Fun.color color
+      |> Fun.translate (fl p) )
+  |> Seq.reduce ($)
+
+
+Async.StartImmediate <| async { 
+  for i in 1 .. 64 do 
+    do! Async.Sleep(200)
+    Fun.show (draw i) }

2015_03_26_Tomas_Petricek_Domain_Specific_Languages_FSharp/Functional3D/app.config

@@ -0,0 +1,11 @@
+<?xml version="1.0" encoding="utf-8"?>
+<configuration>
+  <runtime>
+    <assemblyBinding xmlns="urn:schemas-microsoft-com:asm.v1">
+      <dependentAssembly>
+        <assemblyIdentity name="OpenTK" publicKeyToken="bad199fe84eb3df4" culture="neutral" />
+        <bindingRedirect oldVersion="0.0.0.0-1.0.0.0" newVersion="1.0.0.0" />
+      </dependentAssembly>
+    </assemblyBinding>
+  </runtime>
+</configuration>

2015_03_26_Tomas_Petricek_Domain_Specific_Languages_FSharp/Functional3D/functional3d.fs

@@ -0,0 +1,425 @@
+// --------------------------------------------------------------------------------------
+// Composable functional 3D graphics library for education
+// --------------------------------------------------------------------------------------
+// (c) Tomas Petricek (tomas@tomasp.net)
+// Distributed under the open-source MS-PL license
+// --------------------------------------------------------------------------------------
+
+module Functional3D
+
+open System
+open System.Drawing
+open System.Windows.Forms
+open System.Collections.Generic
+
+open OpenTK
+open OpenTK.Graphics
+open OpenTK.Graphics.OpenGL
+open OpenTK.Input
+
+// --------------------------------------------------------------------------------------
+// Representing 3D objects
+// --------------------------------------------------------------------------------------
+
+/// Represents the context of the drawing (mainly color at the moment)    
+type Drawing3DContext = 
+  { Color : Color4 }
+
+/// 3D object is represented as a function that draws it
+type Drawing3D = DF of (Drawing3DContext -> unit)
+
+// --------------------------------------------------------------------------------------
+// Drawing form used to display the OpenGL content
+// (supports rotations and zooming, works in F# interactive)
+// --------------------------------------------------------------------------------------
+ 
+type DrawingForm(?drawing:Drawing3D) as x =
+  inherit Form(ClientSize=Size(800, 600), Text="Functional 3D Drawing") 
+
+  let mutable drawing = defaultArg drawing (DF ignore)
+  let mutable lighting = (fun () ->
+    GL.Light(LightName.Light0, LightParameter.Ambient, [| 0.2f; 0.2f; 0.2f; 1.0f |])
+    GL.Light(LightName.Light0, LightParameter.Diffuse, [| 1.0f; 1.0f; 1.0f; 1.0f |])
+    GL.Light(LightName.Light0, LightParameter.Specular, [| 1.0f; 1.0f; 1.0f; 1.0f |])
+    GL.Light(LightName.Light0, LightParameter.Position, [| 1.0f; 1.0f; 1.0f; 0.0f |])
+    GL.Enable(EnableCap.Light0)
+    GL.Enable(EnableCap.Lighting) )
+
+  // ----------------------------------------------------------------------------------
+
+  let mutable cameraDistance = -10.0
+  let mutable currentAngles = [| 0.0; 0.0; 0.0 |]
+  let mutable currentSpeeds = [| 0.0; 0.0; 0.0 |]
+  let loaded = ref false
+
+  // ----------------------------------------------------------------------------------
+
+  let glControl = new GLControl(Dock = DockStyle.Fill)
+
+  let redrawWindow() = 
+    GL.Clear(ClearBufferMask.ColorBufferBit ||| ClearBufferMask.DepthBufferBit)
+    GL.MatrixMode(MatrixMode.Modelview)
+    
+    GL.LoadIdentity()
+    GL.Enable(EnableCap.Normalize) // scaling issue
+        
+    lighting()
+    GL.Translate(0., 0., cameraDistance)
+    GL.Rotate(30., 1., 0., 0.)
+        
+    GL.Rotate(currentAngles.[0], 1.0, 0.0, 0.0)
+    GL.Rotate(currentAngles.[1], 0.0, 1.0, 0.0)
+    GL.Rotate(currentAngles.[2], 0.0, 0.0, 1.0)
+
+    let clr = Color.DarkOliveGreen
+    let conv n = float32 n / 255.0f
+    let ctx = { Color = Color4(conv clr.R, conv clr.G, conv clr.B, conv clr.A) }
+    let (DF f) = drawing
+
+    GL.ShadeModel(ShadingModel.Smooth)
+    f(ctx)
+
+    glControl.SwapBuffers()
+  
+  let setupViewPort() = 
+    let w, h = glControl.ClientSize.Width, glControl.ClientSize.Height
+    GL.Viewport(0, 0, w, h)
+    let ratio = float32 w / float32 h
+    let mutable persp = Matrix4.CreatePerspectiveFieldOfView(float32 Math.PI / 4.0f, ratio, 1.0f, 64.0f)
+    GL.MatrixMode(MatrixMode.Projection)
+    GL.LoadMatrix(&persp)
+    
+  // ----------------------------------------------------------------------------------
+  // Interaction and event handling - repeatedly refresh the form
+  // and implement zooming & rotation using win forms events
+  
+  do 
+    let rec timer() = async { 
+      do! Async.Sleep(10)
+      x.Invoke(Action(fun () ->
+        for i in 0 .. 2 do 
+          currentAngles.[i] <- currentAngles.[i] + currentSpeeds.[i] 
+        x.Refresh() )) |> ignore
+      return! timer() }
+      
+    x.Controls.Add(glControl)
+    x.Load.Add(fun _ -> 
+      loaded := true
+      GL.ClearColor(Color.FromArgb(220, 225, 205))  
+      GL.Enable(EnableCap.DepthTest)
+      timer() |> Async.Start
+      x.Resize.Add(fun _ -> setupViewPort())
+      setupViewPort()  )
+    
+    glControl.KeyPress 
+      |> Event.add (fun ke ->
+          match ke.KeyChar with
+          | '-' | '_' -> x.CameraDistance <- x.CameraDistance - 1.0
+          | '+' | '=' -> x.CameraDistance <- x.CameraDistance + 1.0 
+          | _ -> () )
+
+    glControl.KeyPress 
+      |> Event.choose (fun ke ->
+          match ke.KeyChar with
+          | 'q' | 'Q' -> Some(0, -0.1)
+          | 'w' | 'W' -> Some(0, 0.1)
+          | 'a' | 'A' -> Some(1, -0.1)
+          | 's' | 'S' -> Some(1, 0.1)
+          | 'z' | 'Z' -> Some(2, -0.1)
+          | 'x' | 'X' -> Some(2, 0.1)
+          | _ -> None )
+      |> Event.add (fun (idx, ofs) ->
+          currentSpeeds.[idx] <- currentSpeeds.[idx] + ofs )
+          
+    glControl.Paint.Add(fun _ ->
+      if !loaded then  redrawWindow() )
+
+  // ----------------------------------------------------------------------------------
+  // Properties used to set displayed object & view properties
+    
+  member x.Drawing 
+    with get() = drawing 
+    and set(v) = 
+      drawing <- v
+      glControl.Refresh()
+      
+  member x.Lighting 
+    with set(v) = 
+      lighting <- v
+      glControl.Refresh()
+      
+  member x.CameraDistance 
+    with get() = cameraDistance 
+    and set(v) = 
+      cameraDistance <- v
+      glControl.Refresh()
+      
+  member x.ResetRotation() = 
+    currentAngles <- [| 0.0; 0.0; 0.0 |]
+    currentSpeeds <- [| 0.0; 0.0; 0.0 |]
+    glControl.Refresh()
+
+// --------------------------------------------------------------------------------------
+// Helper functions and extension methods
+// --------------------------------------------------------------------------------------
+
+module Array3D = 
+  /// Creates a 3D array from cube (represented as nested arrays)
+  /// The resulting array has indices from -x/2 to x/2
+  let fromCube (data:int[][][]) =
+    let length = Seq.length data
+    let b = -length/2;
+    let res = Array.CreateInstance(typeof<int>, [| length; length; length |], [| b; b; b |])
+    data |> Seq.iteri (fun x data -> 
+      data |> Seq.iteri (fun y data -> 
+        data |> Seq.iteri (fun z v -> 
+          res.SetValue(v, [| x+b; y+b; z+b |]) )))
+    (res :?> int[,,])
+
+type GLEx = 
+  /// Add multiple vertices to GL
+  static member Vertices vertices = 
+    for (x:float32), y, z in vertices do
+      GL.Vertex3(x, y, z)
+
+  /// Add mesh to the GL and set the specified normal vector first
+  static member Face (x:float32, y, z) vertices = 
+    GL.Normal3(x, y, z)
+    GLEx.Vertices vertices
+       
+// --------------------------------------------------------------------------------------
+// Representing and constructing 3D objects
+// --------------------------------------------------------------------------------------
+
+/// Composes two 3D objects by drawing both of them
+let ($) (DF a) (DF b) = DF (fun ctx -> 
+  a(ctx)
+  b(ctx) )
+
+module Fun = 
+  /// A constant that specifies the number of triangles in sphere or a cylinder
+  let mutable quality = 40
+
+  // ------------------------------------------------------------------------------------
+  // Operations for composing and modifying 3D objects
+
+  /// Scale the specified 3D object by the specified scales along the 3 axes
+  let scale (x:float, y, z) (DF f) = DF (fun ctx ->
+    GL.Scale(x, y, z)
+    f(ctx)
+    GL.Scale(1.0/x, 1.0/y, 1.0/z) )
+  
+  /// Scale the specified 3D object by the specified scales along the 3 axes
+  let rotate (x:float, y, z) (DF f) = DF (fun ctx ->
+    GL.Rotate(x, 1.0, 0.0, 0.0)
+    GL.Rotate(y, 0.0, 1.0, 0.0)
+    GL.Rotate(z, 0.0, 0.0, 1.0)
+    f(ctx)
+    GL.Rotate(-x, 1.0, 0.0, 0.0)
+    GL.Rotate(-y, 0.0, 1.0, 0.0)
+    GL.Rotate(-z, 0.0, 0.0, 1.0) )
+  
+  /// Move the specified object by the provided offsets
+  let translate (x:float, y:float, z:float) (DF f) = DF (fun ctx ->
+    GL.Translate(Vector3(float32 x, float32 y, float32 z))
+    f(ctx)
+    GL.Translate(Vector3(float32 -x, float32 -y, float32 -z)) )
+  
+  /// Set color to be used when drawing the specified 3D objects
+  let color (clr:Color) (DF f) = DF ( fun ctx -> 
+    let conv n = float32 n / 255.0f
+    f { ctx with Color = Color4(conv clr.R, conv clr.G, conv clr.B, conv clr.A) })
+
+
+  // ------------------------------------------------------------------------------------
+  // Primitive 3D objects 
+
+  /// Creates an empty 3D object that doesn't show anything
+  let empty = DF ignore
+
+  /// Creates a 3D cube of unit size using the current color
+  let cube = DF (fun ctx ->
+    GL.Material(MaterialFace.FrontAndBack, MaterialParameter.Diffuse, ctx.Color)
+    GL.Begin(BeginMode.Quads)
+    GLEx.Face 
+      (-1.f, 0.f, 0.f) 
+      [ (-0.5f, -0.5f, -0.5f); (-0.5f, -0.5f,  0.5f); 
+        (-0.5f,  0.5f,  0.5f);  (-0.5f,  0.5f, -0.5f) ] 
+    GLEx.Face 
+      ( 1.f, 0.f, 0.f)
+      [ ( 0.5f, -0.5f, -0.5f); ( 0.5f, -0.5f,  0.5f);
+        ( 0.5f,  0.5f,  0.5f); ( 0.5f,  0.5f, -0.5f) ]
+    GLEx.Face 
+      (0.f, -1.f, 0.f)
+      [ (-0.5f, -0.5f, -0.5f); (-0.5f, -0.5f,  0.5f);
+        ( 0.5f, -0.5f,  0.5f); ( 0.5f, -0.5f, -0.5f) ]
+    GLEx.Face 
+      (0.f, 1.f, 0.f)
+      [ (-0.5f,  0.5f, -0.5f); (-0.5f,  0.5f,  0.5f);
+        ( 0.5f,  0.5f,  0.5f); ( 0.5f,  0.5f, -0.5f) ]
+    GLEx.Face 
+      (0.f, 0.f, -1.f)
+      [ (-0.5f, -0.5f, -0.5f); (-0.5f,  0.5f, -0.5f);
+        ( 0.5f,  0.5f, -0.5f); ( 0.5f, -0.5f, -0.5f) ]
+    GLEx.Face 
+      (0.f, 0.f, 1.f)
+      [ (-0.5f, -0.5f,  0.5f); (-0.5f,  0.5f,  0.5f);
+        ( 0.5f,  0.5f,  0.5f); ( 0.5f, -0.5f,  0.5f) ]
+    GL.End() )
+  
+  
+  /// Generates a 3D cylinder object of a unit size
+  let cylinder = DF (fun ctx ->
+    GL.Material(MaterialFace.FrontAndBack, MaterialParameter.Diffuse, ctx.Color)
+    GL.Begin(BeginMode.Triangles)
+    
+    // points that will be used for generating the circle
+    let q = float32 (Math.PI / (float quality / 2.0))
+    let circlePoints = 
+      [ for i in 0 .. quality -> 
+          sin(float32 i * q) * 0.5f, cos(float32 i * q) * 0.5f ]
+                   
+    // generate 3D points that form the coordinates of the circle
+    let borderCirlces = 
+      [| for hy in [-0.5f; 0.5f] -> 
+           [| for (x, y) in circlePoints -> Vector3(x, y, hy) |] |]
+  
+    // generate triangles forming the cylinder
+    for i in 0 .. quality - 1 do
+      // First triangle of the rounded part
+      GL.Normal3 (borderCirlces.[0].[i].X, borderCirlces.[0].[i].Y, 0.0f)
+      GL.Vertex3  borderCirlces.[0].[i]
+      GL.Normal3 (borderCirlces.[0].[i+1].X, borderCirlces.[0].[i+1].Y, 0.0f)
+      GL.Vertex3  borderCirlces.[0].[i+1]
+      GL.Vertex3  borderCirlces.[1].[i+1]
+      
+      // Second triangle of the rounded part
+      GL.Vertex3  borderCirlces.[1].[i+1]
+      GL.Normal3 (borderCirlces.[0].[i].X, borderCirlces.[0].[i].Y, 0.0f)
+      GL.Vertex3  borderCirlces.[1].[i]
+      GL.Vertex3  borderCirlces.[0].[i]
+  
+      // Triangle to form the lower side
+      GL.Normal3 (0.0, 0.0, -1.0)
+      GL.Vertex3 borderCirlces.[0].[i]
+      GL.Vertex3 borderCirlces.[0].[i+1]
+      GL.Vertex3 (0.0, 0.0, -0.5)
+      
+      // Triangle to form the upper side
+      GL.Normal3 (0.0, 0.0, 1.0)
+      GL.Vertex3 borderCirlces.[1].[i+1]
+      GL.Vertex3 borderCirlces.[1].[i]
+      GL.Vertex3 (0.0, 0.0, 0.5)
+    GL.End() )
+    
+  /// Creates a 3D sphere with unit size
+  let sphere = DF (fun ctx ->
+    GL.Material(MaterialFace.FrontAndBack, MaterialParameter.Diffuse, ctx.Color)
+    GL.Begin(BeginMode.Triangles)
+  
+    // points that will be used for generating the circle
+    let q = float32 (Math.PI / (float quality / 2.0))
+    let circlePoints = 
+      [ for i in 0 .. quality -> 
+          sin(float32 i * q) * 0.5f, cos(float32 i * q) * 0.5f ]
+  
+    // points from the top to the bottom
+    let heightPoints = 
+      [ for i in 0 .. quality -> 
+          sin(float32 i * q) * 0.5f, cos(float32 i * q) * 0.5f ]
+    
+    // Array (along one dimension) of circles 
+    let points = 
+      [| for hx, hy in heightPoints ->
+           [| for x, y in circlePoints -> 
+                Vector3(x * hx * 2.0f, y * hx * 2.0f, hy) |] |]
+  
+    /// Generate the sphere 
+    for lat in 0 .. quality - 1 do
+      for i in 0 .. quality - 1 do
+        GL.Normal3 points.[lat].[i]
+        GL.Vertex3 points.[lat].[i]
+        GL.Normal3 points.[lat].[i+1]
+        GL.Vertex3 points.[lat].[i+1]
+        GL.Normal3 points.[lat+1].[i+1]
+        GL.Vertex3 points.[lat+1].[i+1]
+  
+        GL.Normal3 points.[lat+1].[i+1]
+        GL.Vertex3 points.[lat+1].[i+1]
+        GL.Normal3 points.[lat+1].[i]
+        GL.Vertex3 points.[lat+1].[i]
+        GL.Normal3 points.[lat].[i]
+        GL.Vertex3 points.[lat].[i]
+    GL.End() )
+  
+  
+  /// Generates a 3D cylinder object of a unit size
+  let cone = DF (fun ctx ->
+    GL.Material(MaterialFace.FrontAndBack, MaterialParameter.Diffuse, ctx.Color)
+    GL.Begin(BeginMode.Triangles)
+    
+    // points that will be used for generating the circle
+    let q = float32 (Math.PI / (float quality / 2.0))
+    let circlePoints = 
+      [| for i in 0 .. quality -> 
+           Vector3(sin(float32 i * q) * 0.5f, cos(float32 i * q) * 0.5f, 0.5f) |]
+                   
+    // generate triangles forming the cylinder
+    for i in 0 .. quality - 1 do
+      // First triangle of the rounded part
+      GL.Normal3 (circlePoints.[i].X, circlePoints.[i].Y, -0.25f)
+      GL.Vertex3 circlePoints.[i]
+      GL.Normal3 (circlePoints.[i+1].X, circlePoints.[i+1].Y, -0.25f)
+      GL.Vertex3 circlePoints.[i + 1]
+      GL.Normal3 (circlePoints.[i].X + circlePoints.[i+1].X / 2.0f, circlePoints.[i].Y + circlePoints.[i+1].Y / 2.0f, -0.25f)
+      GL.Vertex3 (0.0, 0.0, -0.5)
+  
+      /// Triangle to form the lower side
+      GL.Normal3 (0.0, 0.0, 1.0)
+      GL.Vertex3 circlePoints.[i]
+      GL.Vertex3 circlePoints.[i + 1]
+      GL.Vertex3 (0.0, 0.0, 0.5)
+    GL.End() )
+    
+  // --------------------------------------------------------------------------------------
+  // Provide easy way of displaying 3D objects
+
+  let private createForm() = 
+    lazy (new DrawingForm(Visible = false))
+    
+  let mutable private lazyForm = createForm()
+  
+  /// Returns the currently displayed form
+  let getForm() = lazyForm.Value
+  
+  /// Gets the distance of camera from the object
+  let getDistance() = lazyForm.Value.CameraDistance
+  /// Sets the distance of camera from the object
+  let setDistance(v) = lazyForm.Value.CameraDistance <- v
+  
+  /// Resets the rotation properties of the view
+  let resetRotation() =
+    lazyForm.Value.ResetRotation()
+    
+  /// Display the specified 3D object on a form
+  let show drawing = 
+    if lazyForm.Value.IsDisposed then
+      lazyForm <- createForm()
+    lazyForm.Value.Drawing <- drawing
+    lazyForm.Value.Visible <- true
+
+#if INTERACTIVE
+do
+  fsi.AddPrinter(fun (d:Drawing3D) ->
+    Fun.show d
+    "(Displayed 3D object)" )
+#endif
+
+module FunEx = 
+  let init() =  
+    use control = new Control()
+    let hWnd = control.Handle
+    use windowInfo = OpenTK.Platform.Utilities.CreateWindowsWindowInfo( hWnd )
+    use context = new GraphicsContext( GraphicsMode.Default, windowInfo )
+    context.MakeCurrent( windowInfo )
+    context.LoadAll()

2015_03_26_Tomas_Petricek_Domain_Specific_Languages_FSharp/Markdown/1 Formatting.fsx

@@ -0,0 +1,33 @@
+open System
+open System.Windows.Forms
+
+// -------------------------------------------------------
+// Show HTML
+// -------------------------------------------------------
+
+let wb = new WebBrowser(Dock=DockStyle.Fill)
+let frm = new Form(Width=800, Height=600, Visible=true)
+frm.Controls.Add(wb)
+let showHtml html = 
+  wb.DocumentText <- "<html><body style='font:150% calibri'>" + html + "</body></html>"
+
+// -------------------------------------------------------
+// Formatting
+// -------------------------------------------------------
+
+let heading n text = 
+  sprintf "<h%d>%s</h%d>" n text n
+let strong text = 
+  sprintf "<strong>%s</strong>" text
+let p text = 
+  sprintf "<p>%s</p>" text
+let list items =
+  let lis = [ for i in items -> sprintf "<li>%s</li>" i ]
+  "<ul>" + (String.concat "" lis) + "</ul>"
+
+(heading 1 "Creating DSLs with F#") + 
+(p "Key components of a DSL:") + 
+(list [
+  (strong "Model") + " describes the structure of the domain that we are modelling";
+  (strong "Syntax") + " provides an easy way for solving problems using the DSL" ])
+|> showHtml

2015_03_26_Tomas_Petricek_Domain_Specific_Languages_FSharp/Markdown/2 Processing.fsx

@@ -0,0 +1,121 @@
+open System
+open System.Windows.Forms
+
+// -------------------------------------------------------
+// Show HTML
+// -------------------------------------------------------
+
+let wb = new WebBrowser(Dock=DockStyle.Fill)
+let frm = new Form(Width=800, Height=600, Visible=true)
+frm.Controls.Add(wb)
+let showHtml html = 
+  wb.DocumentText <- """<html><style>body {padding:30px;font:150% cabin}
+    li {margin-top:10px}</style><body>""" + html + "</body></html>"
+
+// -------------------------------------------------------
+// Domain model
+// -------------------------------------------------------
+
+type MarkdownNode = 
+  | Literal of string
+  | Strong of MarkdownNode 
+  | Paragraph of MarkdownNode 
+  | Heading of int * MarkdownNode 
+  | List of MarkdownNode list
+  | Sequence of MarkdownNode list
+
+// -------------------------------------------------------
+// Formatting
+// -------------------------------------------------------
+
+let rec formatNode = function
+  | Literal s -> s
+  | Strong s -> sprintf "<strong>%s</strong> " (formatNode s)
+  | Paragraph p -> formatNode p
+  | Heading(n, p) -> sprintf "<h%d>%s</h%d>" n (formatNode p) n
+  | List items -> 
+      let lis = [ for li in items -> sprintf "<li>%s</li>" (formatNode li) ]
+      "<ul>" + (String.concat "" lis) + "</ul>"
+  | Sequence nodes -> nodes |> List.map formatNode |> String.concat ""
+
+// -------------------------------------------------------
+// Sample document
+// -------------------------------------------------------
+
+let doc =
+  Sequence 
+    [ Heading(1, Literal "Creating DSLs with F#")
+      Paragraph(Literal "Key components of a DSL:")
+      List(
+        [ Sequence
+            [ Strong (Literal "Model")
+              Literal " describes the structure of the domain that we are modelling"]
+          Sequence 
+            [ Strong (Literal "Syntax")
+              Literal " provides an easy way for solving problems using the DSL" ]
+      ]) ]
+
+doc
+|> formatNode
+|> showHtml
+
+// -------------------------------------------------------
+// Building nicer syntax
+// -------------------------------------------------------
+
+let (!) s = Literal s
+let ($) s1 s2 = Sequence [s1;s2]
+
+let doc2 =
+  Heading(1, !"Creating DSLs with F#") $
+  Paragraph(!"Key components of a DSL:") $
+  List(
+    [ Strong (!"Model") $
+        Literal " describes the structure of the domain that we are modelling"
+      Strong (!"Syntax") $
+        Literal " provides an easy way for solving problems using the DSL" ])
+
+doc2
+|> formatNode
+|> showHtml
+
+// -------------------------------------------------------
+// Translating documents
+// -------------------------------------------------------
+
+#r "../packages/FSharp.Data.2.0.8/lib/net40/FSharp.Data.dll"
+open FSharp.Data
+
+[<Literal>]
+let Sample = "http://mymemory.translated.net/api/get?q=hello&langpair=en%7Cno"
+
+// Request sample translation
+Http.Request(Sample).Body
+
+// Generate types for translation API
+type Translate = JsonProvider<Sample>
+
+let translate (phrase:string) = 
+  printfn "Translating: '%s'" phrase
+  if String.IsNullOrWhiteSpace(phrase) then "" else
+  let phrase = phrase.Replace("F#", "fsharp")
+  let doc = Translate.Load("http://mymemory.translated.net/api/get?langpair=en|no&de=tomas@tomasp.net&q=" + phrase)
+  let phrase = doc.Matches.[0].Translation
+  phrase.Replace("fsharp", "F#")
+
+translate "world"
+translate "describes the structure of the domain that we are modelling"
+
+// Recursive function to translate documents
+let rec translateNode = function
+  | Literal text -> Literal (translate text)
+  | Strong s -> Strong(translateNode s)
+  | Heading(n, s) -> Heading(n, translateNode s)
+  | List li -> List (List.map translateNode li)
+  | Paragraph p -> Paragraph(translateNode p)
+  | Sequence p -> Sequence (List.map translateNode p)
+
+doc
+|> translateNode
+|> formatNode
+|> showHtml

2015_03_26_Tomas_Petricek_Domain_Specific_Languages_FSharp/Markdown/3 Parsing.fsx

@@ -0,0 +1,226 @@
+open System
+open System.Windows.Forms
+
+// -------------------------------------------------------
+// Show HTML
+// -------------------------------------------------------
+
+let wb = new WebBrowser(Dock=DockStyle.Fill)
+let frm = new Form(Width=800, Height=600, Visible=true)
+frm.Controls.Add(wb)
+let showHtml html = 
+  wb.DocumentText <- """<html><style>body {padding:30px;font:150% cabin}
+    li {margin-top:10px}</style><body>""" + html + "</body></html>"
+
+// -------------------------------------------------------
+// Domain model
+// -------------------------------------------------------
+
+type MarkdownNode = 
+  | Literal of string
+  | Strong of MarkdownNode 
+  | Paragraph of MarkdownNode 
+  | Heading of int * MarkdownNode 
+  | List of MarkdownNode list
+  | Sequence of MarkdownNode list
+
+// -------------------------------------------------------
+// Formatting
+// -------------------------------------------------------
+
+let rec formatNode = function
+  | Literal s -> s
+  | Strong s -> sprintf "<strong>%s</strong> " (formatNode s)
+  | Paragraph p -> formatNode p
+  | Heading(n, p) -> sprintf "<h%d>%s</h%d>" n (formatNode p) n
+  | List items -> 
+      let lis = [ for li in items -> sprintf "<li>%s</li>" (formatNode li) ]
+      "<ul>" + (String.concat "" lis) + "</ul>"
+  | Sequence nodes -> nodes |> List.map formatNode |> String.concat ""
+ 
+// -------------------------------------------------------
+// Translating documents
+// -------------------------------------------------------
+
+#r "../packages/FSharp.Data.2.0.8/lib/net40/FSharp.Data.dll"
+open FSharp.Data
+
+[<Literal>]
+let Sample = "http://mymemory.translated.net/api/get?q=hello&langpair=en%7Cno"
+
+// Generate types for translation API
+type Translate = JsonProvider<Sample>
+
+let translate (phrase:string) = 
+  printfn "Translating: '%s'" phrase
+  if String.IsNullOrWhiteSpace(phrase) then "" else
+  let phrase = phrase.Replace("F#", "fsharp")
+  let doc = Translate.Load("http://mymemory.translated.net/api/get?langpair=en|no&de=tomas@tomasp.net&q=" + phrase)
+  let phrase = doc.Matches.[0].Translation
+  phrase.Replace("fsharp", "F#")
+
+// Recursive function to translate documents
+let rec translateNode = function
+  | Literal text -> Literal (translate text)
+  | Strong s -> Strong(translateNode s)
+  | Heading(n, s) -> Heading(n, translateNode s)
+  | List li -> List (List.map translateNode li)
+  | Paragraph p -> Paragraph(translateNode p)
+  | Sequence p -> Sequence (List.map translateNode p)
+
+// -------------------------------------------------------
+// Active patterns for parsing
+// -------------------------------------------------------
+
+let toString chars =
+  System.String(chars |> Array.ofList)
+
+let (|StartsWith|_|) prefix list =
+  let rec loop = function
+    | [], rest -> Some(rest)
+    | p::prefix, r::rest when p = r -> loop (prefix, rest)
+    | _ -> None
+  loop (prefix, list)
+
+let rec parseBracketedBody closing acc = function
+  | StartsWith closing (rest) -> Some(List.rev acc, rest)
+  | c::chars -> parseBracketedBody closing (c::acc) chars
+  | _ -> None
+  
+let (|Delimited|_|) delim = function
+  | StartsWith delim chars -> parseBracketedBody delim [] chars
+  | _ -> None
+
+// -------------------------------------------------------
+// Parsing spans
+// -------------------------------------------------------
+  
+let rec parseSpans acc chars = seq {
+  let emitLiteral() = seq {
+    if acc <> [] then 
+      yield acc |> List.rev |> toString |> Literal }
+  match chars with
+  | Delimited ['*'; '*' ] (body, chars) ->
+      yield! emitLiteral ()
+      yield Strong(Sequence(parseSpans [] body |> List.ofSeq))
+      yield! parseSpans [] chars
+  | c::chars ->
+      yield! parseSpans (c::acc) chars
+  | [] ->
+      yield! emitLiteral () }
+
+// -------------------------------------------------------
+// Helper functions & patterns
+// -------------------------------------------------------
+
+module List = 
+  let partitionWhile f = 
+    let rec loop acc = function
+      | x::xs when f x -> loop (x::acc) xs
+      | xs -> List.rev acc, xs
+    loop [] 
+
+let (|LineSeparated|) lines =
+  let isWhite = System.String.IsNullOrWhiteSpace
+  match lines |> List.partitionWhile (isWhite >> not) with
+  | par, _::rest | par, ([] as rest) -> par, rest
+    
+let (|AsCharList|) (str:string) = 
+  str |> List.ofSeq
+
+let (|PrefixedLines|) prefix (lines:list<string>) = 
+  let prefixed, other = lines |> List.partitionWhile (fun line -> line.StartsWith(prefix))
+  [ for line in prefixed -> line.Substring(prefix.Length) ], other
+
+// -------------------------------------------------------
+// Parsing Markdown blocks
+// -------------------------------------------------------
+
+let rec parseBlocks lines = seq {
+  match lines with
+  | AsCharList(StartsWith ['#'; ' '] heading)::rest ->
+      yield Heading(1, Sequence(parseSpans [] heading |> List.ofSeq))
+      yield! parseBlocks rest
+  | LineSeparated (h::tl, rest) when h.StartsWith(" *") -> 
+      let body = String.concat " " (h.Substring(2)::tl) |> List.ofSeq
+      let list, rest = 
+        parseBlocks rest |> List.ofSeq
+        |> List.partitionWhile (function List _ -> true | _ -> false)
+      yield List [
+        yield Sequence(parseSpans [] body |> List.ofSeq)
+        for List l in list do yield! l ]
+      yield! rest 
+  | LineSeparated (body, rest) when body <> [] -> 
+      let body = String.concat " " body |> List.ofSeq
+      yield Paragraph(Sequence(parseSpans [] body |> List.ofSeq))
+      yield! parseBlocks rest 
+  | line::rest when System.String.IsNullOrWhiteSpace(line) ->
+      yield! parseBlocks rest 
+  | _ -> () }
+
+let parseMarkdown (sample:string) = 
+  Sequence(parseBlocks (sample.Split('\r', '\n') |> List.ofSeq) |> List.ofSeq)
+
+// -------------------------------------------------------
+// Samples
+// -------------------------------------------------------
+
+let sample = """
+# Creating DSLs with F#
+
+Key components of a DSL:
+
+ * **Model** describes the 
+   structure of the domain 
+   that we are modelling
+
+ * **Syntax** provides an easy 
+   way for solving problems 
+   using the DSL
+"""
+
+sample
+|> parseMarkdown
+|> translateNode
+|> formatNode
+|> showHtml
+
+
+let oslo = """
+# Buildings and structures
+
+Architecture in Oslo may at first seem dull. Unlike for 
+instance its Swedish counterpart, Stockholm, downtown Oslo 
+has only scattered monumental buildings where in particular 
+the Parliament-Palace axis (upper part of Karl Johan Street) 
+has a certain Parisian grandeur. The charm of Oslo can also 
+be found in the affluent inner-city suburbs of for instance 
+Frogner and Fagerborg as well as above St.Hanshaugen park. 
+
+ * **Royal Palace** - Tours inside the palace are arranged 
+   in summertime, this year from June 21. The tickets for the 
+   tour must be bought in advance from a post office. 
+
+ * **University in Oslo** - The building is currently only 
+   housing the Faculty of Law, the rest of the university is 
+   situated at Blindern. Occasional concerts will be arranged in 
+   the magnificent Universitetets Aula, housing 11 of Edvard 
+   Munch's pictures. 
+
+ * **Opera House** - Norway's first entry into the top league 
+   of modern architecture. Awarded the 2008 prize for best 
+   cultural building at the World Architecture Festival in Barcelona, 
+   and the prestigious Mies van der Rohe award for best European 
+   contemporary architecture in 2009, its appearance is stunning. 
+"""
+
+
+let res = 
+  oslo
+  |> parseMarkdown
+  |> translateNode
+
+res
+|> formatNode
+|> showHtml
+

2015_03_26_Tomas_Petricek_Domain_Specific_Languages_FSharp/Samples.sln

@@ -0,0 +1,26 @@
+
+Microsoft Visual Studio Solution File, Format Version 12.00
+# Visual Studio 2012
+Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "3 Classifiers", "3 Classifiers", "{9020E4E5-A368-477D-9DD8-98D97AF8C71C}"
+	ProjectSection(SolutionItems) = preProject
+		Classifiers\1 Pricing.fsx = Classifiers\1 Pricing.fsx
+	EndProjectSection
+EndProject
+Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "1 Functional 3D", "1 Functional 3D", "{97B3B763-2B9B-4A47-9BD7-0729E13D3CE4}"
+	ProjectSection(SolutionItems) = preProject
+		Functional3D\1 Samples.fsx = Functional3D\1 Samples.fsx
+		Functional3D\2 Puzzle.fsx = Functional3D\2 Puzzle.fsx
+	EndProjectSection
+EndProject
+Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "2 Markdown", "2 Markdown", "{B2BC6183-675E-483E-96CF-A140404903AF}"
+	ProjectSection(SolutionItems) = preProject
+		Markdown\1 Formatting.fsx = Markdown\1 Formatting.fsx
+		Markdown\2 Processing.fsx = Markdown\2 Processing.fsx
+		Markdown\3 Parsing.fsx = Markdown\3 Parsing.fsx
+	EndProjectSection
+EndProject
+Global
+	GlobalSection(SolutionProperties) = preSolution
+		HideSolutionNode = FALSE
+	EndGlobalSection
+EndGlobal

2015_03_26_Tomas_Petricek_Domain_Specific_Languages_FSharp/packages.config

@@ -0,0 +1,4 @@
+<?xml version="1.0" encoding="utf-8"?>
+<packages>
+  <package id="FSharp.Data" version="2.0.8" targetFramework="net40-Client" />
+</packages>