Learning WPF with F# - TreeView and ListView

Working through Chapter 16 of Petzold's bookApplications = Code + Markup: A Guide to the Microsoft Windows Presentation Foundation.

The most interesting effort in working through these examples is converting the repeated if statements in the implementation of Convert method in MetadataToFlags to use zip,filter,map and combine. The column definitions in DependencyPropertyListView has also been refactored to define all the definitions in a list and iterate through the list to create each GridViewColumn.

ManuallyPopulateTreeView
#light 
#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0"
#r @"WindowsBase.dll"
#r @"PresentationCore.dll"
#r @"PresentationFramework.dll"

open System
open System.Windows
open System.Windows.Controls
open System.Windows.Input
open System.Windows.Media 
//
// From Chapter 16 - ManuallyPopulateTreeView
//
//----------------------------------------------------------

let addSubItems items (branch:TreeViewItem) = items |> Seq.iter (fun item -> 
    item |> branch.Items.Add |> ignore)

let tree = new TreeView()

tree.Items.Add
   (let animalBranch = new TreeViewItem(Header="Animal")

    animalBranch.Items.Add
       (let branch = new TreeViewItem(Header="Dog")
        let dogs = ["Poodle";"Irish Setter";"German Shepherd"]
        addSubItems dogs branch
        branch) |>ignore

    animalBranch.Items.Add
       (let branch = new TreeViewItem(Header="Cat")
        branch.Items.Add(new TreeViewItem(Header="Alley Cat")) |>ignore
        branch.Items.Add(new Button(Content="Noodles")) |>ignore
        branch.Items.Add("Siamese") |>ignore
        branch) |> ignore

    animalBranch.Items.Add
       (let branch = new TreeViewItem(Header="Primate")
        let primates = ["Chimpanzee";"Bonobo";"Human"]
        addSubItems primates branch
        branch) |> ignore
    animalBranch) |> ignore
      
tree.Items.Add
   (let branch = new TreeViewItem(Header="Mineral")
    let minerals = ["Calcium";"Zinc";"Iron"]
    addSubItems minerals branch
    branch) |> ignore

tree.Items.Add
   (let branch = new TreeViewItem(Header="Vegetable")
    let vegetables = ["Carrot";"Asparagus";"Broccoli"]
    addSubItems vegetables branch
    branch) |> ignore
   
let window = new Window(Title="Manually Populate TreeView",
                        Content=tree)
    

#if COMPILED
[<STAThread()>]
do 
    let app =  Application() in
    app.Run(window) |> ignore
#endif

RecurseDirectoriesInefficiently
#light 
#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0"
#r @"WindowsBase.dll"
#r @"PresentationCore.dll"
#r @"PresentationFramework.dll"

open System
open System.IO
open System.Windows
open System.Windows.Controls
open System.Windows.Input
open System.Windows.Media 
//
// From Chapter 16 - RecurseDirectoriesInefficiently
//
//----------------------------------------------------------

let rec GetSubDir (item:TreeViewItem) = 
    let dir = item.Tag :?> DirectoryInfo
    try
       dir.GetDirectories() |> Seq.iter (fun subdir ->
          let subitem = new TreeViewItem(Header=subdir.Name,Tag=subdir)
          subitem |> item.Items.Add |> ignore
          // recursively obtain subdirectories
          subitem |> GetSubDir)
    with _ -> ()

let tree = new TreeView()

tree.Items.Add
   (let item = new TreeViewItem(Header = Path.GetPathRoot(Environment.SystemDirectory))
    item.Tag <- new DirectoryInfo(item.Header :?> string)
    GetSubDir item
    item)|>ignore
 
   
let window = new Window(Title="Recurse Directories Inefficiently",
                        Content=tree)


#if COMPILED
[<STAThread()>]
do 
    let app =  Application() in
    app.Run(window) |> ignore
#endif

RecurseDirectoriesIncrementally
#light 
#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0"
#r @"WindowsBase.dll"
#r @"PresentationCore.dll"
#r @"PresentationFramework.dll"

open System
open System.IO
open System.Windows
open System.Windows.Controls
open System.Windows.Input
open System.Windows.Media 
open System.Windows.Media.Imaging
//----------------------------------------------------------
// From Chapter 16 – RecurseDirectoriesIncrementally
//----------------------------------------------------------
let selectedImage = new BitmapImage(new Uri("file:///icons/OPENFOLD.BMP"))
let unselectedImage  = new BitmapImage(new Uri("file:///icons/CLSDFOLD.BMP"))
let cddriveImage  = new BitmapImage(new Uri("file:///icons/CDDRIVE.BMP"))
let driveImage  = new BitmapImage(new Uri("file:///icons/DRIVE.BMP"))
let floppyImage  = new BitmapImage(new Uri("file:///icons/35FLOPPY.BMP"))

//
// From Chapter 16 – ImagedTreeViewItem
//
type ImagedTreeViewItem() = class
   inherit TreeViewItem() as base

   let stack = new StackPanel(Orientation=Orientation.Horizontal)
   let img = new Image(VerticalAlignment = VerticalAlignment.Center,
                       Margin = new Thickness(0.0, 0.0, 2.0, 0.0))
   let text = new TextBlock(VerticalAlignment = VerticalAlignment.Center)
   let mutable srcSelected:ImageSource = null
   let mutable srcUnselected:ImageSource = null
   
   do
      base.Header <- stack
      img |> stack.Children.Add |> ignore
      text |> stack.Children.Add |> ignore
   
   member this.Text
      with get() = text.Text
      and set value =
         text.Text <- value

   member this.SelectedImage
      with get() = srcSelected
      and set value = 
         srcSelected <- value
         if (this.IsSelected) then img.Source <- srcSelected

   member this.UnselectedImage
      with get() = srcUnselected
      and set value = 
         srcUnselected <- value
         if (this.IsSelected=false) then img.Source <- srcUnselected

   override this.OnSelected (args:RoutedEventArgs ) =
      base.OnSelected(args)
      img.Source <- selectedImage      

   override this.OnUnselected (args:RoutedEventArgs ) =
      base.OnUnselected(args)
      img.Source <- unselectedImage      
         
end   

