Skip to content

Instantly share code, notes, and snippets.

@cloudRoutine
Last active August 29, 2015 14:12
Show Gist options
  • Select an option

  • Save cloudRoutine/98f25f5d2a1a9c121930 to your computer and use it in GitHub Desktop.

Select an option

Save cloudRoutine/98f25f5d2a1a9c121930 to your computer and use it in GitHub Desktop.
Polymorphic WPF GUI Controls with F#
namespace ViewModels
open System.Windows
open System.Windows.Controls
open System.Windows.Documents
open System.Windows.Media
open GUIControls.Extensions
open GUIControls.Patterns
open System.Windows.Interactivity
/// <summary>
/// <para> A struct used to hold content for a Querylistbox </para>
/// <p> test of the 'p' tag </p>
/// </summary>
/// <param name="text"> The string displayed in the GUI </param>
[<Struct; StructuredFormatDisplay( "{Output}" )>]
type ListData (text:string, detail:string [], path:string) =
member __.Text = text
member __.Detail = detail
member __.Path = path
/// <summary>
/// Listbox consructor for display text that is not an alias for underlying
/// </summary>
/// <param name="text"> The string displayed in the GUI </param>
new( text ) = ListData( text, [||], text )
new( text, path ) = ListData( text, [||], path )
member internal x.Output =
let detail = sprintf "%A" x.Detail
"Text : " + x.Text + " \n" +
"Path : " + x.Path + " \n" +
"Detail : " + detail + " \n"
/// <summary>
/// A record to encapuslate the state that will change in the QueryListBox
/// after a filter has been executed or when a new set of data has been
/// loaded into the QueryListBox </summary>
type QueryListBoxState<'DataType> =
{
LastQuery : string
OriginalResults : 'DataType []
ResultList : 'DataType []
ShowCharMatch : Visibility
ShowExactMatch : Visibility
}
type QueryListBoxFunctions<'DataType> =
{
CharMatch : string -> 'DataType[] -> 'DataType[]
ExactMatch : string -> 'DataType[] -> 'DataType[]
FilterResults : string ->
(string -> 'DataType[] -> 'DataType[]) ->
(string -> 'DataType[] -> 'DataType[]) ->
QueryListBoxState<'DataType> ->
QueryListBoxState<'DataType>
}
type QueryListBoxConfig =
{
BlockSmall : float
BlockBig : float
BlockZone : float
Opacity : float
QueryText : string
BgdColor : SolidColorBrush
TextColor : Color
BlockColor : Color
HighlightColor : SolidColorBrush
ScrollVisibility : ScrollBarVisibility
}
type QueryListBoxTemplates =
{
DataTemplate : DataTemplate
Selector : DataTemplateSelector
}
[<AutoOpen>]
module QueryListBoxHelpers =
/// <summary>
/// List of strings displayed in the XAML designer by the QueryListBox
/// </summary>
let tempItems = [| "cowboy bebop";"gundam wing";"princess mononoke";
"my neighbor totoro";"nausica and the valley of the wind";
"castle in the sky";"spirited away";"steamboy";"kill la kill";
"ghost in the shell";"memories" |]
let makeListData arr = arr |> Array.map ( fun s -> ListData(s,[|"Ctrl+Somekey";"decscription"|],s))
let tempData = makeListData tempItems
let charMatch (query:string) (candidates:ListData []) =
let qry = (query.FilterChar ' ' ).ToLower()
let folder (acc:ListData [])((ch,num):char*int) =
acc
|> Array.filter ( fun s -> s.Text.ContainsCount ch >= num )
List.fold folder candidates qry.charCounts
let exactMatch (query:string)(candidates:ListData[]) =
candidates
|> Array.filter ( fun s -> s.Text.Contains(query))
let filterResults
( query :string )
( charMatch :string->ListData[]->ListData[] )
( exactMatch:string->ListData[]->ListData[] )
( state:QueryListBoxState<ListData> ):QueryListBoxState<ListData> =
if query <> state.LastQuery then
match query with
| Empty _ -> { state with
ShowCharMatch = Visibility.Hidden
ShowExactMatch = Visibility.Hidden
ResultList = state.OriginalResults }
| MatchExact qt -> let filtered = exactMatch qt state.OriginalResults
{ state with
ShowCharMatch = Visibility.Hidden
ShowExactMatch = Visibility.Visible
LastQuery = query
ResultList = filtered }
| qry -> let filtered = charMatch qry state.OriginalResults
{ state with
ShowCharMatch = Visibility.Visible
ShowExactMatch = Visibility.Hidden
LastQuery = qry
ResultList = filtered }
else
state
/// <summary>
///
/// </summary>
type HighlightText() as self =
inherit Behavior<TextBlock>()
[<DefaultValue(false)>]
static val mutable private QueryProperty:DependencyProperty
[<DefaultValue(false)>]
static val mutable private HighlightColorProperty:DependencyProperty
[<DefaultValue(false)>]
static val mutable private ShowCharMatchProperty:DependencyProperty
[<DefaultValue(false)>]
static val mutable private ShowExactMatchProperty:DependencyProperty
static do
HighlightText.QueryProperty <- DependencyProperty.Register("Query" , typeof<string> , typeof<HighlightText>)
HighlightText.HighlightColorProperty <- DependencyProperty.Register("HighlightColor" , typeof<SolidColorBrush> , typeof<HighlightText>)
HighlightText.ShowCharMatchProperty <- DependencyProperty.Register("ShowCharMatch" , typeof<Visibility> , typeof<HighlightText>)
HighlightText.ShowExactMatchProperty <- DependencyProperty.Register("ShowExactMatch" , typeof<Visibility> , typeof<HighlightText>)
member __.HighlightColor
with get() = self.GetValue HighlightText.HighlightColorProperty :?> SolidColorBrush
and set (v:SolidColorBrush) = self.SetValue (HighlightText.HighlightColorProperty,v)
member __.Query
with get() = self.GetValue HighlightText.QueryProperty :?> string
and set (v:string) = self.SetValue (HighlightText.QueryProperty,v)
member __.ShowCharMatch
with get() = self.GetValue HighlightText.ShowCharMatchProperty :?> Visibility
and set (v:Visibility) = self.SetValue (HighlightText.ShowCharMatchProperty,v)
member __.ShowExactMatch
with get() = self.GetValue HighlightText.ShowExactMatchProperty :?> Visibility
and set (v:Visibility) = self.SetValue (HighlightText.ShowExactMatchProperty,v)
member __.ApplyHighlight () =
// Highlight strategy for exact match queries
if self.ShowExactMatch = Visibility.Visible then
let textblock = self.AssociatedObject
let text = textblock.Text
let inlines = textblock.Inlines
let query = self.Query.TrimEnds
if query.Length > 0 then
// clear the current textblock rendering to start fresh
inlines.Clear()
let startIndex = text.IndexOf(query)
let endIndex = startIndex + query.LastIndex
if startIndex <> -1 then
match startIndex,endIndex with
| si,ei when si = 0
&& ei = text.LastIndex ->
let ct = Run(text)
ct.Background <- self.HighlightColor
inlines.Add ct
| si,ei when si <> 0
&& ei = text.LastIndex ->
inlines.Add( Run text.[0..si-1])
let ct = Run(text.[si..ei])
ct.Background <- self.HighlightColor
inlines.Add ct
| si,ei when si = 0
&& ei <> text.LastIndex ->
let ct = Run(text.[si..ei])
ct.Background <- self.HighlightColor
inlines.Add ct
inlines.Add( Run text.[ei+1..text.LastIndex])
| si,ei ->
inlines.Add( Run text.[0..si-1])
let ct = Run(text.[si..ei])
ct.Background <- self.HighlightColor
inlines.Add ct
inlines.Add( Run text.[ei+1..text.LastIndex])
// Highlight strategy for character match queries
if self.ShowCharMatch = Visibility.Visible then
let textblock = self.AssociatedObject
let text = textblock.Text
let textlow = textblock.Text.ToLower()
let inlines = textblock.Inlines
let query = self.Query.FilterChar ' '
if query.Length > 0 then
// clear the current textblock rendering to start fresh
inlines.Clear()
// get a list of the distinct chars in the query
let queryIDs = query.ToArray |> Seq.distinct |> Seq.toList
let len = text.Length
(* For each distinct char in the query find the indices of each instance
of that char in the strings being searched.
Take the first x indices of that char in the text, where x is the number
of instances of the char in the query
Accumulate the matches for all chars in the query into a list *)
let rec getIndices acc (qryChars:char list) =
match qryChars with
| hd::tl -> let idxs = textlow.AllIndices hd
let cnt = query.ContainsCount hd
let locs =
// if cnt = 1 then
// idxs |> Array.toList
// else
idxs.[0..cnt-1] |> Array.toList
// let cnt = if query.ContainsCount hd = 0 then
// (query.ContainsCount hd) - 1
// else
// 0
// let locs = if cnt = 0 then
// []
// else
// idxs.[0..cnt] |> Array.toList
getIndices ( locs @ acc ) tl
| [] -> acc
// sort the list of indices of char matches so they can be used to split
// and reconstruct the textblock with the matches highlighted
let indicies = getIndices [] queryIDs |> List.sort
// 'last' is the index of the previous char in the text that matched a char in the query
// 'cur' is the index of current char that matches a char in the query
// when last = -1 it means we're parsing from the beginning of the text string
let addRun last cur =
match last, cur with
// If the first match is at [0] highlight that char and add it to the textblock
| -1,cur when cur = 0 -> let ct = Run ( string text.[0] )
ct.Background <- self.HighlightColor
inlines.Add ct
cur
// If the first match is at [i>0], add the text before the match to the textblock
// then highlight the matching char and add it to the textblock
| -1,cur when cur <> 0 -> inlines.Add( Run text.[0..cur-1])
let ct = Run ( string text.[cur] )
ct.Background <- self.HighlightColor
inlines.Add ct
cur
// If the prior match was the index before the current match
// then highlight the current match and add it to the textblock
| l,cur when cur = l+1 -> let ct = Run ( string text.[cur] )
ct.Background <- self.HighlightColor
inlines.Add ct
cur
// If there are unmatched chars between the last match and the
// current match add them to the textblock then highlight
// the current match and add it to the textblock
| l,cur -> inlines.Add( Run text.[l+1..cur-1])
let ct = Run( string text.[cur] )
ct.Background <- self.HighlightColor
inlines.Add ct
cur
// The loop folds the addRun function over the list of indices of char matches.
// After all the matches for chars in the query have been found ([]), if there are
// chars left in the text, add them to the textblock
let rec loop indls last =
match indls with
| cur::tl -> loop tl ( addRun last cur )
| [] -> if last+1 <= len-1 then
inlines.Add( Run text.[last+1..len-1])
loop indicies -1
override __.OnAttached() =
self.ApplyHighlight()
namespace ViewModels
open FSharp.ViewModule
open System.Windows
open System.Windows.Controls
open GUIControls.Utilities
open GUIControls
open QueryListBoxHelpers
open System.ComponentModel
type QueryListBoxViewModel<'DataType>
( functions : QueryListBoxFunctions<'DataType> ,
config : QueryListBoxConfig ,
state : QueryListBoxState<'DataType> ) as self =
inherit ViewModelBase()
// #region Helper Functions and Operators
// Functions to create dependency properties
let ( =+= ) arg1 arg2 = self.Factory.Backing(arg1,arg2)
let makeCommand func = self.Factory.CommandSync(func)
let makeCommandParam func = self.Factory.CommandSyncParam(func)
// Operators for connecting dependency properties
let ( <=== ) prop1 prop2 = addDep self prop1 prop2
let ( <<== ) prop1 props = addDeps self prop1 props
let ( |>>> ) cmd prop = addCmd self cmd prop
// #endregion
// Dependency Properties created with default values
// Some of these values are to aid at design time and will be initialized differently
let resultWidth = <@ self.ResultWidth @> =+= 0.0
let scrollOpacity = <@ self.ScrollOpacity @> =+= config.Opacity
let blockWidth = <@ self.BlockWidth @> =+= config.BlockSmall
let query = <@ self.Query @> =+= config.QueryText
let lastQuery = <@ self.LastQuery @> =+= config.QueryText
let resultList = <@ self.ResultList @> =+= state.OriginalResults
let originalResults = <@ self.OriginalResults @> =+= state.OriginalResults
let bgdColor = <@ self.BgdColor @> =+= config.BgdColor
let textColor = <@ self.TextColor @> =+= config.TextColor
let blockColor = <@ self.BlockColor @> =+= config.BlockColor
let scrollVisible = <@ self.ScrollVisibility @> =+= config.ScrollVisibility
let highlightColor = <@ self.HighlightColor @> =+= config.HighlightColor
let showCharMatch = <@ self.ShowCharMatch @> =+= Visibility.Hidden
let showExactMatch = <@ self.ShowExactMatch @> =+= Visibility.Hidden
let isLeftMouseDown = <@ self.IsLeftMouseDown @> =+= false
let currentSelection = <@ self.CurrentSelection @> =+= ""
let selectedValue = <@ self.SelectedValue @> =+= ""
let selectedIndex = <@ self.SelectedIndex @> =+= -1
let charMatchFunc = <@ self.CharMatch @> =+= functions.CharMatch
let exactMatchFunc = <@ self.ExactMatch @> =+= functions.ExactMatch
// #region Command Definitions
// positionCommand is used to change the size of the scrollbar when the user's
// cursor is near it. The check on whether the left button is down makes sure the
// block stays big if the cursor moves away from the bar while the user is moving it
let positionCommand (pos:Point) =
let width: float = resultWidth.Value
let bz = config.BlockZone
if (pos) <> defaultPoint && width > 0.0 then
match pos with
| pos when pos.X >= width - bz -> self.BlockWidth <- config.BlockBig
| _ -> if self.IsLeftMouseDown = false then
self.BlockWidth <- config.BlockSmall
// Commands to respond to event triggers in XAML file
let mousePosition = makeCommandParam positionCommand
let getWidth = makeCommandParam ( fun width -> self.ResultWidth <- width )
let getSelectedValue = makeCommandParam ( fun value -> self.SelectedValue <- value )
let filterCommand (qry:string) =
let stateUpdate =
functions.FilterResults qry
self.CharMatch
self.ExactMatch
{ ResultList = self.ResultList
LastQuery = self.LastQuery
OriginalResults = self.OriginalResults
ShowCharMatch = self.ShowCharMatch
ShowExactMatch = self.ShowExactMatch }
self.ResultList <- stateUpdate.ResultList
self.LastQuery <- stateUpdate.LastQuery
self.ShowCharMatch <- stateUpdate.ShowCharMatch
self.ShowExactMatch <- stateUpdate.ShowExactMatch
let filterResults =
makeCommandParam ( fun (qry:string) -> filterCommand qry )
let mouseOver = makeCommand ( fun () -> self.ScrollVisibility <- ScrollBarVisibility.Visible )
let mouseAway = makeCommand ( fun () -> self.ScrollVisibility <- ScrollBarVisibility.Hidden )
let leftMouseDown = makeCommand ( fun () -> self.IsLeftMouseDown <- true )
let leftMouseUp = makeCommand ( fun () -> self.IsLeftMouseDown <- false )
// #endregion
do
// Bind commands to properties
mouseOver |>>> <@@ self.ScrollVisibility @@>
mouseAway |>>> <@@ self.ScrollVisibility @@>
mousePosition |>>> <@@ self.BlockWidth @@>
getWidth |>>> <@@ self.ResultWidth @@>
leftMouseDown |>>> <@@ self.IsLeftMouseDown @@>
leftMouseUp |>>> <@@ self.IsLeftMouseDown @@>
getSelectedValue |>>> <@@ self.SelectedValue @@>
filterResults |>>> <@@ self.ResultList @@>
// Connect property dependencies
<@@ self.ResultList @@> <=== <@@ self.Query @@>
<@@ self.BlockWidth @@> <=== <@@ self.ScrollVisibility @@>
<@@ self.BlockWidth @@> <=== <@@ self.IsLeftMouseDown @@>
/// Stores the results that will be filtered by the query's value
member __.OriginalResults
with get() = originalResults.Value
and set v = originalResults.Value <- v
self.ResultList <- v
self.LastQuery <- config.QueryText
self.Query <- config.QueryText
//#region Dependency Properties
// Type Members to access dependency properies for bindings in XAML file
[<Browsable(true)>]
member __.Query
with get() = query.Value
and set v = query.Value <- v
self.RaisePropertyChanged <@ self.Query @>
member __.LastQuery
with get() = lastQuery.Value
and set v = lastQuery.Value <- v
self.RaisePropertyChanged <@ self.LastQuery @>
member __.ResultList
with get() = resultList.Value
and set v = resultList.Value <- v
self.RaisePropertyChanged <@ self.ResultList @>
member __.ScrollVisibility
with get() = scrollVisible.Value
and set v = scrollVisible.Value <- v
member __.ScrollOpacity
with get() = scrollOpacity.Value
and set v = scrollOpacity.Value <- v
member __.BlockColor
with get() = blockColor.Value
and set v = blockColor.Value <- v
member __.TextColor
with get() = textColor.Value
and set v = textColor.Value <- v
member __.BgdColor
with get() = bgdColor.Value
and set v = bgdColor.Value <- v
[<Browsable(true)>]
member __.HighlightColor
with get() = highlightColor.Value
and set v = highlightColor.Value <- v
member __.ShowCharMatch
with get() = showCharMatch.Value
and set v = showCharMatch.Value <- v
member __.ShowExactMatch
with get() = showExactMatch.Value
and set v = showExactMatch.Value <- v
member __.BlockWidth
with get() = blockWidth.Value
and set v = blockWidth.Value <- v
member __.ResultWidth
with get() = resultWidth.Value
and set v = resultWidth.Value <- v
member __.IsLeftMouseDown
with get() = isLeftMouseDown.Value
and set v = isLeftMouseDown.Value <- v
member __.CurrentSelection
with get() = currentSelection.Value
and set v = currentSelection.Value <- v
self.RaisePropertyChanged <@ self.CurrentSelection @>
member __.SelectedValue
with get() = selectedValue.Value
and set v = selectedValue.Value <- v
self.RaisePropertyChanged <@ self.SelectedValue @>
member __.SelectedIndex
with get() = selectedIndex.Value
and set v = selectedIndex.Value <- v
member __.CharMatch
with get() = charMatchFunc.Value
and set v = charMatchFunc.Value <- v
member __.ExactMatch
with get() = exactMatchFunc.Value
and set v = exactMatchFunc.Value <- v
// #region Command Members
// Type Members to access commands in XAML file
member __.MouseOver = mouseOver
member __.MouseAway = mouseAway
member __.MousePosition = mousePosition
member __.GetWidth = getWidth
member __.LeftMouseDown = leftMouseDown
member __.LeftMouseUp = leftMouseUp
member __.GetSelectedValue = getSelectedValue
member __.FilterResults = filterResults
// #endregion
[<Struct>]
[<StructuredFormatDisplay( "{Output}" )>]
type CommandData (name:string, chord:string, description:string) =
member __.Name = name
member __.Chord = chord
member __.Description = description
member internal x.Output =
"Name : " + x.Name + " \n" +
"Chord : " + x.Chord + " \n" +
"Description : " + x.Description + " \n"
[<AutoOpen>]
module PaletteSetup =
let c1 = CommandData( "Function 1", "Ctrl+Alt+Delete","The description text")
let c2 = CommandData( "Function 2", "Ctrl+Alt" ,"The description text")
let c3 = CommandData( "Function 3", "Ctrl+Delete" ,"The description text")
let c4 = CommandData( "Function 4", "Ctrl+Shift" ,"The description text")
let c5 = CommandData( "Function 5", "Alt+Shift" ,"The description text")
let c6 = CommandData( "Function 6", "Alt+K" ,"The description text")
let comArr = [|c1;c2;c3;c4;c5;c6|]
let charMatch (query:string) (candidates:CommandData[]) =
let query = (query.FilterChar ' ').ToLower()
let folder (acc:CommandData [])((ch,num):char*int) =
acc
|> Array.filter ( fun s -> s.Name.ContainsCount ch >= num ||
s.Chord.ContainsCount ch >= num ||
s.Description.ContainsCount ch >= num )
List.fold folder candidates query.charCounts
let exactMatch (query:string) (candidates:CommandData[]) =
candidates
|> Array.filter ( fun s -> s.Name.Contains(query) ||
s.Chord.Contains(query) ||
s.Description.Contains(query))
let filterResults
( query :string )
( charMatch :string->CommandData[]->CommandData[] )
( exactMatch:string->CommandData[]->CommandData[] )
( state:QueryListBoxState<CommandData> ):QueryListBoxState<CommandData> =
if query <> state.LastQuery then
match query with
| Empty _ ->{state with
ShowCharMatch = Visibility.Hidden
ShowExactMatch = Visibility.Hidden
ResultList = state.OriginalResults}
| MatchExact qt -> let filtered = exactMatch qt state.OriginalResults
{state with
ShowCharMatch = Visibility.Hidden
ShowExactMatch = Visibility.Visible
LastQuery = query
ResultList = filtered }
| qry -> let filtered = charMatch qry state.OriginalResults
{state with
ShowCharMatch = Visibility.Visible
ShowExactMatch = Visibility.Hidden
LastQuery = qry
ResultList = filtered }
else
state
let paletteFuncs =
{ ExactMatch = exactMatch
CharMatch = charMatch
FilterResults = filterResults }
let paletteConfig: QueryListBoxConfig =
{ BlockSmall = 5.0
BlockBig = 10.0
BlockZone = 13.0
Opacity = 0.40
QueryText = "Search Commands..."
BgdColor = Brushes.DimGray
TextColor = Brushes.LightGray.Color
BlockColor = Brushes.DarkCyan.Color
HighlightColor = Brushes.Black
ScrollVisibility = ScrollBarVisibility.Hidden }
let paletteState:QueryListBoxState<CommandData> =
{ LastQuery = paletteConfig.QueryText
OriginalResults = comArr
ResultList = comArr
ShowCharMatch = Visibility.Hidden
ShowExactMatch = Visibility.Hidden }
type CommandPaletteControlVM() =
inherit QueryListBoxViewModel<CommandData>( paletteFuncs ,
paletteConfig ,
paletteState )
type CommandPaletteWindowVM() as self =
inherit ViewModelBase()
let mutable controlVM = new CommandPaletteControlVM()
do
controlVM.OriginalResults <- comArr
()
member __.ControlVM
with get() = controlVM
and set v = controlVM <- v
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment