constraints framework

constraints.fsx

type Message = | IHaveAValue
               | ILostMyValue
[<ReferenceEquality>]
type Constraint = Constraint of (Message -> unit)

let forEachExcept (except:obj) (procedure: Constraint -> unit) (list: Constraint list) =
  let rec loop (items: Constraint list) =
    match items with
    | [] -> ()
    | h::t when System.Object.ReferenceEquals(h,except) -> loop t
    | h::t -> procedure h
              loop t
  loop list

type Connector<'a> = 'a ref * obj ref * Constraint list ref
let makeConnector<'a> () : Connector<'a> = (ref Unchecked.defaultof<'a>, ref null, ref List.empty)//val, inf, constraints

let hasValue ((_,informant,_) : Connector<'a>) = informant.Value <> null
let getValue ((value,_,_) : Connector<'a>) = value.Value



let informAboutValue (Constraint(c)) = c Message.IHaveAValue
let informAboutNoValue (Constraint(c)) = c Message.ILostMyValue

let setValue ((value,informant,constraints):Connector<'a>) (newval:'a) (setter:obj) =
      if informant.Value = null 
      then 
             value.Value <- newval
             informant.Value <- setter
             forEachExcept setter informAboutValue constraints.Value
      elif not (value.Value = newval)
      then
            failwithf "Contradiction %A" [value.Value;newval]
      else ()
let forgetValue ((value,informant,constraints):Connector<'a>) (retractor:obj) =
      if retractor = informant.Value
      then 
          informant.Value <- null
          forEachExcept retractor informAboutNoValue constraints.Value
          
let connect ((value,informant,constraints):Connector<'a>) (newConstraint:Constraint) = 
      if not (List.contains newConstraint constraints.Value)
      then
          constraints.Value <- newConstraint :: constraints.Value
      if informant.Value <> null then informAboutValue newConstraint

let probe name connector =
  let printProbe value = printfn "Probe: %s %A" name value
  let processNewValue () = printProbe (getValue connector)
  let processForgetValue () = printProbe "?"
  let me request =
    match request with
    | Message.IHaveAValue -> processNewValue()
    | Message.ILostMyValue -> processForgetValue()
  connect connector (Constraint(me))
  me

let constant value connector =
    let me request =
        failwithf "Unknown request -- CONSTANT %A" request
    let me = Constraint(me)
    connect connector me
    setValue connector value me
    me

let multiplier m1 m2 product =
    
    let processNewValue me =
        if ((hasValue m1) && (getValue m1 = 0)) || ((hasValue m2) && (getValue m2 = 0))
            then setValue product 0 me
        elif (hasValue m1) && (hasValue m2)
            then setValue product ((getValue m1) * (getValue m2)) me
        elif (hasValue product) && (hasValue m1)
            then setValue m2 ((getValue product) / (getValue m1)) me
        elif (hasValue product) && (hasValue m2)
            then setValue m1 ((getValue product) / (getValue m2)) me
        else ()    
    let processForgetValue me =
        forgetValue product me
        forgetValue m1 me
        forgetValue m2 me
        processNewValue me
    let rec mer : Constraint ref = ref (Constraint(fun msg->()))
    let me request = 
        if request = Message.IHaveAValue 
        then processNewValue mer.Value
        else processForgetValue mer.Value
    
    mer.Value <- Constraint(me)
    connect m1 mer.Value
    connect m2 mer.Value
    connect product mer.Value
    mer.Value

let adder a1 a2 sum =
  let processNewValue me =
    if (hasValue a1) && (hasValue a2)
    then setValue sum ((getValue a1) + (getValue a2)) me
    elif ((hasValue a1) && (hasValue sum))
    then setValue a2 ((getValue sum) - (getValue a1)) me
    elif (hasValue a2) && (hasValue sum)
    then setValue a1 ((getValue sum) - (getValue a2)) me

  let processForgetValue me =
    forgetValue sum me
    forgetValue a1 me
    forgetValue a2 me
    processNewValue me
  let rec mer : Constraint ref = ref (Constraint(fun msg->()))
  let me request = 
        if request = Message.IHaveAValue 
        then processNewValue mer.Value
        else processForgetValue mer.Value
    
  mer.Value <- Constraint(me)
  connect a1 mer.Value
  connect a2 mer.Value
  connect sum mer.Value
  me

let celsiusFahrenheitConverter c f =
    let u  = makeConnector<int> ()
    let v  = makeConnector ()
    let w  = makeConnector ()
    let x  = makeConnector ()
    let y  = makeConnector ()
    multiplier c w u |> ignore
    multiplier v x u |> ignore
    adder v y f |> ignore
    constant 9 w |> ignore
    constant 5 x |> ignore
    constant 32 y |> ignore

let C = makeConnector<int> ()
let F = makeConnector<int> ()
celsiusFahrenheitConverter C F

probe "Celsius temp" C
probe "Fahrenheit temp" F

setValue C 25 "user"

setValue F 212 "user"

forgetValue C "user"

setValue F 212 "user"