//
// From Chapter 16 – DirectoryTreeViewItem
//
type DirectoryTreeViewItem = class
   inherit ImagedTreeViewItem as base
   
   val mutable dir:DirectoryInfo
   
   new (rootdir:DirectoryInfo) as this = {dir=rootdir} then
      base.Text <- this.dir.Name
   
   member this.DirectoryInfo 
      with get() = this.dir
      
   member this.Populate () =
      try
         this.dir.GetDirectories() 
         |> Seq.iter (fun child -> 
            new DirectoryTreeViewItem(child) 
            |> this.Items.Add |> ignore)
         
      with _ -> ()

   override this.OnExpanded (args:RoutedEventArgs) =
      base.OnExpanded(args)
       
      this.Items |> Seq.untyped_to_typed 
      |> Seq.iter (fun (item:DirectoryTreeViewItem) ->
         item.Populate())
   
end

//
// From Chapter 16 – DirectoryTreeView
//
type DirectoryTreeView()  = class
   inherit TreeView()  as base
     
   member this.RefreshTree() =
      this.BeginInit()
      this.Items.Clear()
      
      DriveInfo.GetDrives() |> Seq.iter (fun (drive:DriveInfo) ->
         let chDrive = String.get (drive.Name|> String.capitalize) 0
         let item = new DirectoryTreeViewItem(drive.RootDirectory)
         if (chDrive <> 'A' && chDrive <> 'B' && drive.IsReady && drive.VolumeLabel.Length > 0) then
            item.Text <- String.Format("{0} ({1})",drive.VolumeLabel,drive.Name)
         else
            item.Text <- String.Format("{0} ({1})",drive.DriveType,drive.Name)
            
         if (chDrive = 'A' || chDrive = 'B') then
            item.SelectedImage <- floppyImage
            item.UnselectedImage <- floppyImage
         else if (drive.DriveType = DriveType.CDRom) then
            item.SelectedImage <- cddriveImage
            item.UnselectedImage <- cddriveImage
         else
            item.SelectedImage <- driveImage
            item.UnselectedImage <- driveImage

         //item.Selected.Add(fun _ -> ())      
         
         item |> this.Items.Add |> ignore
         if (chDrive <> 'A' && chDrive <> 'B' && drive.IsReady) then
           item.Populate()
         this.EndInit()
      )
end   


//
// From Chapter 16 – RecurseDirectoriesIncrementally
//
let tree = new DirectoryTreeView()
tree.RefreshTree()
let stack = new StackPanel()

tree.SelectedItemChanged.Add(fun args ->
   let item = args.NewValue :?> DirectoryTreeViewItem
   stack.Children.Clear()
   
   try
      item.DirectoryInfo.GetFiles() |> Seq.iter (fun info ->
         let text = new TextBlock(Text=info.Name)
         text |> stack.Children.Add |> ignore)
   with _ -> ()
)

let grid = new Grid()

[new ColumnDefinition(Width=new GridLength(50.0, GridUnitType.Star));
 new ColumnDefinition(Width=GridLength.Auto);
 new ColumnDefinition(Width=new GridLength(50.0, GridUnitType.Star))]
|> List.iter  grid.ColumnDefinitions.Add

tree |> grid.Children.Add
Grid.SetColumn(tree,0)

let split = new GridSplitter(Width=6.0,
                             ResizeBehavior = GridResizeBehavior.PreviousAndNext)
split |> grid.Children.Add
Grid.SetColumn(split,1)

let scroll = new ScrollViewer(Content = stack)
scroll |> grid.Children.Add
Grid.SetColumn(scroll,2)
   
let window = new Window(Title="Recurse Directories Incrementally",
                        Content=grid)

#if COMPILED
[<STAThread()>]
do 
    let app =  Application() in
    app.Run(window) |> ignore
#endif

TemplateTheTree & DiskDirectory
#light 
#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0"
#r @"WindowsBase.dll"
#r @"PresentationCore.dll"
#r @"PresentationFramework.dll"

open System
open System.IO
open System.Windows
open System.Windows.Controls
open System.Windows.Data
open System.Windows.Input
open System.Windows.Media 
open System.Windows.Media.Imaging
//
// From Chapter 16 – TemplateTheTree & DiskDirectory
//
//----------------------------------------------------------

type DiskDirectory = class
   
   val mutable dirinfo:DirectoryInfo
   
   new (rootdir:DirectoryInfo) as this = {dirinfo=rootdir} 
   
   member this.Name 
      with get() = this.dirinfo
      
   member this.Subdirectories 
      with get() =
         let dirs = new ResizeArray<DiskDirectory>()
         try
            this.dirinfo.GetDirectories() |> Seq.iter (fun subdir ->
               dirs.Add(new DiskDirectory(subdir)))
         with _ -> ()
         dirs

   
end

let treevue = new TreeView()
   
let window = new Window(Title="Template the Tree",
                        Content=treevue)

let template = new HierarchicalDataTemplate(typeof<DiskDirectory>)
template.ItemsSource <- new Binding("Subdirectories")
let factoryTextBlock = new FrameworkElementFactory(typeof<TextBlock>)

(TextBlock.TextProperty, new Binding("Name"))
   |> factoryTextBlock.SetBinding

template.VisualTree <- factoryTextBlock

let dir = new DiskDirectory(new DirectoryInfo(Path.GetPathRoot(Environment.SystemDirectory)))

treevue.Items.Add 
   (let item = new TreeViewItem(Header=dir.Name,
                                IsExpanded=true,
                                ItemsSource=dir.Subdirectories,
                                ItemTemplate=template)
   item)

#if COMPILED
[<STAThread()>]
do 
    let app =  Application() in
    app.Run(window) |> ignore
#endif

ShowClassHierarchy
#light 
#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0"
#r @"WindowsBase.dll"
#r @"PresentationCore.dll"
#r @"PresentationFramework.dll"

open System
open System.Collections.Generic
open System.Reflection
open System.Windows
open System.Windows.Controls
//
// From Chapter 16 - ShowClassHierarchy
//
//----------------------------------------------------------

type TypeTreeViewItem = class
   inherit TreeViewItem as base
   
   val mutable mytype:Type
   
   new () as this = {mytype=null}
   
   member this.Type 
      with get() = this.mytype
      and set (value:Type) =
         this.mytype <- value
         if (this.mytype.IsAbstract) then
            base.Header <- (this.mytype.Name + " (abstract)")
         else
            base.Header <- this.mytype.Name

         
end

type ClassHierarchyTreeView = class
   inherit TreeView as base

   new (typeRoot:Type) as this = {} then
      let dummy = new UIElement()
      let assemblies = new ResizeArray<Assembly>()
      Assembly.GetExecutingAssembly().GetReferencedAssemblies() 
        |> Seq.iter (fun name -> assemblies.Add(Assembly.Load(name)))
      let classes = new SortedList<string,Type>()
      classes.Add(typeRoot.Name,typeRoot)
      
      assemblies |> Seq.iter (fun assembly ->
         assembly.GetTypes() |> Seq.iter (fun t ->
            if (t.IsPublic && t.IsSubclassOf(typeRoot)) then
               classes.Add(t.Name,t)))
      
      // create root item
      let item = new TypeTreeViewItem(Type=typeRoot) 
      item |> this.Items.Add |> ignore
      
      // Add recursively
      this.CreateLinkedItems item classes
               
      

   member this.CreateLinkedItems (itemBase:TypeTreeViewItem) (list:SortedList<string,Type>) =
      list |> Seq.iter (fun keypair ->
         if (keypair.Value.BaseType = itemBase.Type) then
            let item = new TypeTreeViewItem(Type=keypair.Value)
            itemBase.Items.Add(item) |> ignore
            this.CreateLinkedItems item list
         )
      
end    

let treevue = new ClassHierarchyTreeView(typeof<System.Windows.Threading.DispatcherObject>)
   
let window = new Window(Title="Show Class Hierarchy",
                        Content=treevue)


#if COMPILED
[<STAThread()>]
do 
    let app =  Application() in
    app.Run(window) |> ignore
#endif

ListSystemParameters
#light 
#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0"
#r @"WindowsBase.dll"
#r @"PresentationCore.dll"
#r @"PresentationFramework.dll"

open System
open System.Collections.Generic
open System.ComponentModel
open System.Reflection
open System.Windows
open System.Windows.Controls
open System.Windows.Data
open System.Windows.Input
open System.Windows.Media
//
// From Chapter 16 - ListSystemParameters
//
//----------------------------------------------------------
type SystemParam() = class
   let mutable strName=""
   let mutable objvalue = null
   
   member this.Name 
      with get() = strName
      and set (value:string) = strName <- value

   member this.Value 
      with get() = objvalue
      and set (value:obj) = objvalue <- value

   override this.ToString() =
      this.Name + "=" + this.Value.ToString()
end


let grdvue = new GridView()
let lstvue = new ListView(View=grdvue)

// Create two GridView columns.
new GridViewColumn(Header="Property Name",
                   Width=200.0,
                   DisplayMemberBinding = new Binding("Name"))
   |> grdvue.Columns.Add                    

new GridViewColumn(Header="Value",
                   Width=200.0,
                   DisplayMemberBinding = new Binding("Value"))
   |> grdvue.Columns.Add                    


typeof<SystemParameters>.GetProperties() |> Seq.iter (fun prop ->
   if (prop.PropertyType <> typeof<ResourceKey>) then
      new SystemParam(Name=prop.Name,
                      Value = prop.GetValue(null,null))
         |> lstvue.Items.Add |> ignore
   )
                             
let window = new Window(Title="List System Parameters",
                        Content=lstvue)


#if COMPILED
[<STAThread()>]
do 
    let app =  Application() in
    app.Run(window) |> ignore
#endif

ListSortedSystemParameters
#light 
#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0"
#r @"WindowsBase.dll"
#r @"PresentationCore.dll"
#r @"PresentationFramework.dll"

open System
open System.Collections.Generic
open System.ComponentModel
open System.Reflection
open System.Windows
open System.Windows.Controls
open System.Windows.Data
open System.Windows.Input
open System.Windows.Media
//
// From Chapter 16 - ListSortedSystemParameters
//
//----------------------------------------------------------
type SystemParam() = class
   let mutable strName=""
   let mutable objvalue = null
   
   member this.Name 
      with get() = strName
      and set (value:string) = strName <- value

   member this.Value 
      with get() = objvalue
      and set (value:obj) = objvalue <- value

   override this.ToString() =
      this.Name + "=" + this.Value.ToString()
end


let grdvue = new GridView()
let lstvue = new ListView(View=grdvue)

// Create two GridView columns.
new GridViewColumn(Header="Property Name",
                   Width=200.0,
                   DisplayMemberBinding = new Binding("Name"))
   |> grdvue.Columns.Add                    

   
// Create DataTemplate for second column
let template = new DataTemplate(typeof<string>)
let factoryTextBlock = new FrameworkElementFactory(typeof<TextBlock>)  
(TextBlock.HorizontalAlignmentProperty, HorizontalAlignment.Right)
   |> factoryTextBlock.SetValue

(TextBlock.TextProperty,new Binding("Value"))
  |> factoryTextBlock.SetBinding

template.VisualTree <- factoryTextBlock
  
new GridViewColumn(Header="Value",
                   Width=200.0,
                   CellTemplate=template,
                   DisplayMemberBinding = new Binding("Value"))
   |> grdvue.Columns.Add

let sortlist = new SortedList<string,SystemParam>()

typeof<SystemParameters>.GetProperties() |> Seq.iter (fun prop ->
   if (prop.PropertyType <> typeof<ResourceKey>) then
      (prop.Name,
       new SystemParam(Name=prop.Name,
                       Value = prop.GetValue(null,null)))
       |> sortlist.Add
   )
lstvue.ItemsSource <- sortlist.Values   
                             
let window = new Window(Title="List Sorted  System Parameters",
                        Content=lstvue)


#if COMPILED
[<STAThread()>]
do 
    let app =  Application() in
    app.Run(window) |> ignore
#endif

ExploreDependencyProperties
#light 
#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0"
#r @"WindowsBase.dll"
#r @"PresentationCore.dll"
#r @"PresentationFramework.dll"
#r @"classhierarchytreeview.dll"

open System
open System.Collections.Generic
open System.ComponentModel
open System.Globalization
open System.Reflection
open System.Windows
open System.Windows.Controls
open System.Windows.Data
open Chapter16  // for ClassHierarchyTreeView
//
// From Chapter 16 - ExploreDependencyProperties
//
//----------------------------------------------------------
type TypeToString() =
   interface IValueConverter with
      member v.Convert (o:obj,t:Type,param:obj,culture:CultureInfo) = 
         (o :?> Type).Name :> obj 
         
      member v.ConvertBack (o:obj,t:Type,param:obj,culture:CultureInfo) = null


type MetadataToFlags() =
   interface IValueConverter with
      member v.Convert (o:obj,t:Type,param:obj,culture:CultureInfo) = 
         // Need to wrap with try/with for those objects that
         // only can cast downto PropertyMetadata
         try
           let metadata = o :?> FrameworkPropertyMetadata
         
           let checks = [metadata.AffectsMeasure;
                         metadata.AffectsArrange;
                         metadata.AffectsParentMeasure;
                         metadata.AffectsParentArrange;
                         metadata.AffectsRender;
                         metadata.Inherits;
                         metadata.OverridesInheritanceBehavior;
                         metadata.IsNotDataBindable;
                         metadata.BindsTwoWayByDefault;
                         metadata.Journal]
                           
           let options = [FrameworkPropertyMetadataOptions.AffectsMeasure;
                          FrameworkPropertyMetadataOptions.AffectsArrange;
                          FrameworkPropertyMetadataOptions.AffectsParentMeasure;
                          FrameworkPropertyMetadataOptions.AffectsParentArrange;
                          FrameworkPropertyMetadataOptions.AffectsRender;
                          FrameworkPropertyMetadataOptions.Inherits;
                          FrameworkPropertyMetadataOptions.OverridesInheritanceBehavior;
                          FrameworkPropertyMetadataOptions.NotDataBindable;
                          FrameworkPropertyMetadataOptions.BindsTwoWayByDefault;
                          FrameworkPropertyMetadataOptions.Journal;]
                        
         // Instead of a bunch of if statements, I replaced it with
         // zip, filter, map and combine...                        
           let flags = 
              Seq.zip checks options  
              |> Seq.filter (fun (check,option) -> check)
              |> Seq.map (fun (check,option) -> option)
              |> Seq.to_list
              |> Enum.combine

           flags :> obj
         with _ -> 
            FrameworkPropertyMetadataOptions.None :> obj
         
         
      member v.ConvertBack (o:obj,t:Type,param:obj,culture:CultureInfo) =
         let options = o :?> FrameworkPropertyMetadataOptions
         new FrameworkPropertyMetadata(null,options) :> obj


let mutable private initTypeProperty : DependencyProperty = null

type DependencyPropertyListView () = class
   inherit ListView() as base

   do
      let grdvue = new GridView()
      base.View <- grdvue

      let buildTemplate (bind:Binding) converter  = 
         let elTextBlock =new FrameworkElementFactory(typeof<TextBlock>)
         let template = new DataTemplate(VisualTree=elTextBlock)
         bind.Converter <- converter
         (TextBlock.TextProperty,bind) |> elTextBlock.SetBinding
         template
      

      let ownerTemplate = buildTemplate (new Binding("OwnerType")) (new TypeToString())         
      let flagsTemplate = buildTemplate (new Binding("DefaultMetadata")) (new MetadataToFlags())         

      let coldefs =
         [("Name",Some("Name"),None,150.0);
          ("Owner",None,Some(ownerTemplate),150.0);
          ("Default",Some("DefaultMetadata.DefaultValue"),None,75.0);
          ("Read-Only",Some("DefaultMetadata.ReadOnly"),None,75.0);
          ("Usage",Some("DefaultMetadata.AttachedPropertyUsage"),None,75.0);
          ("Flags",None,Some(flagsTemplate),250.0);]
      
      coldefs |> Seq.iter (fun (header,bindingOption,templateOption,width) ->
          match bindingOption with
            | Some binding -> 
               new GridViewColumn(Header=header,
                                  DisplayMemberBinding = new Binding(binding),
                                  Width=width) 
               |> grdvue.Columns.Add
            
            | None -> ()
            
          match templateOption with
            | Some template -> 
               new GridViewColumn(Header=header,
                                  CellTemplate = template,
                                  Width=width) 
               |> grdvue.Columns.Add
            | None -> ())         

   static member TypeProperty =
      if initTypeProperty = null then
         let metadata = 
            new PropertyMetadata(null, new PropertyChangedCallback(DependencyPropertyListView.OnTypePropertyChanged))

         initTypeProperty <-
            DependencyProperty.Register
               ("Type",
                typeof<Type>,
                typeof<DependencyPropertyListView>,
                metadata)

      initTypeProperty   

   static member OnTypePropertyChanged (obj:DependencyObject) (args:DependencyPropertyChangedEventArgs) =
      let lstvue = obj :?> DependencyPropertyListView
      let t = args.NewValue :?> Type
      lstvue.ItemsSource <- null
      if t <> null then
         let list = new SortedList<string,DependencyProperty>()
         t.GetFields() |> Seq.iter (fun info ->
            if info.FieldType = typeof<DependencyProperty> then
               (info.Name,(info.GetValue(null) :?> DependencyProperty))
               |> list.Add)
         lstvue.ItemsSource <- list.Values

   member this.Type
      with get() =
         let value = this.GetValue(DependencyPropertyListView.TypeProperty)
         (value :?> DependencyProperty)
      and set (value:DependencyProperty) = this.SetValue(DependencyPropertyListView.TypeProperty,value)
      
end


let treevue = new Chapter16.ClassHierarchyTreeView(typeof<DependencyObject>)
let grid = new Grid()

// create 3 column definitions for Grid
[new GridLength(1.0,GridUnitType.Star);
 GridLength.Auto;
 new GridLength(3.0,GridUnitType.Star)] 
 |> Seq.iter (fun width ->
    new ColumnDefinition(Width=width) |> grid.ColumnDefinitions.Add)
    
treevue |> grid.Children.Add
Grid.SetColumn(treevue,0)

let split = new GridSplitter(HorizontalAlignment = HorizontalAlignment.Center,
                             VerticalAlignment = VerticalAlignment.Stretch,
                             Width = 6.0)
split |> grid.Children.Add
Grid.SetColumn(split,1)
                             
let lstvue = new DependencyPropertyListView(DataContext=treevue)
lstvue |> grid.Children.Add
Grid.SetColumn(lstvue,2)

