The Estimable Item 175

Here are some more recreations suggested by reading TAoCP Fascicle 4.1. This is a wonderful little book, reasonably priced and deserving of a place on every computer programmer’s bookshelf.

This example illustrates a famous “Gosper hack.” There is apparently some controversy over which Gosper hack merits the title THE Gosper hack. Often that title goes to MIT A.I. Laboratory HAKMEM Item 145. The code below is based on Gosper hack 175 from the same document, which is the one Knuth mentions.

The example below contains a series of experiments which should make it increasingly obvious what the Gosper function 175 computes. In case that’s not enough, another function in the same general class is also illustrated.

(Presented “as-is” and without warranty or implied fitness; use at your own risk.)

// HAKMEM Item 175 (Gosper) 
let g175 x = 
  let u = x &&& -x
  let v = x + u
  v + (((v^^^x)/u)>>>2)
  
  
// Some tests.

// x of 1 to 32.
let l0 = List.map (fun x->(x,(g175 x))) [1..32]


// Unfold x from 1 to <64.
let l1 = 
  Seq.toList(
    Seq.unfold (
      fun s -> 
        if s>=64 
          then None 
          else Some(s,(g175 s))) 
      1)


// Unfold x from 0x1f to <64.
let l2 = 
  Seq.toList(
    Seq.unfold (
      fun s -> 
        if s>=64 
          then None 
          else Some(s,(g175 s))) 
      0x1f)


// Hideously overly complex binary formatter
// just for the fun of it.
let binaryFmt =
  let rec binaryFmt0 f b =
    match b with 
    | 0 -> f("")
    | _ -> 
        match (b&&&1) with 
        | 0 -> binaryFmt0 (fun s -> s+f("0")) (b/2)
        | _ -> binaryFmt0 (fun s -> s+f("1")) (b/2)
  binaryFmt0 (fun s->s)    


// Unfold x from 7 to <64.
// Results in binary.
let l3 = 
  Seq.toList(
    Seq.unfold (
      fun s -> 
        if s>=64 
          then None 
          else Some((binaryFmt s),(g175 s))) 
      7)
      

// Another function in 
// the same general class.      
let ee n =
  let u = n&&&(-n)
  ((binaryFmt (n/u)),u)


// x from 1 to 64.
let l4 = List.map (fun n->ee n) [1..64]


printf "Your breakpoint here."

Bit Operations from TAoCP in F#

In the interest of keeping the blog active in the midst of tax time, dragging out the bit theme a bit longer, etc., here the bit enumerators based on Dr. Knuth's TAoCP (Fascicle 4.1) in F#. My earlier C# posts on this can be found here and here.

(Presented “as-is” and without warranty or implied fitness; use at your own risk.)

// Enumerate the bits in an integer.
let rec bits n = seq {
  match n with 
  | 0 -> ()
  | _ -> 
    let b = n&&&(-n)
    yield b
    yield! bits (n&&&(~~~b))
}


// Enumerate the power set of the bits in
// an integer, including the null set.
let powerSet = 
  let rec powerSet0 s n = seq {  
    yield s 
    match (s=n) with 
    | true -> ()
    | _ -> yield! powerSet0 ((s-n)&&&n) n
  }
  powerSet0 0
  

// Test.
let x0 = Seq.toList (bits 0xDD)
let x1 = Seq.toList (powerSet 5)
let x2 = Seq.toList (powerSet 0xDD)
let x3 = Seq.toList (powerSet 7)

printf "Your breakpoint here."

Correction

Oops! Code while distracted on weekends, repent while distracted next weekday. I found a bug in the nextNibble function of the BC32 library. The fix shown below and has also been applied to the original blog post. It doesn’t affect any of the existing examples, but might have shown up in other BC32 programs.

Since my policy is never to fix one bug without introducing the possibility of others (lol), I also made some improvements to the code.

My apologies, Neil.

(As always, presented “as-is” and without warranty or implied fitness; use at your own risk.)

// Aligns a power of two to the next block.
let rec internal nextBlock (n:int) 
                           (b:int)
                           (f:int) =
  match (n<=b) with 
  | true -> b
  | _ -> nextBlock n (b*f) f


// Align to the next nibble.      
let rec internal nextNibble (n:int) =
  nextBlock n 16 16

Bit Computer Addition

Today, an addition algorithm for the bit-based computer. I thought up this algorithm without consulting a reference, but I have since discovered that it is listed in the famous MIT A.I. Laboratory "HAKMEM" as Item 23.

We can implement addition by dividing the 32-bit string into sub-strings representing numbers. These numbers could then be added and the result placed elsewhere in the string or written over the original numbers.

But what algorithm to use? It turns out there’s one that’s perfect, and an F# implementation is shown in the following recursive function:

let rec plus lhs rhs = 
  match rhs with 
  | 0 -> lhs
  | _ -> plus (lhs^^^rhs) ((lhs&&&rhs)*2)

That is, if rhs is zero, the answer is just lhs. If rhs is not zero, call the function recursively with the half-add (XOR) of the two numbers as the new lhs and the carry as the new rhs. To find the carry, do a bitwise AND left shift the result by one. (Note that the designation of lhs and rhs is arbitrary; the items in each of the two computations for the new parameters are commutative.)

Why is this perfect? For one thing, both the XOR and the AND are able to operate on pairs of bits asynchronously. This is nice, because the input value is (in effect) tested against the production rules asynchronously. The shift is synchronous, but if we have some way of latching the original bits this limitation can be ignored. And as it turns out, the fact that the input is tested first and asynchronously makes it work as a latch. Furthermore, since the input value is latched, and both lhs and rhs are discarded at each step, we can write the new result right back into the original bit registers!

The rules are fairly simple; the need to split the data between sections of the 32-bit word and the simultaneously updates and shifts presenting only minor problems. The first problem we will solve by limiting the initial test to 3-bit addends and use the nibble separator to keep them registered. Here is the template for the four rules that will be required at each bit position:

  0--:0--  ->  0---:---
  1--:0--  ->  0---:1--
  0--:1--  ->  0---:---
  1--:1--  ->  1---:0—

Some advantage can be gained by modifying the rules for the first bit position and for the final carry. The update of the first bit position is the appropriate place to shift the zero into the carry array. Since there is never an addend, only a carry in the last bit position, only one rule is required. Furthermore, since the state never changes after the carry addend becomes zero, there is no need for a special halt test.

Test code implementing the addition algorithm is shown below; the BC32 library is the same as that listed in an earlier post.

(As always, presented “as-is” and without warranty or implied fitness; use at your own risk. This technique does not, to my knowledge, infringe on any patents, however, the reader is responsible for making sure that such non-infringement is indeed the case for their particular uses.)

open System
open BC32


// This program adds the two three-bit numbers
// in the first two nibbles.  
// The technique is easily extended.
let Add3 =
  [
  // First bit is a special case.
  // Must zero out bit L.0.
  (ins "0:0" "0-:-" )
  (ins "1:0" "00:1" )
  (ins "0:1" "0-:-" )
  (ins "1:1" "10:0" )
  
  // Interior bits follow a pattern.
  
  (ins "0-:0-" "0--:--" )
  (ins "1-:0-" "0--:1-" )
  (ins "0-:1-" "0--:--" )
  (ins "1-:1-" "1--:0-" )
  
  (ins "0--:0--" "0---:---" )
  (ins "1--:0--" "0---:1--" )
  (ins "0--:1--" "0---:---" )
  (ins "1--:1--" "1---:0--" )
  
  // Last bit is a special case.
  // No high bit to test in R.
  // Must zero L high bit.
  (ins "1---:0---" "0---:1---" )
  
  // No need for a halt function.
  ]

// A little syntax helper function.
let runAdd3 l r = (snd (run 100 Add3 (((l&&&0x7)*16)+(r&&&0x7))))

// A few spot examples.
let x00_00 = runAdd3 0 0
let x01_01 = runAdd3 0 1
let x11_02 = runAdd3 1 1
let x22_04 = runAdd3 2 2
let x23_05 = runAdd3 2 3
let x50_05 = runAdd3 5 0
let x57_12 = runAdd3 5 7
let x66_12 = runAdd3 6 6
let x77_14 = runAdd3 7 7

// An exhaustive test.
for l in [0..7] do
  for r in [0..7] do
    if (runAdd3 l r)<>(l+r) then
      failwith "Some kind of error!"
printfn "No errors!"

printfn ""
printfn "Press any key to continue..."
Console.ReadLine() |> ignore

F# Implementation of Bit-Based Computer

Here is some F# source code which implements the tiny bit-based computer described in the previous post. The first block contains the library code, while the second block is a test involving a counting program. Curiously, most of the code is associated with program input – reading in and “assembling” the program – and only very little of the code with running the program. In fact, of the 167 lines of code, comments, etc., the computer itself takes up only 26 lines of code!

The “assembler” makes use of string shorthand to read the binary values for the test and application functions. The main function that takes care of this is “ins” or “INStruction” opcode (in fact, it’s the only opcode). It has two parameters, the test pattern and the application pattern. “Assembly” consists of turning instances of this opcode and its parameters into curried function calls. The program itself is composed of a series of these calls stored in a list. The list order is also the application order for the successful test.

The runtime portion of the computer consists of two functions: a single step and a run. The single step uses List.fold to test and apply all the functions. Run runs a program until a halt condition is met. Halt conditions are: 1) depletion of a “safety” counter, 2) a set “halt bit” (the high bit is reserved for this use), or 3) an output value equal to the input value (it will cycle there forever). Note that the exact sequence of operations as implemented differs from the steps listed in the previous post, but the result is functionally equivalent.

The test code demonstrates a program that, beginning at zero, single steps to fifteen.

As always, presented “as-is” and without warranty or implied fitness; use at your own risk. (This technique does not, to my knowledge, infringe on any patents, however, the reader is responsible for making sure that such non-infringement is indeed the case for their particular uses.)

