2 people like it.

Defining union cases that have the cons ( :: ) pattern

Here I give an example of a data structure known as a skew binary list and also an example of how to use the cons pattern, normally reserved for FSharp lists, in your own union cases. It is not possible to do the same with the nil union case, []. Nor is it possible to use any other symbols (as far as I know). This kind of sucks.

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
130: 
131: 
132: 
133: 
134: 
135: 
136: 
137: 
138: 
139: 
140: 
141: 
142: 
143: 
144: 
145: 
146: 
147: 
148: 
149: 
150: 
151: 
152: 
[<CompilationRepresentationAttribute(CompilationRepresentationFlags.ModuleSuffix)>]
module internal TreeList = 
    let Treelist_indexing_error = errors.Invalid_state "There was a strange indexing error involving a binary tree."
    let Node_without_children = errors.Invalid_state "The program tried to get the children of a leaf node."
    type Size = int
    
    type BinaryTree<'a> =
        internal 
        | Leaf of 'a
        | Parent of BinaryTree<'a> * BinaryTree<'a> * Size (* The sk*)
        | ValuedParent of 'a * BinaryTree<'a> * BinaryTree<'a> * Size
        with

        member this.Value = 
            match this with
            | Leaf(v) | ValuedParent(v,_,_,_) -> v
            | Parent _ -> failwith "This node has no value."

        member this.HasValue = 
            match this with
            | Parent _ -> false
            | _ -> true

        member this.Left = 
            match this with
            | Parent(left,_,_) | ValuedParent(_,left,_,_) -> left
            | Leaf v -> raise Node_without_children
          

        member this.Right = 
            match this with
            | Parent(_,right,_) | ValuedParent(_,_,right,_) -> right
            | Leaf v -> raise Node_without_children

        
        member this.Count = 
            match this with
            | Leaf(_) -> 1 | Parent(_,_,c) | ValuedParent(_,_,_,c) -> c 

        member this.Get i =  
            let rec get tree i = 
                (* This algorithm is trivial. Every node knows how many value children it has. *)
                match tree with
                | _ when this.Count <= i -> failwith "The index is not found in this tree."
                | ValuedParent(v,_,_,_) | Leaf(v) when i = 0 -> v

                | Parent(left,_,_) when left.Count > i -> get left i
                | Parent(left,right,_ ) ->
                    get right (i - left.Count)
                | ValuedParent(_,left,right,_) when 1 + left.Count > i -> get left (i - 1)
                | ValuedParent (_,left,right,_) ->
                    get right (i - left.Count - 1)
                | _ -> raise Treelist_indexing_error
            get this i

        member this.First = 
            match this with
            | Leaf(v) | ValuedParent(v,_,_,_) -> v
            | Parent(left,_,_) -> left.First
    
    module public Tree =   
        let inline left (tree : ^s) : ^s = 
            ( ^s : ( member Left : ^s) tree)

        let inline right (tree : ^s) : ^s = 
            ( ^s : ( member Right : ^s) tree)

        let inline value (tree : ^s) : ^a = 
            ( ^s : (member Value : ^a) tree)

        let inline isEmpty ( tree : ^s) : bool = 
            (^s : (member IsEmpty : bool) tree)

        let inline empty () = 
            (^s : (static member empty : ^s) () )

     
        let newLeaf v = Leaf v
            
        let newParent left right = Parent(left,right,left.Count + right.Count)

        let newValParent v left right = ValuedParent(v,left,right,left.Count + right.Count + 1)
             

    
    
    open Tree
    type TreeList<'a> = 
    | Nil
    | (::) of BinaryTree<'a> * TreeList<'a> 
    (*Fun fact: the cons union case, (::), can be defined. Allows us to pattern match list-like structures that are not lists.*)
    with
        static member Empty = Nil
        
        member this.Head = 
            match this with
            | Nil -> failwith "Empty list."
            | h::_ -> h.First

        member this.IsEmpty = 
            match this with
            | Nil -> true | _ -> false

        member private this.fix (s : TreeList<'a>) : TreeList<'a> = 
            match s with
            | ValuedParent(_,_,_,c_1)::ValuedParent(_,_,_,c_2)::_ & a::b::tail when c_1 = c_2->
                newParent a b :: tail
            | _ -> s

        member this.Cons v : TreeList<'a> =
            match this with
            | Nil -> newLeaf(v)::Nil (* Trivial case *)
            | ValuedParent _ :: _ -> 
                let fx = this.fix this
                match fx with
                | Parent(left,right,_)::tail -> newValParent v left right::(tail)
                | _ -> newLeaf v :: this
            | Leaf _ as head::tail -> (newParent (newLeaf v) (head))::tail
            | Parent(left,right,_)::tail -> (newValParent v left right) :: tail
  

        member this.Uncons = 
            match this with
            | Nil -> failwith "The list is empty."
            | Leaf _::tail -> tail
            | ValuedParent(_,left,right,_)::tail -> newParent left right :: tail
            | Parent(Leaf _, leaf,_)::tail -> leaf::tail
            | Parent(ValuedParent(_,left_left,left_right,_),right,_)::tail -> 
                newParent left_left left_right :: right :: tail
            | _ -> failwith "Invalid."
        
        member this.Length =
            let mutable count = 0
            let mutable lst = this
            while lst.IsEmpty |> not do
                match lst with
                | head::tail ->
                    count <- count + head.Count
                    lst <- tail
                | Nil -> raise errors.Contradiction
            count

        member this.Get i =
            let rec get lst i = 
                match lst with
                | Nil -> raise errors.Is_empty
                | head::tail when head.Count > i -> head.Get i
                | head::tail -> get tail (i - head.Count)
            get this i
                

    
Multiple items
type CompilationRepresentationAttribute =
  inherit Attribute
  new : flags:CompilationRepresentationFlags -> CompilationRepresentationAttribute
  member Flags : CompilationRepresentationFlags

Full name: Microsoft.FSharp.Core.CompilationRepresentationAttribute

--------------------
new : flags:CompilationRepresentationFlags -> CompilationRepresentationAttribute
type CompilationRepresentationFlags =
  | None = 0
  | Static = 1
  | Instance = 2
  | ModuleSuffix = 4
  | UseNullAsTrueValue = 8
  | Event = 16

Full name: Microsoft.FSharp.Core.CompilationRepresentationFlags
CompilationRepresentationFlags.ModuleSuffix: CompilationRepresentationFlags = 4
module TreeList

from Script
val internal Treelist_indexing_error : System.Exception

Full name: Script.TreeListModule.Treelist_indexing_error
val internal Node_without_children : System.Exception

Full name: Script.TreeListModule.Node_without_children
type internal Size = int

Full name: Script.TreeListModule.Size
Multiple items
val int : value:'T -> int (requires member op_Explicit)

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

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
type internal BinaryTree<'a> =
  | Leaf of 'a
  | Parent of BinaryTree<'a> * BinaryTree<'a> * Size
  | ValuedParent of 'a * BinaryTree<'a> * BinaryTree<'a> * Size
  member Get : i:int -> 'a
  member Count : int
  member First : 'a
  member HasValue : bool
  member Left : BinaryTree<'a>
  member Right : BinaryTree<'a>
  member Value : 'a

Full name: Script.TreeListModule.BinaryTree<_>
union case TreeList.BinaryTree.Leaf: 'a -> TreeList.BinaryTree<'a>
union case TreeList.BinaryTree.Parent: TreeList.BinaryTree<'a> * TreeList.BinaryTree<'a> * TreeList.Size -> TreeList.BinaryTree<'a>
union case TreeList.BinaryTree.ValuedParent: 'a * TreeList.BinaryTree<'a> * TreeList.BinaryTree<'a> * TreeList.Size -> TreeList.BinaryTree<'a>
val this : TreeList.BinaryTree<'a>
member internal TreeList.BinaryTree.Value : 'a

Full name: Script.TreeListModule.BinaryTree`1.Value
val v : 'a
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
member internal TreeList.BinaryTree.HasValue : bool

Full name: Script.TreeListModule.BinaryTree`1.HasValue
member internal TreeList.BinaryTree.Left : TreeList.BinaryTree<'a>

Full name: Script.TreeListModule.BinaryTree`1.Left
val left : TreeList.BinaryTree<'a>
val raise : exn:System.Exception -> 'T

Full name: Microsoft.FSharp.Core.Operators.raise
member internal TreeList.BinaryTree.Right : TreeList.BinaryTree<'a>

Full name: Script.TreeListModule.BinaryTree`1.Right
val right : TreeList.BinaryTree<'a>
member internal TreeList.BinaryTree.Count : int

Full name: Script.TreeListModule.BinaryTree`1.Count
val c : TreeList.Size
member internal TreeList.BinaryTree.Get : i:int -> 'a

Full name: Script.TreeListModule.BinaryTree`1.Get
val i : int
val get : (TreeList.BinaryTree<'b> -> int -> 'b)
val tree : TreeList.BinaryTree<'b>
property TreeList.BinaryTree.Count: int
val v : 'b
val left : TreeList.BinaryTree<'b>
val right : TreeList.BinaryTree<'b>
member internal TreeList.BinaryTree.First : 'a

Full name: Script.TreeListModule.BinaryTree`1.First
property TreeList.BinaryTree.First: 'a
val internal left : tree:'s -> 's (requires member get_Left)

Full name: Script.TreeListModule.Tree.left
val tree : 's (requires member get_Left)
val internal right : tree:'s -> 's (requires member get_Right)

Full name: Script.TreeListModule.Tree.right
val tree : 's (requires member get_Right)
val internal value : tree:'s -> 'a (requires member get_Value)

Full name: Script.TreeListModule.Tree.value
val tree : 's (requires member get_Value)
val internal isEmpty : tree:'s -> bool (requires member get_IsEmpty)

Full name: Script.TreeListModule.Tree.isEmpty
val tree : 's (requires member get_IsEmpty)
type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool
val internal empty : unit -> 's (requires member get_empty)

Full name: Script.TreeListModule.Tree.empty
val internal newLeaf : v:'a -> TreeList.BinaryTree<'a>

Full name: Script.TreeListModule.Tree.newLeaf
val internal newParent : left:TreeList.BinaryTree<'a> -> right:TreeList.BinaryTree<'a> -> TreeList.BinaryTree<'a>

Full name: Script.TreeListModule.Tree.newParent
val internal newValParent : v:'a -> left:TreeList.BinaryTree<'a> -> right:TreeList.BinaryTree<'a> -> TreeList.BinaryTree<'a>

Full name: Script.TreeListModule.Tree.newValParent
module Tree

from Script.TreeListModule
type internal TreeList<'a> =
  | Nil
  | ( :: ) of BinaryTree<'a> * TreeList<'a>
  member Cons : v:'a -> TreeList<'a>
  member Get : i:int -> 'a
  member private fix : s:TreeList<'a> -> TreeList<'a>
  member Head : 'a
  member IsEmpty : bool
  member Length : int
  member Uncons : TreeList<'a>
  static member Empty : TreeList<obj>

Full name: Script.TreeListModule.TreeList<_>
union case TreeList.TreeList.Nil: TreeList.TreeList<'a>
static member internal TreeList.TreeList.Empty : TreeList.TreeList<obj>

Full name: Script.TreeListModule.TreeList`1.Empty
val this : TreeList.TreeList<'a>
member internal TreeList.TreeList.Head : 'a

Full name: Script.TreeListModule.TreeList`1.Head
val h : TreeList.BinaryTree<'a>
member internal TreeList.TreeList.IsEmpty : bool

Full name: Script.TreeListModule.TreeList`1.IsEmpty
member private TreeList.TreeList.fix : s:TreeList.TreeList<'a> -> TreeList.TreeList<'a>

Full name: Script.TreeListModule.TreeList`1.fix
val s : TreeList.TreeList<'a>
val c_1 : TreeList.Size
val c_2 : TreeList.Size
val a : TreeList.BinaryTree<'a>
val b : TreeList.BinaryTree<'a>
val tail : TreeList.TreeList<'a>
member internal TreeList.TreeList.Cons : v:'a -> TreeList.TreeList<'a>

Full name: Script.TreeListModule.TreeList`1.Cons
val fx : TreeList.TreeList<'a>
member private TreeList.TreeList.fix : s:TreeList.TreeList<'a> -> TreeList.TreeList<'a>
val head : TreeList.BinaryTree<'a>
member internal TreeList.TreeList.Uncons : TreeList.TreeList<'a>

Full name: Script.TreeListModule.TreeList`1.Uncons
val leaf : TreeList.BinaryTree<'a>
val left_left : TreeList.BinaryTree<'a>
val left_right : TreeList.BinaryTree<'a>
member internal TreeList.TreeList.Length : int

Full name: Script.TreeListModule.TreeList`1.Length
val mutable count : int
val mutable lst : TreeList.TreeList<'a>
property TreeList.TreeList.IsEmpty: bool
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
member internal TreeList.TreeList.Get : i:int -> 'a

Full name: Script.TreeListModule.TreeList`1.Get
val get : (TreeList.TreeList<'b> -> int -> 'b)
val lst : TreeList.TreeList<'b>
val head : TreeList.BinaryTree<'b>
val tail : TreeList.TreeList<'b>
Raw view Test code New version

More information

Link:http://fssnip.net/he
Posted:11 years ago
Author:Greg Ros
Tags: discriminated unions , operators , cons , linked list , data structures , skew binary list , cons