(DependencyPropertyListView.TypeProperty, "SelectedItem.Type")
|> lstvue.SetBinding
    
let window = new Window(Title="Explore Dependency Properties",
                        Content=grid)


#if COMPILED
[<STAThread()>]
do 
    let app =  Application() in
    app.Run(window) |> ignore
#endif

Learning WPF with F# - Toolbars and Status Bars

I've been working through Chapter 15 of Petzold's book,Applications = Code + Markup: A Guide to the Microsoft Windows Presentation Foundation. FormatRichText is probably the largest and most complete example that I've written so far with F#. For that reason, I decided to logically organize the code into modules. According to the book Expert F#, a module is just a simple container for values and type definitions. While I did not physically separate the modules into different file, but there's no reason why it cannot be done.

For the most part, FormatRichText functions just like Petzold's C# version. However, example code looks significantly different than the C# version and may be more difficult to understand compared with the first WPF examples that I wrote. I can see that a C# developer probably would not have much of a problem with the first few WPF examples but may have more problems reading later examples. Does this make the code less readable? Probably to those who are just jumping into F# from C# but not, I think or hope, to those who are familiar with F#.

One final comment on the published example. I first implemented seqdrop function based on Haskell's drop function. Later, I ran a timing test against that implementation of seqdrop with the following implementation:

let seqdrop2 n list =
   Seq.to_list list 
   |> List.rev 
   |> List.to_seq 
   |> Seq.truncate n 
   |> Seq.to_list
   |> List.rev 
   |> List.to_seq

I erroneously thought this version of the drop would be slower because of all the list reversal. When I did a timing test with seqdrop and seqdrop2, seqdrop2 was a lot faster. Basically, running seqdrop on a list of 10000 integers on my machine took almost 9 seconds while it ran in 0.1 seconds with the second version. The lesson learned is always use F# standard library functions whenever possible.

Below are the example codes with the slow version of seqdrop implemented.

CraftTheToolbar
#light 
#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0"
#r @"WindowsBase.dll"
#r @"PresentationCore.dll"
#r @"PresentationFramework.dll"