In the next post, I’ll demonstrate a simple addition algorithm.

The library:

module BC32

// Some constants, for syntax.
let internal highReset = System.Int32.MaxValue
let internal highSet   = System.Int32.MinValue
let internal allReset  = 0
let internal allSet    = -1


// Aligns a power of two to the next block.
let rec internal nextBlock (n:int) 
                           (b:int)
                           (f:int) =
  match (n<=b) with 
  | true -> b
  | _ -> nextBlock n (b*f) f


// Align to the next nibble.      
let rec internal nextNibble (n:int) =
  nextBlock n 16 16


// Reads a string into binary number.
// Character translation is as follows:
// : = Increment counter to next nibble.
//     (Default fill is zero.)
// 0 = Sets bit to zero.
// 1 = Sets bit to one.
//   = Anything else, skip.  This can be used for 
//     user-defined separators, etc.
let rec internal readBinary0 (s:string) 
                             (i:int) 
                             (p:int) 
                             (n:int)  = 
  match i>=0 with
  | false -> n
  | true ->
      match s.[i] with
      | ':' -> readBinary0 s (i-1) (nextNibble p) n
      | '0' -> readBinary0 s (i-1) (p*2) n
      | '1' -> readBinary0 s (i-1) (p*2) (n|||p)
      | _   -> readBinary0 s (i-1) p n  
      

// Syntactic helper for readBinary0.      
let readBinary (s:string) = 
  readBinary0 s (s.Length-1) 1 allReset


// Reads a string into an AXTest parameter pair.
// Character translation is as follows:
// : = Increment counter to next nibble.
//     (Default fill is equivalent to '-'.)
// 0 = On test, will match a zero.
//     (Stores a one na and a zero nx.)
// 1 = On test, will match a one.
//     (Stores a one in both na and nx.)
// - = On test, matches anything.
//     (Stores a zero in both na and nx.)
//   = Anything else, skip.  This can be used for 
//     user-defined separators, etc.
let rec internal readAXTest0 (s:string) 
                             (i:int) 
                             (p:int) 
                             (na:int)
                             (nx:int) = 
  match i>=0 with
  | false -> (na,nx)
  | true ->
      match s.[i] with
      | ':' -> readAXTest0 s (i-1) (nextNibble p) na nx
      | '0' -> readAXTest0 s (i-1) (p*2) (na|||p) nx
      | '1' -> readAXTest0 s (i-1) (p*2) (na|||p) (nx|||p)
      | '-' -> readAXTest0 s (i-1) (p*2) na nx
      | _   -> readAXTest0 s (i-1) p na nx 
      

// Syntactic helper for readAXTest0.      
let internal readAXTest (s:string) = 
  readAXTest0 s (s.Length-1) 1 allReset allReset


// Reads a string into an AXFunc parameter pair.
// Character translation is as follows:
// : = Increment counter to next nibble.
//     (Default fill is equivalent to '-'.)
// 0 = On application, function will store a zero.
//     (Stores a zero in both na and nx.)
// 1 = On application, function will store a one.
//     (Stores a zero in na, and a one in nx.)
// - = On application, function will leave bit unchanged.
//     (Stores a one in na, and a zero in nx.)
//   = Anything else, skip.  This can be used for 
//     user-defined separators, etc.
let rec internal readAXFunc0 (s:string) 
                             (i:int) 
                             (p:int) 
                             (na:int)
                             (nx:int) = 
  match i>=0 with
  | false -> (na,nx)
  | true ->
      match s.[i] with
      | ':' -> readAXFunc0 s (i-1) (nextNibble p) na nx
      | '0' -> readAXFunc0 s (i-1) (p*2) (na&&&(~~~p)) nx 
      | '1' -> readAXFunc0 s (i-1) (p*2) (na&&&(~~~p)) (nx|||p)
      | '-' -> readAXFunc0 s (i-1) (p*2) na nx
      | _   -> readAXFunc0 s (i-1) p na nx 
      

// Syntactic helper for readAXFunc0.      
let internal readAXFunc (s:string) = 
  readAXFunc0 s (s.Length-1) 1 allSet allReset


// A "assembled" program instruction.
let internal fIns ((ta,tx):int*int) 
                  ((fa,fx):int*int) 
                  (nT:int) 
                  (nF:int) =
  match ((nT&&&ta)^^^tx)=0 with
  | true -> (nF&&&fa)^^^fx
  | false -> nF


// An external program instruction.
// Returns the "assembled" function.
let ins (sT:string) 
        (sF:string) = 
  fIns
    (readAXTest sT)
    (readAXFunc sF)


// As an action parameter, will set the halt bit. 
let halt = "1-------.--------.--------.--------"

// As a test parameter, will match anything. 
let any  = "--------.--------.--------.--------"
  

// Single-step a program. 
let step (l:(int->int->int) list)
         (nT:int)
         (nF:int) =
  List.fold (fun s t -> t nT s) nF l                  
  

// Run a program count steps or until
// a halt or trap state is encountered. 
let rec run (l:(int->int->int) list)
            (nF:int) 
            (count:int) =
  // Halt when: 1) count is exhausted.
  match count<=0 with
  | true -> (count,nF)
  | _ -> 
      // Halt when: 2) halt bit is set.
      match (nF&&&highSet)<>0 with
      | true -> (count,(nF&&&highReset))
      | _ -> 
          let nF0 = (step l nF nF)
          // Halt when: 3) state is trapped.
          match nF0=nF with
          | true -> (count,nF)
          // Otherwise, keep running.
          | _ -> run l nF0 (count-1)

The test:

open System
open BC32


let rec testProg0 p i n (f:int list->int list) =
  match i>1 with
  | false -> f [n]
  | _ -> testProg0 p (i-1) (step p n n) (fun n0->f (n::n0))
    
    
let testProg l i =
  testProg0 l i 0 (fun n0->n0)


let pCountTo15 =
  [
  (ins "---0" "---1" )
  (ins "---1" "---0" )
  
  (ins "--01" "--1-" )
  (ins "--11" "--0-" )
  
  (ins "-011" "-1--" )
  (ins "-111" "-0--" )
  
  (ins "0111" "1---" )
  (ins "1111" "0---" )
  ]
  

let result = testProg pCountTo15 18

printfn "Press any key to continue..."
Console.ReadLine() |> ignore

-Neil

A 32-Bit Computer in One Page of Code

I want to depart from the lofty world of semantic networks for a few posts, in order to investigate the world of bit-based computers. By bit-based computer, I mean one in which the entire state of the computer is based on an ordered set of bits. The computer I describe below was suggested by Digi-Comp I, a classic bit-based computer made almost entirely of plastic, but mine is based on a somewhat different design.

Both Digi-Comp I and the computer described below are Von Neumann machines, in the sense that the program memory and the working memory are separate. However, they both differ from more familiar computing devices in that the operation is based on modifying the state using simple production rules.

My implementation is a “32-bit” computer, in the sense that the bits are stored in a single 32-bit integer. I could have used some other storage format, say an array of Boolean values, but the use of a single integer both simplifies the implementation and provides a bit of challenge when writing programs. Because it’s a 32-bit, bit-based computer, I’m going to name it “32BC.” (See the last paragraph for this name as a pun.) The entire computer consists of a single 32-bit integer for working memory, a set of production rules, a simple computing engine, and some I/O stuff. In fact, the computer is so simple, the I/O comprises the bulk of the code.

The basic operation is as follows:

1) Test for a halt; if true goto step 5, else goto to step 2

2) Test the state against the “if” of all the rules.

3) For each of the rules that succeeds, apply the “then” portion of that rule to the state, and set that value as the state. Do this in the order in which the rules are listed.

Note that EVERY state is tested and (if true) applied on every program loop.

4) Goto step 1.

5) Halt and return.

The only thing left to do is to define the test and apply operations. In fact, they will be the same operation, only with different data. They are both based on the following particularly useful logic gate, where A and X are bits supplied by the program memory, and N is the bit from the program state. (Using 32-bit integers makes it easy to do these operations in parallel on all the bits).

As can be seen, the logic gate above can essentially compute any single-bit value.

We will consider a test to have succeeded if, after applying to this gate the program test bits (A0-A31, X0-X31) and the state bits (N0-N31), all of the bits are zero. The action is applied to the current state by applying the action bits from the program to the state bits, and then replacing the current state with the output.

And, except for the details (see F# code in the next post), that’s it.

What can this compute? Anything – anything – within its bit capacity. The production rules function as a “universal” computer in the sense that, if one is willing to write as many production rules as there are states, any possible state->state function can be computed. But that technique’s no fun (not to mention inefficient), the real fun comes from trying to write much smaller sets of production rules to accomplish a given task.

What good is it? Not much really, except as a mental exercise and as a demonstration. But what it does demonstrate is something very interesting:

The computer described above is simple enough to be encoded in very basic hardware. Not just in terms of electronic hardware, like on PLA-type device or as part of a larger circuit (where “mini-computers” like the one above are sometimes actually used). But it is even simple enough to implement – like Digi-Comp I – on “real” hardware, as in plastic, metal, wood, nuts and bolts.

Which prompts a thought: if the Greeks were able to produce, c.125 BC, a device as complex as the Antikythera mechanism, they could no doubt have managed a computer as simple as the one described here by 32 BC. In fact, my “32BC” is actually much simpler than the Antikythera mechanism. What if they had done so and gone on to produce all sorts of other mechanisms based on binary logic? How would the world look today?

-Neil

Next, source code. Hopefully today, if not, early tomorrow. (It depends on whether I decide to spend time today reviewing the code or doing my income taxes, lol.)

Thanks

I'd like to give a big thank you to Rick Minerich for mentioning me in his F# Discoveries This Week 03/26/2010. It's more honor than my little blog deserves, but I do thank him.

Also, I'd like to alert folks to the F# group on IRC at:

/server irc.freenode.org
/join ##fsharp

There can be found a great bunch of F# enthusiasts there who are happy to chat, answer questions, etc. In my brief time there, I've noticed that most questions are are answered in just a minute or two, either directly or with via web reference for more complex questions.

-Neil

Correction

The astute reader will have noticed an inefficiency in the previous search function. The continuation function is doing more work than it needs to do. Below is a better version. I marked the changes with four slashes (“////”). I hope this version is bug free; the astute reader is invited to point out any bugs or remaining inefficiencies.

As always, presented “as-is” and without warranty or implied fitness; use at your own risk.

module Searcher

open System.Collections.Generic


// This is the actual tail-recursive function.
// Note: not tail-recursive unless tail-call is turned on.
let rec internal search0<'a,'b> (fGetEnum:'a->IEnumerator<'a> option)
                                (fTest:'a->bool)
                                (enum:IEnumerator<'a>)
                                (fFail:unit->'a list) 
                                //(fSucceed:'a->'a list->'a list) =
                                (fSucceed:'a list->'a list) =
  // This function is a direct tail recursion 
  // for each item in a sequence.
  match enum.MoveNext() with
  | false -> fFail()
  | _ -> 
      let current = enum.Current
      // Test for goal node.
      match fTest current with
      ////| true -> fSucceed current []
      | true -> fSucceed [current]
      | false -> 
          // Test for child enumeration.
          // (Can user short circuit here.
          match (fGetEnum current) with 
          | None -> fFail()
          | Some(newEnum) ->
              // Direct tail recursion plus
              // a continuation tail recursion.
              // (Formatted for ease of reading.)
              (search0 
                fGetEnum
                fTest
                enum 
                (fun ()->
                   search0 
                     fGetEnum
                     fTest
                     newEnum 
                     fFail 
                     // Composition of list.
                     ////(fun a0 al->(fSucceed current (a0::al))))
                     (fun a0 ->(fSucceed (current::a0))))
                 fSucceed)

// Interface funcion.             
and search<'a,'b> (fGetEnum:'a->IEnumerator<'a> option)
                  (fTest:'a->bool)
                  (a:'a) =
  // Test on the root node here makes
  // search0 more straightforward.
  match fTest a with 
  | true -> [a]
  | false ->
      // Test for child enumeration.
      // (Can user short circuit here.
      match (fGetEnum a) with 
      | None -> []
      | Some(newEnum) ->  
          //// Added match and cons.
          match (search0 
                   fGetEnum
                   fTest
                   newEnum
                   (fun ()->[]) 
                   ////(fun a0 al->a::a0::al))            
                   (fun a0->a0)) with
          | [] -> []
          | l -> a::l

Improved Continutation Search

This one returns a list in the right order, and the example shows how to detect circularities. It's a little tricky; the tail recursion involves both a direct tail recursion and a continuation that results in a tail call. I had to run tests to convince myself it really wasn't eating up the stack, lol.

Next up: adding this to the semantic network code.

As always, presented without warranty or implied fitness. That and there may still be a bug or two or a simpler way of doing this.

The functions:

module Searcher

open System.Collections.Generic


// This is the actual tail-recursive function.
// Note: not tail-recursive unless tail-call is turned on.
let rec internal search0<'a,'b> (fGetEnum:'a->IEnumerator<'a> option)
                                (fTest:'a->bool)
                                (enum:IEnumerator<'a>)
                                (fFail:unit->'a list) 
                                (fSucceed:'a->'a list->'a list) =
  // This function is a direct tail recursion 
  // for each item in a sequence.
  match enum.MoveNext() with
  | false -> fFail()
  | _ -> 
      let current = enum.Current
      // Test for goal node.
      match fTest current with
      | true -> fSucceed current []
      | false -> 
          // Test for child enumeration.
          // (Can user short circuit here.
          match (fGetEnum current) with 
          | None -> fFail()
          | Some(newEnum) ->
              // Direct tail recursion plus
              // a continuation tail recursion.
              // (Formatted for ease of reading.)
              (search0 
                fGetEnum
                fTest
                enum 
                (fun ()->
                   search0 
                     fGetEnum
                     fTest
                     newEnum 
                     fFail 
                     // Composition of list.
                     (fun a0 al->(fSucceed current (a0::al))))
                 fSucceed)

// Interface funcion.             
and search<'a,'b> (fGetEnum:'a->IEnumerator<'a> option)
                  (fTest:'a->bool)
                  (a:'a) =
  // Test on the root node here makes
  // search0 more straightforward.
  match fTest a with 
  | true -> [a]
  | false ->
      // Test for child enumeration.
      // (Can user short circuit here.
      match (fGetEnum a) with 
      | None -> []
      | Some(newEnum) ->
          (search0 
            fGetEnum
            fTest
            newEnum
            (fun ()->[]) 
            (fun a0 al->a::a0::al))

Test:

open System.Collections.Generic


// A simple tree node based on a HashSet.
[<System.Diagnostics.DebuggerDisplayAttribute("{S}")>]
type Node (s:string) =
  
  let h = new HashSet<Node>()
  
  member this.Add n =
    h.Add(n) |> ignore
    this // Convenient chaining of adds.
  
  member this.H = h
  member this.S = s 


// This "safe" search uses a hash table 
// to detect circularity and returns 
// a None for the enumerator option.
let searchSafe =

  // Hash of visited nodes.
  let tested = new HashSet<Node>()
  
  // Returns child node enumerator iff
  // node has not already been considered.
  // Also marks unvisited nodes as visited.
  let fEnum (n:Node) =
    match tested.Add(n) with
    | false -> None
    | true -> Some(n.H.GetEnumerator():>IEnumerator<Node>)
  
  // Return a function.
  // (F# behavior means tested Hash will be cached.)
  (fun n s ->
    tested.Clear()  
    Searcher.search 
      fEnum
      (fun (n:Node)->n.S=s)
      n)


// Test it. 
// (Formatted for blog width.)

let n11 = (Node "n11").Add(Node "n110").Add(Node "n111")
let n10 = (Node "n10").Add(Node "n100").Add(Node "n101")
let n01 = (Node "n01").Add(Node "n010").Add(Node "n011")
let n00 = (Node "n00").Add(Node "n000").Add(Node "n001")
let n1  = (Node "n1").Add(n10).Add(n11)
let n0  = (Node "n0").Add(n00).Add(n01)
let n   = (Node "n").Add(n0).Add(n1) 


let l     = searchSafe n "n"
let l011  = searchSafe n "n011"
let l01x  = searchSafe n "n01x"

printfn "Your breakpoint here!"  

Search Using Continuations

Here's my first pass at a search using continuations. This is my first non-trivial implementation of continuations! It may not be the simplest way to do this, and it still returns a list in the opposite order from that which I want, but it's a start. I even made it generic. (Note: this version is only for acyclic graphs; this will be fixed in the next version.)

As always, presented without warranty or implied fitness. That and there may still be a bug or two.

p.s. The name "SeqTryPick" is an anachronism from experiments involving Seq; it will be changed in the next version.

open System
open System.Collections.Generic


[<System.Diagnostics.DebuggerDisplayAttribute("{S}")>]
type Bob (s:string) =
  
  let h = new HashSet<Bob>()
  
  member this.Add b =
    h.Add(b) |> ignore
    this
  
  member this.H = h
  member this.S = s 
  

let rec internal SeqTryPick0<'a,'b> (fe:'a->IEnumerator<'a>)
                                    (ft:'a->bool)
                                    (e:IEnumerator<'a>)
                                    (ff:unit->'a list) 
                                    (fs:'a list->'a list) =
  match e.MoveNext() with
  | false -> ff()
  | _ -> 
      let c = e.Current
      match ft c with
      | true -> c::fs([])
      | false -> 
          (SeqTryPick0 
            fe
            ft
            e 
            (fun ()->
               SeqTryPick0 
                 fe
                 ft
                 (fe c) 
                 ff 
                 (fun s->c::fs(s)))
             fs)
             
and SeqTryPick<'a,'b> (fe:'a->IEnumerator<'a>)
                      (ft:'a->bool)
                      (a:'a) =
  match ft a with 
  | true -> [a]
  | false ->
      SeqTryPick0 
        fe
        ft
        (fe a) 
        (fun ()->[]) 
        (fun a0->a::a0)  

let b =
  (Bob "b").Add(
    (Bob "b0").Add(
      (Bob "b00").Add((Bob "b000")).Add((Bob "b001"))).Add(
      (Bob "b01").Add((Bob "b010")).Add((Bob "b011")))).Add(
    (Bob "b1").Add(
      (Bob "b10").Add((Bob "b100")).Add((Bob "b101").Add((Bob "b1010")).Add((Bob "b1011")))).Add(
      (Bob "b11").Add((Bob "b110")).Add((Bob "b111")))) 
    
let x = 
  SeqTryPick 
    (fun (b:Bob)->(b.H.GetEnumerator():>IEnumerator<Bob>)) 
    (fun (b:Bob)->b.S="b1011")
    b

Console.ReadLine() |> ignore

Semantic Net Search 0.1

Here is the latest; a step towards deep search.

I decided to implement the search using an auxiliary class. This allows the network itself to remain more pure, with details such as the transitivity of links being a function of the search rather than the structure. (The epistemological implications of this are intriguing.)

I did augment the network with a dictionary which stores a table of the last item in a relationship keyed by the first item and the link. This is for efficiency only; it could also have been accomplished using the existing Find function.

Lastly, my first attempt at a search function is rather grim, messy, and imperative. It works, but I’m not proud of it. I tried to construct a version based on continuations, but it defeated my resolve to get something that at least worked posted to the blog today. Watch for a cleaner, more functional version in the next blog post or two. Until then, consider it an example of an anti-pattern, lol.

As always, no warranties or implied fitness. Use at your own risk. I rushed to post this, so there may be bugs.

Library:

module SemanticNet

open System.Collections.Generic


// I'm a fool for syntactic sugar.
type internal Rel       = string*string*string
type internal RelHash   = HashSet<Rel>
type internal RelDict   = Dictionary<string,RelHash>
type internal FinderVal = bool*(RelHash option)
type internal RelChain  = Dictionary<(string*string),HashSet<string>>



// Computation expression builder for finds.
type internal RelFinder () =

  // "let!" function.
  member this.Bind (((b,h):FinderVal),
                    (f:FinderVal->FinderVal)) =
    match b with 
      | true -> f (b,h)
      | _ -> (b,h)

  // "return" function.
  member this.Return bh = bh



// Holds the relationships.
type Graph () =

  // Holds all the relationships.
  let relHash = new RelHash()

  // Holds all the relationships as chains.
  // Supports deep search.
  let relChain = new RelChain()

  // Maps a node in each position 
  // to the relationships for that node.
  let n0ToRelHash = new RelDict()
  let n1ToRelHash = new RelDict()
  let n2ToRelHash = new RelDict()

  // Computation expression builder for finds.
  let relFinder = RelFinder()
  
  // Internal function for finds.
  let relFinderComp (d:RelDict) 
                    (so:string option) 
                    (bhi:FinderVal) =
    match so with 
    | None -> bhi
    | Some(s) ->
        match d.TryGetValue s with
        | (true,h) -> 
            match bhi with 
            // Copy the first hash found.
            | (true,None) -> (true,Some(RelHash(h)))
            | (true,Some(hi)) ->
                hi.IntersectWith(h)
                (true,Some(hi))
            | _ -> failwith "Internal program error."
        | _ -> (false,None)

//  // For a slightly more efficient first call, 
//  // this can be used.
//      
//  let relFinderCompFst (d:RelDict) 
//                       (so:string option) =
//    match so with 
//    | None -> (true,None)
//    | Some(s) ->
//        match d.TryGetValue s with
//        | (true,h) -> (true,Some(RelHash(h)))
//        | _ -> (false,None)
  
  // Add a relationship to a dictionary. 
  let tryAddRel (d:RelDict) k r =
    match d.TryGetValue k with
    | (true,h) -> 
        h.Add r |> ignore
    | _ -> 
        let h = new RelHash()
        h.Add r |> ignore
        d.Add(k,h)
  
  // Add a relationship to the chain dictionary. 
  let tryAddRelChain (s0,s1,s2) =
    (match relChain.TryGetValue((s0,s1)) with
      | (true,h) -> h
      | _ ->
          let h = HashSet<string>()
          relChain.Add((s0,s1),h)
          h).Add s2 |> ignore
  
  // Remove a relationship from a dictionary. 
  let tryRemoveRel (d:RelDict) k r =
    match d.TryGetValue k with
    | (true,h) -> 
        let rmv = h.Remove r 
        // Clean up empty entries.
        if (h.Count=0) then d.Remove k |> ignore
        //rmv 
    | _ -> ()
  
  // Add a relationship to the chain dictionary. 
  let tryRemoveRelChain (s0,s1,s2) =
    match relChain.TryGetValue((s0,s1)) with
    | (true,h) -> 
        let rmv = h.Remove s2
        // Clean up empty entries.
        if (h.Count=0) then relChain.Remove((s0,s1)) |> ignore
        //rmv
    | _ -> ()
          
  // Add a relationship.
  member this.Add r =
    match relHash.Add r with
    | false -> ()
    | _ -> 
        let (s0,s1,s2) = r
        tryAddRelChain (s0,s1,s2) |> ignore
        tryAddRel n0ToRelHash s0 r 
        tryAddRel n1ToRelHash s1 r 
        tryAddRel n2ToRelHash s1 r 
  
  // Add a bunch of relationships.
  member this.Add (e:IEnumerable<Rel>) =
    for r in e do
      this.Add r 
  
  // Return a hash of all relationships.      
  member this.All =  
    RelHash(relHash)
  
  // Return true if a relationship exists.      
  member this.Exists r =  
    relHash.Contains r
  
  // Return a hash option of the matched relationships.
  // Note: Uses string option; None acts as a wildcard in Find.
  member this.Find (s0,s1,s2) =
    match 
      (relFinder {
        // // See note above.
        // let! r0 = relFinderCompFst n0ToRelHash s0 
        let! r0 = relFinderComp n0ToRelHash s0 (true,None)
        let! r1 = relFinderComp n1ToRelHash s1 r0
        return    relFinderComp n2ToRelHash s2 r1 }) with
    // Three wildcards.
    | (true,None) -> Some(RelHash(relHash))
    // Something found.
    | (true,h) -> h
    // Nothing found.
    | _ -> None
  
  // Return a hash option of the matched conclusions.
  // More efficient than Find(s0,s1,s2) with wildcard.
  member this.Find (s0,s1) =
    relChain.TryGetValue((s0,s1))
  
  // Return a hash option of the matched relationships.
  // Note: Uses strings; explicit wildcard.
  member this.FindW w (s0,s1,s2) =
    this.Find (
      (if s0=w then None else Some(s0)),
      (if s1=w then None else Some(s1)),
      (if s2=w then None else Some(s2)))
  
  // Remove a relationship.
  member this.Remove r =
    match relHash.Remove r with
    | true -> 
        let (s0,s1,s2) = r
        tryRemoveRelChain (s0,s1,s2) 
        tryRemoveRel n0ToRelHash s0 r 
        tryRemoveRel n1ToRelHash s1 r 
        tryRemoveRel n2ToRelHash s2 r 
    | _ -> ()
  
  // Remove a bunch of relationships.
  member this.Remove (e:IEnumerable<Rel>) =
    for r in e do
      this.Remove r 
  
  // + operator adds a relationship, returns graph.      
  static member (+) ((g:Graph),(r:Rel)) =
    g.Add r 
    g
  
  // - operator removes a relationship, returns graph.      
  static member (-) ((g:Graph),(r:Rel)) =
    g.Remove r 
    g



// Abstract interface for a searcher.
[<AbstractClass>]
type SearcherBase () =
  //abstract member Search: Graph -> Rel -> bool
  abstract member Search: Graph -> Rel -> Rel list



// A simple searcher.
type SimpleSearcher () =
  inherit SearcherBase()

  // Used to prevent cycling.
  let tested = new HashSet<string>() 

  // Indicates transitive links.
  let transitive =
    let transHash = new HashSet<string>()
    transHash.Add "isA"  |> ignore
    transHash.Add "hasA" |> ignore
    (fun s -> transHash.Contains(s))

  // Search internal.
  let rec searchDeep (gs:Graph) ((s0,s1,s2):Rel) =
    match tested.Add(s0) with 
    | false -> None
    | true ->
        match gs.Exists (s0,s1,s2) with
        | true -> Some([(s0,s1,s2)])
        | _ ->
            match gs.Find(s0,s1) with
            | (false,_) -> None
            | (_,h) ->
              let mutable e = h.GetEnumerator()
              let mutable l = true
              let mutable rtn = None
              while l && (e.MoveNext()) do
                match searchDeep gs (e.Current,s1,s2) with
                | None -> ()
                | Some(l1) -> 
                    l <- false
                    rtn <- Some((s0,s1,e.Current)::l1)
              rtn

  // Search interface.
  override this.Search (gs:Graph) (r:Rel) =
    let (_,s1,_) = r
    match transitive s1 with
    | true -> 
        tested.Clear()
        match searchDeep gs r with
        | None -> []
        | Some(l) -> l
    | _ -> 
        match gs.Exists r with
        | true -> [r]
        | _ -> []

Test:

open SemanticNet

// Create a graph and 
// add some relationships.

let g = 
  Graph() + 
  ("mammal","isA",       "animal") + 
  ("insect","isA",       "animal") + 
  ("dog",   "isA",       "mammal") + 
  ("flea",  "isA",       "insect") + 
  ("dog",   "isA",       "pet")    + 
  ("dog",   "hasA",      "tag")    + 
  ("chow",  "isA",       "dog")    + 
  ("dog",   "scratches", "flea")    + 
  ("flea",  "scratches", "itch")    + 
  ("cat",   "isA",       "pet") 

let simpleSearch = (SimpleSearcher()).Search g
  
// Search.

let l0 = simpleSearch ("chow","isA",      "dog")
let l1 = simpleSearch ("chow","isA",      "animal")
let l2 = simpleSearch ("chow","isA",      "sasquatch")
let l3 = simpleSearch ("dog", "scratches","itch")
let l4 = simpleSearch ("flea", "isA",     "animal")
let l5 = simpleSearch ("flea", "isA",     "mammal")

printfn "All done!"

Yet Another Semantic Network

I know I keep complaining about being tired of building semantic networks in F#, but here’s another one. This one, I hope, is the most F#-like yet. I even managed to use a computation expression! Next up, I’ll add better search capabilities.

As always, no warranties or implied fitness; use at your own risk. Formatted for blog width.

Code:

module SemanticNet

open System.Collections.Generic


// I'm a fool for syntactic sugar.
type internal Rel       = string*string*string
type internal RelHash   = HashSet<Rel>
type internal RelDict   = Dictionary<string,RelHash>
type internal FinderVal = bool*(RelHash option)


// Holds the relationships.
type Graph () =

  // Holds all the relationships.
  let relHash = new RelHash()

  // Maps a node in each position 
  // to the relationships for that node.
  let n0ToRelHash = new RelDict()
  let n1ToRelHash = new RelDict()
  let n2ToRelHash = new RelDict()

  // Computation expression builder for finds.
  let relFinder = RelFinder()
  
  // Internal function for finds.
  let relFinderComp (d:RelDict) 
                    (so:string option) 
                    (bhi:FinderVal) =
    match so with 
    | None -> bhi
    | Some(s) ->
        match d.TryGetValue s with
        | (true,h) -> 
            match bhi with 
            // Copy the first hash found.
            | (true,None) -> (true,Some(RelHash(h)))
            | (true,Some(hi)) ->
                hi.IntersectWith(h)
                (true,Some(hi))
            | _ -> failwith "Internal program error."
        | _ -> (false,None)

//  // For a slightly more efficient first call, 
//  // this can be used.
//      
//  let relFinderCompFst (d:RelDict) 
//                       (so:string option) =
//    match so with 
//    | None -> (true,None)
//    | Some(s) ->
//        match d.TryGetValue s with
//        | (true,h) -> (true,Some(RelHash(h)))
//        | _ -> (false,None)
  
  // Add a relationship to a dictionary. 
  let tryAddRel (d:RelDict) k r =
    match d.TryGetValue k with
    | (true,h) -> 
        h.Add r |> ignore
    | _ -> 
        let h = new RelHash()
        h.Add r |> ignore
        d.Add(k,h)
  
  // Remove a relationship from a dictionary. 
  let tryRemoveRel (d:RelDict) k r =
    match d.TryGetValue k with
    | (true,h) -> 
        let rmv = h.Remove r 
        // Clean up empty hash tables.
        if (h.Count=0) then d.Remove k |> ignore
        rmv
    | _ -> false
  
  // Add a relationship.
  member this.Add r =
    match relHash.Add r with
    | false -> r
    | _ -> 
        let (s0,s1,s2) = r
        tryAddRel n0ToRelHash s0 r 
        tryAddRel n1ToRelHash s1 r 
        tryAddRel n2ToRelHash s1 r 
        r
  
  // Add a bunch of relationships.
  member this.Add (e:IEnumerable<Rel>) =
    for r in e do
      this.Add r |> ignore
  
  // Return a hash of all relationships.      
  member this.All =  
    RelHash(relHash)
  
  // Return true if a relationship exists.      
  member this.Exists r =  
    relHash.Contains r
  
  // Return a hash option of the matched relationships.
  // Note: Uses string option; None acts as a wildcard in Find.
  member this.Find (s0,s1,s2) =
    match 
      (relFinder {
        // // See note above.
        // let! r0 = relFinderCompFst n0ToRelHash s0 
        let! r0 = relFinderComp n0ToRelHash s0 (true,None)
        let! r1 = relFinderComp n1ToRelHash s1 r0
        return    relFinderComp n2ToRelHash s2 r1 }) with
    // Three wildcards.
    | (true,None) -> Some(RelHash(relHash))
    // Something found.
    | (true,h) -> h
    // Nothing found.
    | _ -> None
  
  // Return a hash option of the matched relationships.
  // Note: Uses strings; explicit wildcard.
  member this.FindW w (s0,s1,s2) =
    this.Find (
      (if s0=w then None else Some(s0)),
      (if s1=w then None else Some(s1)),
      (if s2=w then None else Some(s2)))
  
  // Remove a relationship.
  member this.Remove r =
    match relHash.Remove r with
    | true -> 
        let (s0,s1,s2) = r
        tryRemoveRel n0ToRelHash s0 r |> ignore
        tryRemoveRel n1ToRelHash s1 r |> ignore
        tryRemoveRel n2ToRelHash s2 r |> ignore
        true 
    | _ -> false
  
  // Remove a bunch of relationships.
  member this.Remove (e:IEnumerable<Rel>) =
    for r in e do
      this.Remove r |> ignore
  
  // + operator adds a relationship, returns graph.      
  static member (+) ((g:Graph),(r:Rel)) =
    g.Add r |> ignore
    g
  
  // - operator removes a relationship, returns graph.      
  static member (-) ((g:Graph),(r:Rel)) =
    g.Remove r |> ignore
    g


// Computation expression builder for finds.
and internal RelFinder () =

  // "let!" function.
  member this.Bind (((b,h):FinderVal),
                    (f:FinderVal->FinderVal)) =
    match b with 
      | true -> f (b,h)
      | _ -> (b,h)

  // "return" function.
  member this.Return bh = bh

And test:

open SemanticNet

let g0 = Graph()

// Add some relationships.

g0 + 
  ("mammal","isA", "animal") + 
  ("dog",   "isA", "mammal") + 
  ("dog",   "isA", "pet")    + 
  ("dog",   "hasA","tag")    + 
  ("cat",   "isA", "pet")    |> ignore

// Sundry experiments.

let h0 = g0.Find(None,(Some "isA"),(Some "pet")) 
let h1 = g0.Find((Some "dog"),None,None) 

g0 - ("cat","isA","pet") |> ignore

let h2 = g0.Find(None,(Some "isA"),(Some "pet")) 

g0 + ("cat","isA","pet") |> ignore

let h3 = g0.Find(None,(Some "isA"),(Some "pet"))

let b0 = g0.Exists("cat","isA","pet")
let b1 = g0.Exists("tiger","isA","pet") 

let find = g0.FindW ""

let h4 = find("dog","","")

if h4.IsSome then g0.Remove h4.Value 

let h5 = find("dog","","")

printfn "All done!"

Latest Semantic Net Experiment

Here it is, the latest and most complex experiment. I'm not sure I'll keep going with this. So far, it does what I intended it to do, but the implementation is shaping up to be way more object-oriented and way less functional than I wanted. And since the whole point here is to learn F# (and especially its use in creating custom languages), I think I may try something else for a change. Perhaps a unification system?

As usual, presented as a learning exercise without warranty or implied fitness; use at your own risk. Also as usual, formatted for the blog window (I have a twin horror of code wrap and horizontal scrolling, lol.)

Main module (test code below):

module SemanticNet

open System.Collections.Generic 


let internal findOrNew<'k,'v> (ff:'k->bool*'v) 
                              (fn:unit->'v)
                              (fa:'k*'v->unit)
                              (k:'k) =
  match ff k with
  | (true,v) -> v
  | (false,_) ->
      let v = fn()
      fa(k,v)
      v
  
        
let internal findOrNewD<'k,'v> (d:Dictionary<'k,'v>)
                               (fn:unit->'v)
                               (k:'k) =
  findOrNew d.TryGetValue fn d.Add k 


let internal findOrNone<'k,'v> (ff:'k->bool*'v) 
                               (k:'k) =
  match ff k with
  | (true,v) -> Some(v)
  | _ -> None
  
        
let internal findOrNoneD<'k,'v> (d:Dictionary<'k,'v>)
                                (k:'k) =
  findOrNone d.TryGetValue k 



type Entity (graph:Graph, key:string) = 
  member this.Graph = graph
  member this.Key = key



and Link (graph:Graph, key:string) =
  inherit Entity(graph,key)
  
  
  
and LinksOut (nodeIn:Node, link:Link) = 
  
  let nodesOut = new Dictionary<string,Node>()
  
  let newNodeOut nodeKey =
    let nodeOut:Node = nodeIn.Graph.Node nodeKey 
    nodeOut.AddIn link.Key nodeIn 
    nodeOut 
  
  member this.Node (nodeOutKey:string) =
    findOrNewD nodesOut 
               (fun()->(newNodeOut nodeOutKey)) 
               nodeOutKey // Node
  
  member this.Nodes (nodeOutKeys:string list) =
    match nodeOutKeys with 
    | [] -> nodeIn.Graph
    | h::t ->
        this.Node h |> ignore
        this.Nodes t

  member this.TestWrite (p:string->unit) =
    p ("  "+link.Key+"\n")
    for node in nodesOut.Values do
      p ("    "+node.Key+"\n")
    
  static member (+) ((this:LinksOut),
                     (nodeKey:string)) =
    (this.Node nodeKey).Graph
    
  static member (+) ((this:LinksOut),
                     (nodeKeys:string list)) =
    this.Nodes nodeKeys
    
    
    
and LinksIn (nodeOut:Node, link:Link) = 
  
  let nodesIn = new Dictionary<string,Node>()
  
  member internal this.Node (nodeIn:Node) =
    if not (nodesIn.ContainsKey nodeIn.Key) then
      nodesIn.Add(nodeIn.Key,nodeIn)
 
    
    
and Node (graph:Graph, key:string) =
  inherit Entity(graph,key)
  
  let linksOut = new Dictionary<string,LinksOut>()  
  let linksIn  = new Dictionary<string,LinksIn>() 
  
  member internal this.AddIn (linkInKey:string) (nodeIn:Node) =
    ((findOrNewD linksIn 
                 (fun()->(graph.LinksIn this linkInKey)) 
                 linkInKey).Node nodeIn) |> ignore
  
  member this.Link (linkOutKey:string) =
    findOrNewD linksOut 
               (fun()->(graph.LinksOut this linkOutKey)) 
               linkOutKey // Links
  
  member this.Links ((linkOutKey:string),(nodeOutKeys:string list)) =
    (findOrNewD linksOut 
                (fun()->(graph.LinksOut this linkOutKey)) 
                linkOutKey).Nodes  nodeOutKeys |> ignore
    this // Node
        
  member this.TestWrite (p:string->unit) =
    p (key+"\n")
    for links in linksOut.Values do
      links.TestWrite p
    
  static member (+) ((this:Node),
                     (linkOutKey:string)) =
    this.Link linkOutKey
  
  static member (+) ((this:Node),
                     (linkNodeOut:string*string list)) =
    this.Links linkNodeOut



and Graph () =

  let links = new Dictionary<string,Link>()
  let nodes = new Dictionary<string,Node>()
  
  member internal this.Link linkKey =
    findOrNewD links 
               (fun()->Link(this,linkKey)) linkKey // Link

  member internal this.LinksIn node linkKey =
    LinksIn(node,(this.Link linkKey))

  member internal this.LinksOut node linkKey =
    LinksOut(node,(this.Link linkKey))

  member this.Node nodeKey =
    findOrNewD nodes 
               (fun()->Node(this,nodeKey)) 
               nodeKey // Node 

  member this.TestWrite (p:string->unit) =
    for node in nodes.Values do
      node.TestWrite p
    
  static member (+) ((this:Graph),(nodeKey:string)) =
    this.Node nodeKey
  

Test code:

open System 
open SemanticNet


let g = Graph()

g+"dog"+
  ("isA",["canine";"man's best friend";"pet"])+ 
  ("hasA",["leash";"collar"]) |> ignore
  
g+"mammal"+"isA"+"animal" |> ignore
g+"canine"+"isA"+"mammal" |> ignore
g+"man's best friend"+"isA"+"dog" |> ignore

g.TestWrite (fun s->Console.Write(s))  

Console.ReadLine() |> ignore

Data-Driven Semantic Network

Here's a super-simple version of a basic semantic network using only strings. There's not much it couldn't be extended to do. However, using only strings in this way is likely to be sub-optimal. For example, when we follow a link from one node to another, in order to go any further we have to do a second lookup, etc.

But I have to say I'm not as displeased with the look and feel of the string version as I had thought I would be, so I think this is the version I'll extend.

Standard disclaimers: as-is, no warranty or implied fitness, use at your own risk.

open System.Collections.Generic 


type Rel () =

  let store = 
    new Dictionary<string,Dictionary<string,HashSet<string>>>()
    
  member private this.TryAdd 
    ((n0,l,n1):string*string*string) = 
    let d = 
      match store.TryGetValue n0 with 
      | (true,d0) -> d0
      | (false,_) ->
          let d0 = new Dictionary<string,HashSet<string>>()
          store.Add(n0,d0)
          d0
    let h =
      match d.TryGetValue l with 
      | (true,h0) -> h0
      | (false,_) ->
          let h0 = new HashSet<string>()
          d.Add(l,h0)
          h0
    h.Add n1 |> ignore
    
  static member (+=) 
    ((r:Rel),((nln):string*string*string)) =
    r.TryAdd nln
    r
  
    
let r = Rel()
 
r += ("mammal","isA","animal") |> ignore
r += ("dog","isA","mammal") |> ignore
r += ("spot","isA","dog") += ("spot","isA","pet") |> ignore

Reified Semantic Network

Continuing on the path of using classic A.I. tutorial examples to teach myself F#, here is an example using semantic networks. So I created a system in which basic semantic nodes and links can be reified into object instances.

This approach has its pluses and minuses.

On the plus side, F# operator definition makes for a very clean, declarative semantic program. The fact that nodes and links have become instances also makes the code fairly straightforward and efficient.

On the minus side, extending the system at runtime would entail the use of reflection. Also, there is not simple repository for the entities that we can treat as a first class entity, meaning that things like reflection become more difficult and may entail reflection.

So, before going any further and adding things like search, I’ll present this version and then follow up with a version in which entities are represented as data. Then, I’ll pick one and move forward.

Standard disclaimer: presented without warranty or implied suitability of any kind, use at your own risk. And, as always, this is formatted for my narrow blog window, and I present it as a learning exercise, not necessarily either the best way to do F# or the best way to do A.I.

open System.Collections.Generic 


[<AbstractClass>]
type Entity (key:string) =
  
  member this.Key = key



type Link (key:string) =
  inherit Entity(key)



type Node (key:string) =
  inherit Entity(key)

  let links = new Dictionary<Link,HashSet<Node>>()
  let props = new Dictionary<Node,HashSet<Node>>()
      
  member private this.TryAdd<'a> 
    (d:Dictionary<'a,HashSet<Node>>) a =
    match d.TryGetValue a with
      | (false,_) -> 
          let h = new HashSet<Node>()
          d.Add(a,h)
          h
      | (true,h) -> h
      
  member private this.TrySub<'a> 
    (d:Dictionary<'a,HashSet<Node>>) a n =
    match d.TryGetValue a with
      | (false,_) -> false
      | (true,h) -> 
          let rtn = h.Remove n
          if (h.Count=0) then 
            h.Clear()
            d.Remove(a) |> ignore 
          true
      
  member private this.TryClear<'a> 
    (d:Dictionary<'a,HashSet<Node>>) a =
    match d.TryGetValue a with
      | (false,_) -> false
      | (true,h) -> 
          h.Clear()
          d.Remove(a) |> ignore 
          true
      
  member private this.Add ((l,n):Link*Node) =
    (this.TryAdd links l).Add n |> ignore
    this
      
  member private this.Add ((l:Link),(nl:Node list)) =
    match nl with 
    | [] -> this
    | h::t ->
      (this.TryAdd links l).Add h |> ignore
      this.Add(l,t)
      
  member private this.Add ((n0,n1):Node*Node) =
    (this.TryAdd props n0).Add n1 |> ignore
    this
      
  member private this.Sub ((l,n):Link*Node) =
    this.TrySub links l n |> ignore
    this
      
  member private this.Sub ((n0,n1):Node*Node) =
    this.TrySub props n0 n1 |> ignore
    this
      
  member private this.Sub (l:Link) =
    this.TryClear links l |> ignore
    this
      
  member private this.Sub (n:Node) =
    this.TryClear props n |> ignore
    this
      
  static member (+=) ((n:Node),(ln:Link*Node)) =
    n.Add ln
    
  static member (+=) 
    ((n:Node),((l,nl):Link*(Node list))) =
    n.Add(l,nl)
    
  static member (+=) ((n:Node),(nn:Node*Node)) =
    n.Add nn
      
  static member (-=) ((n:Node),(ln:Link*Node)) =
    n.Sub ln
    
  static member (-=) ((n:Node),(nn:Node*Node)) =
    n.Sub nn
      
  static member (-=) ((n:Node),(l:Link)) =
    n.Sub l
      
  static member (-=) ((n0:Node),(n1:Node)) =
    n0.Sub n1
    
    

let isA  = Link "isA" 
let hasA = Link "hasA" 

let animal    = Node "animal"     
let canine    = Node "dog"  
let color     = Node "color" 
let gray      = Node "gray"
let mammal    = Node "mammal"     
let name      = Node "name"     
let pet       = Node "pet"  
let spot      = Node "spot"  
let tail      = Node "tail"  
let wine      = Node "wine"  
let white     = Node "white"  
let wolfie    = Node "wolfie"  

white += (isA,[color;name;wine]) |> ignore

white -= (isA,name) -= (isA,wine) |> ignore

gray += (isA,color) |> ignore

mammal += (isA,animal) |> ignore

canine += (isA,mammal) += (hasA,tail) |> ignore

spot 
  += (isA,canine) 
  += (color,white) 
  += (isA,pet) |> ignore

wolfie += (isA,canine) |> ignore
wolfie += (color,gray+=(isA,color)) |> ignore

Here's Something Surprising

One of the most fun things about F# is the surprises it holds. For example, I learned that one can "banana clip" a function on input to another function. I'd like to say it was unexpected, but I learned about it by coming up with the idea and then trying it to see whether it would work. Still I was surprised that it did work. I don't really know of any good application for which this is "just right," but I'll keep looking.

Here's a minimal example using options, but it also works with parameterized patterns, etc.

let f (|A|_|) =
  match None with
  | A -> printfn "Some()"
  | _ -> printfn "None"

f (fun _ -> None)
f (fun _ -> Some())

(Standard disclaimers, no warranties, etc.)

Next Step in the Tiny Expert System?

Here, just for fun, is the bare beginning of a tiny expert system using active patterns. I have no clue how it will progress from here.

(As always, standard disclaimers apply, use at your own risk, etc.)

open System  // For query ReadKey only.


/// <summary>Query helper.</summary>     
let rec internal GetQuery q = 
  printf "%s (y/n) " q
  let key = Console.ReadKey().KeyChar
  printfn ""
  match key with 
    | 'y' | 'Y' -> Some()
    | 'n' | 'N' -> None
    | _ -> GetQuery q

let black  = lazy ( GetQuery ("Is it a black?") ) 
let orange = lazy ( GetQuery ("Is it a orange?") )
let white  = lazy ( GetQuery ("Is it a white?") )

let (|Black|_|)  _ = black.Value
let (|Orange|_|) _ = orange.Value
let (|White|_|)  _ = white.Value
  
let x a = 
  match a with 
    | Black & Orange -> a+" is a tiger."    
    | Black & White  -> a+" is a zebra."    
    | _              -> a+" is a sasquatch."  
  
let y a = 
  match a with 
    | Black & Orange -> a+" is a tiger."    
    | Black & White  -> a+" is a zebra."    
    | _              -> a+" is a sasquatch."  
       

printfn "%s" (x "Rover")
printfn "%s" (y "Rover")

Console.ReadLine() |> ignore

Recap of Tiny Expert System

Before I move on, let me post a re-do of the the original lazy-evaluated style tiny expert system, incorporating all I've learned about F# over the last couple of weeks. I like this approach. It's a little less sophisticated than the object-oriented versions, but it embodies what I find attractive about F#: simple, direct code that looks like what it does.

(Again, standard disclaimers apply, use at your own risk, etc.)

type Query =
  | Yes
  | No
  | Unknown
  

let Conjoin q0 q1 =
  match q0 with
    | Query.No -> Query.No
    | Query.Yes -> q1
    | _ -> match q1 with 
             | Query.No -> Query.No
             | _ -> Query.Unknown
  

let Disjoin q0 q1 =
  match q0 with
    | Query.Yes -> Query.Yes
    | Query.No -> q1
    | _ -> match q1 with 
             | Query.Yes -> Query.Yes
             | _ -> Query.Unknown
  

let Negate q0 =
  match q0 with
    | Query.Yes -> Query.No
    | Query.No -> Query.Yes
    | _ -> q0
  

let rec Junction (fc:Query->Query->Query) 
                 (ft:Query->bool)
                 (lq:Lazy<Query> list) =
  match lq with
    | [] -> Query.Unknown
    | h::[] -> h.Value 
    | h::t -> 
        match ft h.Value with
          | true -> h.Value
          | _ -> fc h.Value
                    (Junction fc ft t) 
    
    
let rec Conjunction (lq:Lazy<Query> list) =
  Junction Conjoin (fun h->h=Query.No) lq 
    
    
let rec Disjunction (lq:Lazy<Query> list) =
  Junction Disjoin (fun h->h=Query.Yes) lq 
    
    
let rec All (lq:Lazy<Query> list) =
  Junction Disjoin (fun h->false) lq 
    
    
let rec Not (lq:Lazy<Query>) = lazy (
  Negate lq.Value)


let rec internal GetQuery q = 
  printf "%s (y/n/u) " q
  let key = Console.ReadKey().KeyChar
  printfn ""
  match key with 
    | 'y' | 'Y' -> Query.Yes
    | 'n' | 'N' -> Query.No
    | 'u' | 'U' -> Query.Unknown
    | _ -> GetQuery q


let black       = lazy ( GetQuery "Is it black?" )
let orangeColor = lazy ( GetQuery "Is it orange?" )
let white       = lazy ( GetQuery "Is it white?" )

let orange = lazy ( 
  Disjunction [
    orangeColor;
    lazy ( GetQuery "Is it an orange?" )])

let blackAndWhite = lazy ( 
  Conjunction [
    black;
    white])

let blackAndOrange = lazy ( 
  Conjunction [
    black;
    orange])

let blackAndWhiteAndOrange = lazy ( 
  Conjunction [
    black;
    white;
    orange])

let blackAndWhiteOnly = lazy ( 
  Conjunction [
    blackAndWhite;
    (Not orange)])

let blackAndOrangeOnly = lazy ( 
  Conjunction [
    blackAndOrange;
    (Not white)])

let color = lazy ( 
  All [
    blackAndWhite;
    blackAndOrange; 
    blackAndWhiteAndOrange; 
    blackAndWhiteOnly; 
    blackAndOrangeOnly])


color.Value |> ignore

Here is the next, and possibly final, installment in this series. It adds quite a bit, including the ability to estimate current certainty for an hypothesis without seeking further proof. However, it has moved quite far afield from my original intent.

I started this series hoping to learn a bit more about F#, and in particular, about F# as a platform for creating domain and application-specific systems. It was my first attempt at an F# program of more than a few lines. It had a good beginning, but as it grew up, it developed into something more conventionally object-oriented. Fortunately, I was able to learn a lot about the syntax and other basics of F#.

But the time has come to return, and seek some other feature of F# (just as “lazy” was the genesis of this series), and learn more about the F# way of doing things. In the meantime, here is the final installment. Standard caveats apply: not thoroughly error checked, use at your own risk, formatted for blog display, etc.

open System  // For query ReadKey only.


/// <summary>Ternary query value.</summary>   
type Query =
  | Yes
  | No
  | Unknown
    
    
/// <summary>Query helper.</summary>   
/// <remarks>Gets yes/no/unknown.</summary>   
let rec internal GetQuery q = 
  printf "%s (y/n/u) " q
  let key = Console.ReadKey().KeyChar
  printfn ""
  match key with 
    | 'y' | 'Y' -> Query.Yes
    | 'n' | 'N' -> Query.No
    | 'u' | 'U' -> Query.Unknown
    | _ -> GetQuery q
    
    
/// <summary>Degree of certainty.</summary>   
type Certainty = 
  | Impossible =   0
  | Unlikely   =  25
  | Possible   =  50
  | Likely     =  75 
  | Certain    = 100

    
/// <summary>Conjoin Certainty.</summary>   
let Conjoin (c0:Certainty)
            (c1:Certainty) = 
  match (c0<c1) with 
    | true  -> c0 
    | false -> c1
    
    
/// <summary>Disjoin Certainty.</summary>   
let Disjoin (c0:Certainty) 
            (c1:Certainty) = 
  match (c0>c1) with 
    | true  -> c0 
    | false -> c1
    
    
/// <summary>Nature of the proof.</summary>   
type Proof = 
  | Estimated = 0
  | Known     = 1

    
/// <summary>Conjoin Proof.</summary>   
let ConjoinProof (p0:Proof)
                 (p1:Proof) = 
  match p0 with 
    | Proof.Estimated -> p0 
    | _ -> p1
    
    
/// <summary>Evidence for an hypothesis.</summary>   
type Evidence = {
  Certainty : Certainty;
  Proof     : Proof; }
    
    
/// <summary>Hypothesis base.</summary>   
/// <param name="name">External name.</param>
/// <param name="priorEvidence">Prior Evidence value.</param>
[<AbstractClass>]
type Hypothesis (name:string,
                 priorEvidence:Evidence) =

  // Start with the prior certainty.
  let mutable evidence = priorEvidence

  // Name (e.g. user hypothesis).
  member this.Name = name
                       
  //  Get/set Certainty.
  member this.Certainty 
    with get() = evidence.Certainty
    and set c = 
      match (evidence.Proof) with
        | Proof.Known -> 
            raise <| new InvalidOperationException();
        | _ -> evidence <- 
                 { Certainty=c; 
                   Proof=Proof.Estimated }
                       
  //  Get/set Evidence.
  member this.Evidence 
    with get() = evidence
    and set e = 
      match (evidence.Proof) with
        | Proof.Known -> 
            raise <| new InvalidOperationException();
        | _ -> evidence <- e
                       
  //  Get/set Proof.
  member this.Proof 
    with get() = evidence.Proof
    and set p = 
      match (evidence.Proof) with
        | Proof.Known -> 
            raise <| new InvalidOperationException();
        | _ -> evidence <- 
                 { Certainty=evidence.Certainty; 
                   Proof=p }
  
  // Set the known certainty.
  member this.Conclude (c:Certainty) = 
    this.Certainty <- c
    this.Proof <- Proof.Known
    evidence
  
  // Update the proof status.
  member this.Update (c:Certainty,
                         p:Proof) = 
    this.Certainty <- c
    this.Proof <- p
    evidence
  
  // Update the estimated certainty.
  member this.Estimate (c:Certainty) = 
    this.Certainty <- c
    evidence
  
  // Compute an estimate.
  abstract GetEstimate : unit->Evidence
  default this.GetEstimate () = evidence
  
  // Compute proof value.
  abstract Prove : unit->Evidence


/// <summary>A constant fact.</summary>   
/// <param name="name">External name.</param>
/// <param name="certainty">Certainty.</param>
type Fact (name:string,
           certainty:Certainty) =
  inherit Hypothesis (name, 
                      { Certainty=certainty; 
                        Proof=Proof.Known })
  
  // This hypothesis is proven from the start.
  override this.Prove () = this.Evidence
    

/// <summary>A boolean-queried fact.</summary>   
/// <param name="name">External name.</param>
/// <param name="query">User question.</param>
/// <param name="priorCertainty">Certainty if unknown.</param>
type QueryBoolean (name:string,
                   query:string,
                   priorCertainty:Certainty) =
  inherit Hypothesis (name, 
                      { Certainty=priorCertainty; 
                        Proof=Proof.Estimated })
  
  // Proof is based on query:
  //   Yes -> Certain
  //   No -> Impossible
  //   Unknown -> Prior certainty.
  override this.Prove () = 
    match this.Evidence.Proof with
      | Proof.Known -> base.Evidence
      | _ -> this.Conclude
               (match GetQuery(query) with
                 | Query.Yes -> Certainty.Certain
                 | Query.No -> Certainty.Impossible
                 | _ -> this.Certainty)
    

/// <summary>Compound hypothesis.</summary>
/// <param name="name">External name.</param>
/// <param name="antecedents">List of antecedents.</param>
/// <param name="baseCertainty">Accumulator base certainty.</param>
/// <param name="combineCertainty">How to combine certainties.</param>
/// <param name="shortCircuitCertainty">High/low short circuit.</param>
[<AbstractClass>]
type HypothesisCompound (name:string,
                         antecedents:Hypothesis list,
                         baseCertainty:Certainty,
                         combineCertainty:Certainty->Certainty->Certainty,
                         shortCircuitCertainty:Certainty->bool) =
  inherit Hypothesis (name, 
                      { Certainty=Certainty.Possible; 
                        Proof=Proof.Estimated })

//  // Here is a tail-recursive version.
//  member private this.getEstimate c p (l:Hypothesis list) =
//    match l with
//      | [] -> (c, p)
//      | h::t  -> 
//          (h.GetEstimate() |> ignore)
//          this.getEstimate 
//            (combineCertainty c h.Certainty)
//            (ConjoinProof p h.Proof)
//            t
//              
//  override this.GetEstimate () = 
//    match this.Evidence.Proof with
//      | Proof.Known -> this.Evidence
//      | _ -> this.Update 
//               (this.getEstimate baseCertainty 
//                                 Proof.Known 
//                                 antecedents)
              
  // Compute an estimate.
  // Here is a fold version.
  // Note: if all antecedents are Known,
  //       combined certainty will be concluded.
  override this.GetEstimate () = 
    match this.Evidence.Proof with
      | Proof.Known -> this.Evidence
      | _ -> this.Update 
               (List.fold 
                 (fun acc (h:Hypothesis) -> 
                   h.GetEstimate() |> ignore
                   ((combineCertainty (fst acc) h.Certainty),
                    (ConjoinProof (snd acc) h.Proof))) 
                 (baseCertainty,Proof.Known) 
                 antecedents)
  
  // Tail-recursive helper.  
  member private this.prove c (l:Hypothesis list) =
    if shortCircuitCertainty c then c
    else  
      match l with
        | [] -> c
        | h::t -> 
            this.prove
              (combineCertainty c (h.Prove()).Certainty)
               t

  // Compute proof value.
  override this.Prove () =
    match this.Evidence.Proof with
      | Proof.Known -> this.Evidence
      | _ -> this.Conclude 
               (this.prove
                 baseCertainty
                 antecedents)


///<summary>Conjunctive hypothesis.</summary>   
type Conjunction (name:string,
                  antecedents:Hypothesis list,
                  certaintyCutoff:Certainty) =
  inherit HypothesisCompound (name,
                              antecedents,
                              Certainty.Certain,
                              Conjoin,
                              fun c -> c<=certaintyCutoff)
                              

///<summary>Disjunctive hypothesis.</summary>   
type Disjunction (name:string,
                  antecedents:Hypothesis list,
                  certaintyCutoff:Certainty) =
  inherit HypothesisCompound (name,
                              antecedents,
                              Certainty.Impossible,
                              Disjoin,
                              fun c -> c>=certaintyCutoff)


//// Test.

let black  = 
  QueryBoolean(
    "black",  
    "Is it black?", 
    Certainty.Possible)
    
let orange = 
  QueryBoolean(
    "orange", 
    "Is it orange?", 
    Certainty.Possible)
    
let read   = 
  QueryBoolean(
    "read",   
    "Is it read?", 
    Certainty.Possible)
    
let white  = 
  QueryBoolean(
    "white",  
    "Is it white?", 
    Certainty.Possible)

let spotted = 
  QueryBoolean(
    "spotted", 
    "Is it spotted?", 
    Certainty.Possible)
    
let striped = 
  QueryBoolean(
    "striped", 
    "Is it striped?", 
    Certainty.Possible)

let blackAndOrange = 
  Conjunction(
    "blackAndOrange", 
    [ black; orange ], 
    Certainty.Unlikely)
    
let blackAndWhite = 
  Conjunction(
    "blackAndWhite", 
    [ black; white ], 
    Certainty.Unlikely)

let dalmation = 
  Conjunction(
    "dalmation", 
    [ spotted; blackAndWhite ], 
    Certainty.Unlikely)
    
let leopard = 
  Conjunction(
    "leopard",
    [ spotted; blackAndOrange ], 
    Certainty.Unlikely)
    
let newspaper = 
  Conjunction(
    "newspaper",
    [ blackAndWhite; read ], 
    Certainty.Unlikely)
    
let tiger = 
  Conjunction(
    "tiger",
    [ striped; blackAndOrange ], 
    Certainty.Unlikely)
    
let zebra = 
  Conjunction(
    "zebra",
    [ striped; blackAndWhite ], 
    Certainty.Unlikely)

let animal = 
  Disjunction(
    "animal", 
    [ dalmation; leopard; tiger; zebra ], 
    Certainty.Certain)

let thing = 
  Disjunction(
    "thing", 
    [ animal; newspaper ], 
    Certainty.Certain)
   
let PrintEvidence (h:Hypothesis) =
  printfn
    "  %s = %s to be %s"
    h.Name
    (h.Evidence.Proof.ToString())
    (h.Certainty.ToString())
   
let PrintAllEvidence msg =
  printfn "%s" msg
  PrintEvidence dalmation
  PrintEvidence leopard  
  PrintEvidence newspaper  
  PrintEvidence tiger  
  PrintEvidence zebra  
  PrintEvidence animal
  printfn "%s" msg

black.Conclude Certainty.Certain |> ignore
white.Conclude Certainty.Certain |> ignore
read.Conclude  Certainty.Likely  |> ignore

thing.GetEstimate() |> ignore
  
PrintAllEvidence "After Estimate"

thing.Prove() |> ignore
  
PrintAllEvidence "After Prove"

Console.ReadLine() |> ignore

Here’s today’s installment. With this version, I am moving away from a declarative style in the code in favor of objects. This make it simpler to add things like intelligent ordering of proof tests, etc. I did manage to keep the case logic delcarative.

This simple beginning doesn’t yet add very much to previous versions. In fact, it's a temporary step back before hopefully moving forward again. I post it now in case the enhancements are delayed. A few of things that I should point out are:

1) This version adds the concept of proven certainty vs. estimated certainty. This will facilitate later enhancements using estimated results to order queries, etc.

2) I have temporarily removed the idea of short circuiting on anything less than the most extreme certainties (Impossible, Certain). This will be re-added later.

3) I have temporarily removed the ability to continue searching on a disjunction until the most certain hypothesis is proven; it now stops on the first hypothesis proven. This will be re-added later.

4) I added back the ability to query the user for a Boolean.

As always, there is no exhaustive quality control on this; use it at your own risk.

open System
    
    
///<summary>Query helper.</summary>   
let internal GetBoolean q = 
  printf "%s " q
  let key = Console.ReadKey().KeyChar
  printfn ""
  (key='y')||(key='t')|| (key='Y')||(key='T')
    
    
///<summary>Degree of certainty.</summary>   
type Certainty = 
  | Impossible = 0
  | Disproven  = 1
  | Unlikely   = 2
  | Possible   = 3
  | Likely     = 4 
  | Proven     = 5
  | Certain    = 6
    
    
///<summary>Minimum (Certainty).</summary>   
let Min c0 c1 = 
  match (c0<c1) with 
    | true  -> c0 
    | false -> c1
    
    
///<summary>Maximum (Certainty).</summary>   
let Max c0 c1 = 
  match (c0>c1) with 
    | true  -> c0 
    | false -> c1
    
    
///<summary>Nature of the proof.</summary>   
type Proof = 
  | Estimated = 0
  | Known     = 1
    
    
///<summary>Evidence for an hypothesis.</summary>   
type Evidence = {
  Certainty : Certainty;
  Proof     : Proof; }
    
    
///<summary>Most certain evidence.</summary>   
let MostCertain e0 e1 = 
  match (e0.Certainty>=e1.Certainty) with
    | true  -> e0
    | false -> e1
    
    
///<summary>Returns the best of two evidences.</summary>   
let Best e0 e1 = 
  match e0.Proof with 
    | Proof.Known -> 
        match e1.Proof with 
          | Proof.Known -> MostCertain e0 e1
          | _ -> e0
    | _ ->
        match e1.Proof with 
          | Proof.Known -> e1 
          | _ -> MostCertain e0 e1
    

///<summary>Hypothesis base.</summary>   
[<AbstractClass>]
type Hypothesis (name:string) =

  let mutable evidence = { 
    Certainty=Certainty.Impossible; 
    Proof=Proof.Estimated }
                           
  member this.Name = name
  
  member this.Evidence = evidence

  member this.Certainty 
    with get() = evidence.Certainty
    and set c = evidence <- { Certainty=c; 
                              Proof=Proof.Known }

  member this.Proof with get() = evidence.Proof
  
  abstract Prove : unit->Evidence
    

///<summary>A constant fact.</summary>   
type Fact (name:string,
           certainty:Certainty) =
  inherit Hypothesis (name)

  do (base.Certainty<-certainty)
  
  override this.Prove () = base.Evidence
    

///<summary>A boolean-queried fact.</summary>   
type QueryBoolean (name:string,
                   query:string) =
  inherit Hypothesis (name)
  
  override this.Prove () = 
    match base.Evidence.Proof with
      | Proof.Known -> base.Evidence
      | _ -> 
          base.Certainty <- 
            match GetBoolean(query) with
              | true  -> Certainty.Certain 
              | false -> Certainty.Impossible
          base.Evidence
    

///<summary>Compound hypothesis.</summary>   
[<AbstractClass>]
type HypothesisCompound (name:string,
                         antecedents:Hypothesis list) =
  inherit Hypothesis (name)
    

///<summary>Conjunctive hypothesis.</summary>   
type Conjunction (name:string,
                  antecedents:Hypothesis list) =
  inherit HypothesisCompound (name,
                              antecedents)
  
  member private this.prove (l:Hypothesis list) =
    match l with
      | []    -> Certainty.Certain
      | h::[] -> h.Prove().Certainty
      | h::t  -> 
          match h.Prove().Certainty with 
            | Certainty.Impossible -> Certainty.Impossible
            | c -> Min c (this.prove(t))
    
  override this.Prove () = 
    match base.Evidence.Proof with
      | Proof.Known -> base.Evidence
      | _ -> 
          base.Certainty <- this.prove antecedents
          base.Evidence
    

///<summary>Disjunctive hypothesis.</summary>   
type Disjunction (name:string,
                  antecedents:Hypothesis list) =
  inherit HypothesisCompound (name,
                              antecedents)
  
  member private this.prove (l:Hypothesis list) =
    match l with
      | []    -> Certainty.Certain
      | h::[] -> h.Prove().Certainty
      | h::t  -> 
          match h.Prove().Certainty with 
            | Certainty.Certain -> Certainty.Certain
            | c -> Max c (this.prove(t))
    
  override this.Prove () = 
    match base.Evidence.Proof with
      | Proof.Known -> base.Evidence
      | _ -> 
          base.Certainty <- this.prove antecedents
          base.Evidence


// Tests.

let f0 = Fact("f0", Certainty.Certain)
let f1 = Fact("f1", Certainty.Certain)
let f2 = Fact("f2", Certainty.Certain)

let q0 = QueryBoolean("q0", "Is it q0?")
let q1 = QueryBoolean("q1", "Is it q1?")
let q2 = QueryBoolean("q2", "Is it q2?")

let c0 = Conjunction("c0", [ f0; q0 ])
let c1 = Conjunction("c1", [ f1; q1 ])
let c2 = Conjunction("c2", [ f2; q2 ])

let c01 = Conjunction("c01", [ c0; c1 ])

let d0 = Disjunction("d0", [ c01; c2 ])

let x0 = d0.Prove()

printfn "%s %s" 
  (x0.Certainty.ToString()) 
  (x0.Proof.ToString())

Console.ReadLine() |> ignore