open System
open System.Windows
open System.Windows.Controls
open System.Windows.Input
open System.Windows.Media 
open System.Windows.Media.Imaging
//
// From Chapter 15 - CraftTheToolbar
//
// Defining drop function...couldn't find a Seq equivalent
// I see Seq.take and Seq.truncate but no Seq.drop
let rec seqdrop n (list:seq<'a>) =
   if n<=0 then list
   else
      match (List.of_seq list) with 
      | _ :: [] -> seq []
      | _ :: t -> seqdrop (n-1) (List.to_seq t)
      | _ -> failwith "Error in seqdrop - never should get here"
// I think if F# has Haskell's type classes, I can avoid
// these awkward type conversion expressions such as (List.to_seq t)
      
   
let dock = new DockPanel(LastChildFill=false)
let window = new Window(Title="Craft the Toolbar",
                        Content=dock)
                        
let toolbar = new ToolBar()
dock.Children.Add(toolbar) |>ignore
DockPanel.SetDock(toolbar,Dock.Top)                        

let commands = 
   seq [ApplicationCommands.New; 
        ApplicationCommands.Open;
        ApplicationCommands.Save; 
        ApplicationCommands.Print;
        ApplicationCommands.Cut; 
        ApplicationCommands.Copy;
        ApplicationCommands.Paste; 
        ApplicationCommands.Delete]
    
let images = 
   seq ["new.gif"; "open.gif"; "save.gif";
        "print.gif"; "cut.gif"; "copy.gif";
        "paste.gif"; "delete.gif"]   
        
// Bind the commands outside toolbar creation
let show (msg:string) (label:string) = MessageBox.Show(msg,label) |>ignore        

commands |> Seq.iter (fun cmd ->
   new CommandBinding(cmd,(fun _ _  -> 
      show (cmd.Name + " command not yet implemented")  window.Title))
      |> window.CommandBindings.Add |>ignore)

// Create toolbar given the command and image file
let addToolbarButtons list =
   list |> Seq.iter (fun (cmd:RoutedUICommand,imgFile) ->
      let img = new Image(Stretch=Stretch.None)
      img.Source <- new BitmapImage(new Uri(@"file:///icons/" + imgFile))
      let tip = new ToolTip(Content=cmd.Text)
      let btn = new Button(Command=cmd,Content=img,ToolTip=tip)
      toolbar.Items.Add(btn) |>ignore)     

// Create a separator at the every nth element
let rec addToolbarButtonsWithSeparator list n=
   if (Seq.length list) > n then
      addToolbarButtons (Seq.take n list)
      toolbar.Items.Add(new Separator()) |>ignore
      addToolbarButtonsWithSeparator (seqdrop n list) n
   else
      addToolbarButtons list

// Create the toolbar with separators
let list = Seq.zip commands images
addToolbarButtonsWithSeparator list 4

#if COMPILED
[<STAThread()>]
do 
    let app =  Application() in
    app.Run(window) |> ignore
#endif
MoveTheToolbar
#light 
#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0"
#r @"WindowsBase.dll"
#r @"PresentationCore.dll"
#r @"PresentationFramework.dll"

open System
open System.Windows
open System.Windows.Controls
open System.Windows.Input
open System.Windows.Media 
//
// From Chapter 15 - MoveTheToolbar
//
         
let dock = new DockPanel(LastChildFill=false)
let window = new Window(Title="Move the Toolbar",
                        Content=dock)

let trayTop = new ToolBarTray()
dock.Children.Add(trayTop) |> ignore
DockPanel.SetDock(trayTop,Dock.Top)

let trayLeft = new ToolBarTray(Orientation = Orientation.Vertical)
dock.Children.Add(trayLeft) |> ignore
DockPanel.SetDock(trayLeft,Dock.Left)

dock.Children.Add(new TextBox())

// Create six toolbars
[1..6] |> Seq.iter (fun i ->
   let toolbar = new ToolBar(Header= "Toolbar " + Int32.to_string i)
   
   if i<4 then trayTop.ToolBars.Add(toolbar)
   else trayLeft.ToolBars.Add(toolbar)
   
   // Add six buttons to each toolbar
   [0..5] |> Seq.iter (fun j ->
      toolbar.Items.Add(new Button(FontSize=16.0,
                                   Content=(Char.chr (Char.code 'A' + j)))) 
      |>ignore
   )
   
)
                        

#if COMPILED
[<STAThread()>]
do 
    let app =  Application() in
    app.Run(window) |> ignore
#endif
FormatRichText (combined)
#light 
#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0"
#r @"WindowsBase.dll"
#r @"PresentationCore.dll"
#r @"PresentationFramework.dll"
#r @"selectcolorfromgrid.dll"  // Compiled from Chap13 example

open Microsoft.Win32
open System
open System.IO
open System.Windows
open System.Windows.Controls
open System.Windows.Controls.Primitives
open System.Windows.Documents
open System.Windows.Input
open System.Windows.Media 
open System.Windows.Media.Imaging
open System.Windows.Shapes
open System.Windows.Threading
open Chapter13;
//
// From Chapter 15 - FormatRichText (combined)
//
//----------------------------------------------------------

// Using this chapter as an opportunity to play around with F# packaging

// Defining some utilities functions...normally I should package this elsewhere
// Nullable utilities for F# - Copied from FLinq sample code
let (=?!) (x: Nullable<'a>) (y:'a) =
   x.HasValue && x.Value = y
   
// Defining drop function...I need this for adding toobar buttons with Separator
let rec seqdrop n (list:seq<'a>) =
   if n<=0 then list
   else
      match (List.of_seq list) with
      | _ :: [] -> seq []
      | _ :: t -> seqdrop (n-1) (List.to_seq t)
      | _ -> failwith "Error in seqdrop - never should get here"

//----------------------------------------------------------------------------
// This module could be physically packaged in a different file if desired.
//----------------------------------------------------------------------------
module Command =

   let fileFilter = 
      "XAML Document Files (*.xaml)|*.xaml|" +
      "XAML Package Files (*.zip)|*.zip|" +
      
      "Rich Text Format Files (*.rtf)|*.rtf|" +
      "Text Files (*.txt)|*.txt|" +
      "All files (*.*)|*.*"
      
   let formats = 
      seq [DataFormats.Xaml; DataFormats.XamlPackage; DataFormats.Rtf;
           DataFormats.Text; DataFormats.Text]

   // OnNew, OnOpen, OnSave - from FormatRichText.File.cs example     
   let OnNew (doc:FlowDocument)(win:Window) =
      let range =new TextRange(doc.ContentStart,doc.ContentEnd)
      range.Text <- ""
   
   let OnOpen (doc:FlowDocument) (win:Window) =
      let range = new TextRange(doc.ContentStart,doc.ContentEnd)
      let dlg = new OpenFileDialog(CheckFileExists=true,Filter=fileFilter)
      if (dlg.ShowDialog(win) =?! true) then
         try
            use strm = new FileStream(dlg.FileName,FileMode.Open)
            range.Load(strm,(Seq.nth dlg.FilterIndex formats))
         with e -> MessageBox.Show(e.Message,win.Title) |>ignore

   let OnSave (doc:FlowDocument) (win:Window) =
      let range = new TextRange(doc.ContentStart,doc.ContentEnd)
      let dlg = new OpenFileDialog(CheckFileExists=true,Filter=fileFilter)
      if (dlg.ShowDialog(win) =?! true) then
         try
            use strm = new FileStream(dlg.FileName,FileMode.Create)
            range.Save(strm, (Seq.nth dlg.FilterIndex formats))
         with e -> MessageBox.Show(e.Message,win.Title) |>ignore

   // CanDelete, OnOpenOnDelete  - from FormatRichText.Edit.cs example     
   let CanDelete (args:CanExecuteRoutedEventArgs) (rtbox:RichTextBox) =
      args.CanExecute  <- not rtbox.Selection.IsEmpty

   let OnDelete (args:ExecutedRoutedEventArgs) (rtbox:RichTextBox) =
      rtbox.Selection.Text <- ""

//----------------------------------------------------------------------------
// This module could be physically packaged in a different file if desired.
//----------------------------------------------------------------------------
module ToolbarFactory =

   // I'm not sure how to handle this.  Seems kind of ugly to
   // have this mutable variable out here.  The alternatives that I
   // can think of aren't any better.
   let mutable originalFontSize:String = "12"

   let addButtons (toolbar:ToolBar) list =
      list |> Seq.iter (fun (cmd:RoutedUICommand,imgFile) ->
         let bitmap = new BitmapImage(new Uri(@"file:///icons/" + imgFile))
         let img = new Image(Source=bitmap,Stretch=Stretch.None)
         let tip = new ToolTip(Content=cmd.Text)
         let btn = new Button(Command=cmd,Content=img,ToolTip=tip)
         ignore(toolbar.Items.Add(btn)))


   // Create a separator at the every nth element
   let rec addButtonsWithSeparator (toolbar:ToolBar) n list =
      if (Seq.length list) > n then
         addButtons toolbar (Seq.take n list) 
         toolbar.Items.Add(new Separator()) |>ignore
         addButtonsWithSeparator toolbar n (seqdrop n list)
      else
         addButtons toolbar list                         

   // Create command bindings

   // from FormatRichText.File.cs example     
   let createFileToolbar (doc:FlowDocument) (win:Window) =
      let commands = seq [ ApplicationCommands.New; ApplicationCommands.Open; ApplicationCommands.Save]
      let handlers = seq [new ExecutedRoutedEventHandler(fun _ _ -> Command.OnNew doc win);
                          new ExecutedRoutedEventHandler(fun _ _ -> Command.OnOpen doc win);
                          new ExecutedRoutedEventHandler(fun _ _ -> Command.OnSave doc win); ]
          
      let images = seq ["new.gif"; "open.gif"; "save.gif" ]
      let toolbar = new ToolBar()
   
      Seq.zip commands images |> addButtons toolbar
      
      // Add the command bindings
      let addBind cmd = ignore(win.CommandBindings.Add cmd)
      Seq.zip commands handlers |> Seq.iter (fun (cmd,handler) ->
         new CommandBinding(cmd,handler) |> addBind)
      
      toolbar
   
   // from FormatRichText.Edit.cs example  - create edit toolbar
   let createEditToolbar (text:RichTextBox) (win:Window) =
      let commands = seq [ ApplicationCommands.Cut; 
                           ApplicationCommands.Copy; 
                           ApplicationCommands.Paste; 
                           ApplicationCommands.Delete; 
                           ApplicationCommands.Undo; 
                           ApplicationCommands.Redo]
                           
      // Use option type to handle the exceptions                           
      let handlers = seq [None;None;None;
                          Some(((new ExecutedRoutedEventHandler(fun _ args -> 
                                   Command.OnDelete args text)),
                                (new CanExecuteRoutedEventHandler(fun _ args -> 
                                   Command.CanDelete args text))));
                          None; None]

      let images = seq ["cut.gif"; "copy.gif"; "paste.gif"; 
                        "delete.gif"; "undo.gif"; "redo.gif"; ]

      let toolbar = new ToolBar()
      Seq.zip commands images |> addButtonsWithSeparator toolbar 4
      
      // Add the command bindings
      let addBind cmd = ignore(win.CommandBindings.Add cmd)
      
      // exe - ExecutionRoutedEventHandler
      // can - CanExecuteRoutedEventHandler
      Seq.zip commands handlers |> Seq.iter (fun (cmd,optHandler) ->
         match optHandler with
         | Some((exe,can)) -> new CommandBinding(cmd,exe,can) |> addBind
         | None -> new CommandBinding(cmd) |> addBind)
      
      toolbar
      
   // from FormatRichText.Char.cs example     
   let createCharToolbar (text:RichTextBox) =
   
      // Some utility function so we can apply DRY principles
      
      // Utility code use to build toggle buttons for FontWeight & FontStyle
      let buildToggleButton tip image (property:DependencyProperty) checkedprop uncheckedprop =
          let tip = new ToolTip(Content="tip")
          let bitmap = new BitmapImage(new Uri(@"file:///icons/" + image))
          let img = new Image(Source=bitmap,Stretch=Stretch.None)
          let button = new ToggleButton(Content=img,ToolTip=tip)
          
          button.Checked.Add(fun args ->
             (property,checkedprop)  
             |> text.Selection.ApplyPropertyValue)

          button.Unchecked.Add(fun args ->
             (property,uncheckedprop)  
             |> text.Selection.ApplyPropertyValue)
             
          button 

      // Utility code use to build menu items for Foreground/Background color
      let buildColorMenuItems  tip image (property:DependencyProperty) =
          let tip = new ToolTip(Content="tip")
          let bitmap = new BitmapImage(new Uri(@"file:///icons/" + image))
          let img = new Image(Source=bitmap,Stretch=Stretch.None)
          let item = new MenuItem(Header=img,ToolTip=tip)
          let colorgrid = new ColorGridBox()
          colorgrid.SelectionChanged.Add(fun _ ->
             (property,colorgrid.SelectedValue)  
             |> text.Selection.ApplyPropertyValue)
             
          item.Items.Add(colorgrid) |> ignore
          item
   
      let toolbar = new ToolBar()

      // Create ComboBox for font families
      toolbar.Items.Add
         (let tip = new ToolTip(Content="Font Family")
          let combo =  new ComboBox(Width = 144.0,
                                    ItemsSource = Fonts.SystemFontFamilies,
                                    ToolTip = tip,
                                    SelectedItem = text.FontFamily)
          // Implement FamilyComboOnSelection - notice that
          // control properties and behavior are a define and not
          // separated in the code as in Petzold's example.
          combo.SelectionChanged.Add(fun args ->
             let family = combo.SelectedItem :?> FontFamily
             if (family <> null) then
                (FlowDocument.FontFamilyProperty,family)  
                |> text.Selection.ApplyPropertyValue
             text.Focus() |>ignore)
          combo)   |>ignore                              
 
      // Create ComboBox for font size
      toolbar.Items.Add
         (let fontsizes = seq [8.0; 9.0; 10.0; 11.0; 12.0; 14.0; 16.0; 18.0;
                               20.0; 22.0; 24.0; 26.0; 28.0; 36.0; 48.0; 72.0]
                               
          let tip = new ToolTip(Content="Font Size")
          let combo =  new ComboBox(Width = 48.0,
                                    ItemsSource = fontsizes,
                                    ToolTip = tip,
                                    IsEditable = true,
                                    IsReadOnly=false,
                                    Text = (text.FontSize).ToString())

          // Implement SizeComboOnSelection 
          combo.SelectionChanged.Add( fun args -> 
             if (combo.SelectedIndex <> -1) then
                let size = (combo.SelectedValue :?> double)
                text.Selection.ApplyPropertyValue(FlowDocument.FontSizeProperty, size) 
                originalFontSize <- Float.to_string size
             text.Focus() |>ignore)
             
          // Implement SizeComboOnGotFocus
          combo.GotKeyboardFocus.Add(fun _ -> 
             originalFontSize <- combo.Text)
          
          // Implement SizeComboOnLostFocus
          combo.LostKeyboardFocus.Add(fun _ -> 
             let (valid,size) = Double.TryParse(combo.Text)
             // Needed to add the addition filter (combo.SelectedIndex = -1)
             // or font size drop down doesn't work properly.
             if valid && (combo.SelectedIndex = -1) then
                text.Selection.ApplyPropertyValue (FlowDocument.FontSizeProperty,size)
             else 
                combo.Text <- originalFontSize
             )
          // Implement SizeComboOnKeyDown
          combo.PreviewKeyDown.Add(fun args -> 
             match args.Key with
                | Key.Escape -> 
                   combo.Text <- originalFontSize
                   args.Handled <- true
                   text.Focus() |> ignore
                | Key.Enter -> 
                   args.Handled <- true
                   text.Focus() |> ignore
                | _ -> ())

          combo)   |>ignore

          
      // Create Bold Button
      toolbar.Items.Add
         (let prop = FlowDocument.FontWeightProperty
          let bold = FontWeights.Bold
          let normal =FontWeights.Normal
          let button = buildToggleButton "Bold" "bold.png" prop bold normal
          // Petzold's original implementation with text.SelectionChanged 
          // didn't do anything,  I changed to using TextChanged event, 
          // which occurs when any content or format changes
          text.TextChanged.Add(fun _ ->
            let font = text.Selection.GetPropertyValue(FlowDocument.FontWeightProperty) 
                       :?> FontWeight
            button.IsChecked <-
               if font = FontWeights.Bold then 
                  new Nullable<bool>(true)
               else new Nullable<bool>(false)
          )
          button) |>ignore

      // Create Italic Button
      toolbar.Items.Add
        (let prop = FlowDocument.FontStyleProperty
         let italic = FontStyles.Italic
         let normal = FontStyles.Normal
         let button = buildToggleButton "Italic" "italic.png" prop italic normal
         text.TextChanged.Add(fun _ ->
            let style = text.Selection.GetPropertyValue(FlowDocument.FontStyleProperty)  
                        :?> FontStyle 
            button.IsChecked <-
               if style = FontStyles.Italic then 
                  new Nullable<bool>(true)
               else new Nullable<bool>(false)
         )
         
         button
         ) |>ignore

      // Create Background and Foreground Color Menus
      toolbar.Items.Add
         (let menu = new Menu()
          // Add background color menu
          let item = (buildColorMenuItems "Background Color" "bgcolor.png"  FlowDocument.BackgroundProperty)
          ignore(menu.Items.Add(item))
          // Add foreground color menu
          let item = (buildColorMenuItems "Foreground Color" "fgcolor.png"  FlowDocument.ForegroundProperty)
          ignore(menu.Items.Add(item))
          menu) |> ignore
      
      // Petzold also implemented a bunch of other RichTextBox Selection Changed events
      // I elected to skip those as I could not see how you can change those other properties
      // without going through the toolbar controls.  If you had separate menu controls, then
      // it would make sense to implement them.  In any case, the implementation for
      // FontStyle and FontWeight are illustrative examples of how to implement TextChanged
      // events.
      toolbar
 
  
   // from FormatRichText.Para.cs example     
   let createParagraphToolbar (text:RichTextBox) =

      let createbutton (align:TextAlignment) (btntip:string) (offsetLeft:float) (offsetRight:float) =
         let canv = new Canvas(Width=16.0,Height=16.0)
         
         [0..4] |> Seq.iter( fun i ->
            let poly = new Polyline(Stroke=SystemColors.WindowTextBrush,
                                    StrokeThickness = 1.0)
            match i with
               | 1 | 3 ->
                  poly.Points <- 
                     new PointCollection([|new Point (2.0+ offsetLeft,
                                                      2.0+3.0*Int32.to_float i);
                                           new Point (14.0+ offsetRight,
                                                      2.0+3.0*Int32.to_float i)|])
               | _ ->
                  poly.Points <- 
                     new PointCollection([|new Point (2.0,2.0+3.0*Int32.to_float i);
                                           new Point (14.0,2.0+3.0*Int32.to_float i)|])
            canv.Children.Add(poly)|>ignore)
         let tip = new ToolTip(Content=btntip)
         let btn = new ToggleButton(Tag=align,Content=canv,ToolTip=tip)
         
         // Checked the button when clicked on
         btn.Click.Add(fun args ->
             btn.IsChecked <- new Nullable<bool>(true)
             text.Selection.ApplyPropertyValue(Paragraph.TextAlignmentProperty,align))

         // Uncheck all the other text alignment buttons
         text.TextChanged.Add( fun _ ->           
            let checkAlignment = text.Selection.GetPropertyValue(Paragraph.TextAlignmentProperty) 
                                 :?> TextAlignment
            if align <> checkAlignment then 
               btn.IsChecked <- new Nullable<bool>(false))
         
         btn

      let toolbar = new ToolBar()     
      toolbar.Items.Add(createbutton TextAlignment.Left "Align Left" 0.0 4.0) |>ignore
      toolbar.Items.Add(createbutton TextAlignment.Center "" 2.0 2.0) |>ignore
      toolbar.Items.Add(createbutton TextAlignment.Right "Align Right" 4.0 0.0) |>ignore
      toolbar.Items.Add(createbutton TextAlignment.Justify "Justify" 0.0  0.0) |>ignore
      toolbar

   // Not really a toolbar - but packaging it under ToolbarFactory
   // From FormatRichText.Status.cs example
   let createStatusbar () =
      let status = new StatusBar()
      let itemDateTime = new StatusBarItem(HorizontalAlignment = HorizontalAlignment.Right)
      status.Items.Add(itemDateTime) |> ignore
      
      let tmr = new DispatcherTimer(Interval = TimeSpan.FromSeconds(1.0))
      tmr.Tick.Add( fun e ->
         let dt = DateTime.Now
         itemDateTime.Content <- dt.ToLongDateString() + " " + dt.ToLongTimeString())
         
      tmr.Start()
      
      status
      

//----------------------------------------------------------------------------
// Main section where we compose our WPF components
//----------------------------------------------------------------------------
         
let dock = new DockPanel(LastChildFill=false)
let window = new Window(Title="Format Rich Text",
                        Content=dock)

let tray = new ToolBarTray()
dock.Children.Add(tray) |> ignore
DockPanel.SetDock(tray,Dock.Top)

let txtbox = new RichTextBox (VerticalScrollBarVisibility = ScrollBarVisibility.Auto)
dock.Children.Add(txtbox)
   
// Create all the toolbars and add to ToolBarTray

// Add file toolbar
tray.ToolBars.Add
   (let toolbar = ToolbarFactory.createFileToolbar txtbox.Document window
    toolbar.Band <- 0
    toolbar.BandIndex <- 0
    toolbar)

// Add edit toolbar
tray.ToolBars.Add
   (let toolbar = ToolbarFactory.createEditToolbar txtbox window
    toolbar.Band <- 1
    toolbar.BandIndex <- 0
    toolbar)

// Add char toolbar
tray.ToolBars.Add
   (let toolbar = ToolbarFactory.createCharToolbar txtbox 
    toolbar.Band <- 2
    toolbar.BandIndex <- 1
    toolbar)

// Add paragraph toolbar
tray.ToolBars.Add
   (let toolbar = ToolbarFactory.createParagraphToolbar txtbox 
    toolbar.Band <- 2
    toolbar.BandIndex <- 0
    toolbar)
    
// Add Status Bar
let status = ToolbarFactory.createStatusbar()
dock.Children.Add(status) 
DockPanel.SetDock(status,Dock.Bottom)
    
   

#if COMPILED
[<STAThread()>]
do 
    let app =  Application() in
    app.Run(window) |> ignore
#endif